From 188c6f3bf205ca0397299a97a11c5396ae190e66 Mon Sep 17 00:00:00 2001 From: ivan Date: Tue, 26 Sep 2000 20:47:48 +0000 Subject: [PATCH] initial import --- Changes | 8 + DBSchema.pm | 323 ++++++++++++++++++++++++++++++++++++++++ DBSchema/ColGroup.pm | 141 ++++++++++++++++++ DBSchema/ColGroup/Index.pm | 37 +++++ DBSchema/ColGroup/Unique.pm | 38 +++++ DBSchema/Column.pm | 198 +++++++++++++++++++++++++ DBSchema/DBD.pm | 74 ++++++++++ DBSchema/DBD/Pg.pm | 136 +++++++++++++++++ DBSchema/DBD/mysql.pm | 110 ++++++++++++++ DBSchema/Table.pm | 350 ++++++++++++++++++++++++++++++++++++++++++++ MANIFEST | 14 ++ Makefile.PL | 10 ++ README | 41 ++++++ test.pl | 20 +++ 14 files changed, 1500 insertions(+) create mode 100644 Changes create mode 100644 DBSchema.pm create mode 100644 DBSchema/ColGroup.pm create mode 100644 DBSchema/ColGroup/Index.pm create mode 100644 DBSchema/ColGroup/Unique.pm create mode 100644 DBSchema/Column.pm create mode 100644 DBSchema/DBD.pm create mode 100644 DBSchema/DBD/Pg.pm create mode 100644 DBSchema/DBD/mysql.pm create mode 100644 DBSchema/Table.pm create mode 100644 MANIFEST create mode 100644 Makefile.PL create mode 100644 README create mode 100644 test.pl diff --git a/Changes b/Changes new file mode 100644 index 0000000..3ddfdfa --- /dev/null +++ b/Changes @@ -0,0 +1,8 @@ +Revision history for Perl extension DBIx::DBSchema. + +0.02 Mon Sep 25 21:30:32 2000 + - change name from DBIx::Schema + +0.01 Sun Sep 17 07:57:35 2000 + - original version; created by h2xs 1.19 + diff --git a/DBSchema.pm b/DBSchema.pm new file mode 100644 index 0000000..e052bd6 --- /dev/null +++ b/DBSchema.pm @@ -0,0 +1,323 @@ +package DBIx::DBSchema; + +use strict; +use vars qw(@ISA $VERSION); +#use Exporter; +#use Carp qw(verbose); +use DBI; +use FreezeThaw qw(freeze thaw cmpStr); +use DBIx::DBSchema::Table; + +#@ISA = qw(Exporter); +@ISA = (); + +$VERSION = "0.1"; + +=head1 NAME + +DBIx::DBSchema - Database-independent schema objects + +=head1 SYNOPSIS + + use DBIx::DBSchema; + + $schema = new DBIx::DBSchema @dbix_dbschema_table_objects; + $schema = new_from_dsn DBIx::DBSchema $dsn, $user, $pass; + $schema = new_odbc DBIx::DBSchema $dbh; + $schema = new_native DBIx::DBSchema $dbh; + + $schema->save("filename"); + $schema = load DBIx::DBSchema "filename"; + + $schema->addtable($dbix_dbschema_table_object); + + @table_names = $schema->tables; + + $DBIx_DBSchema_table_object = $schema->table("table_name"); + + $sql_string = $schema->sql($dsn); + + $perl_code = $schema->pretty_print; + %hash = eval $perl_code; + $schema = pretty_read DBIx::DBSchema \%hash; + +=head1 DESCRIPTION + +DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and +represent a database schema. + +=head1 METHODS + +=over 4 + +=item new TABLE_OBJECT, TABLE_OBJECT, ... + +Creates a new DBIx::DBSchema object. + +=cut + +sub new { + my($proto, @tables) = @_; + my %tables = map { $_->name, $_ } @tables; #check for duplicates? + + my $class = ref($proto) || $proto; + my $self = { + 'tables' => \%tables, + }; + + bless ($self, $class); + +} + +=item new_odbc_from_dsn DATA_SOURCE USERNAME PASSWORD + +Connects to the specified DBI data source and creates a DBIx::DBSchema object +from it using new_odbc. + +=cut + +sub new_odbc_from_dsn { + my($proto, $dsn, $user, $pass ) = @_; + my $dbh = DBI->connect( $dsn, $user, $pass ) or die $DBI::errstr; + my $self = $proto->new_odbc($dbh); + $dbh->disconnect; #silly DBI + $self; +} + +=item new_odbc DATABASE_HANDLE + +Creates a new DBIx::DBSchema object from the supplied DBI database handle. +This uses the experimental DBI type_info method to create a schema with +standard (ODBC) SQL column types that most closely correspond to any +non-portable column types. Use this to import a schema that you wish to use +with many different database engines. Although primary key and (unique) index +information will only be read from databases with DBIx::DBSchema::DBD drivers +(currently MySQL and PostgreSQL), import of column names and attributes +*should* work for any database. + +=cut + +sub new_odbc { + my($proto, $dbh) = @_; + $proto->new( + map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh) + ); +} + +=item new_native_from_dsn DATA_SOURCE USERNAME PASSWORD + +Connects to the specified DBI data source and creates a DBIx::DBSchema object +from it using new_native. + +=cut + +sub new_native_from_dsn { + my($proto, $dsn, $user, $pass) = @_; + my $dbh = DBI->connect( $dsn, $user, $pass ) or die $DBI::errstr; + my $self = $proto->new_native($dbh); + $dbh->disconnect; #silly DBI + $self; +} + +=item new_native DATABASE_HANDLE + +Creates a new DBIx::DBSchema object from the supplied DBI database handle. This +uses database-native methods to read the schema, and will preserve any +non-portable column types. The method is only available if there is a +DBIx::DBSchema::DBD for the corresponding database engine (currently, MySQL and +PostgreSQL). + +=cut + +sub new_native { + my($proto, $dbh) = @_; + $proto->new( + map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh) + ); +} + +=item load FILENAME + +Loads a DBIx::DBSchema object from a file. + +=cut + +sub load { + my($proto,$file)=@_; #use $proto ? + open(FILE,"<$file") or die "Can't open $file: $!"; + my($string)=join('',); #can $string have newlines? pry not? + close FILE or die "Can't close $file: $!"; + my($self)=thaw $string; + #no bless needed? + $self; +} + +=item save FILENAME + +Saves a DBIx::DBSchema object to a file. + +=cut + +sub save { + my($self,$file)=@_; + my($string)=freeze $self; + open(FILE,">$file") or die "Can't open $file: $!"; + print FILE $string; + close FILE or die "Can't close file: $!"; + my($check_self)=thaw $string; + die "Verify error: Can't freeze and thaw dbdef $self" + if (cmpStr($self,$check_self)); +} + +=item addtable TABLE_OBJECT + +Adds the given DBIx::DBSchema::Table object to this DBIx::DBSchema. + +=cut + +sub addtable { + my($self,$table)=@_; + $self->{'tables'}->{$table->name} = $table; #check for dupliates? +} + +=item tables + +Returns a list of the names of all tables. + +=cut + +sub tables { + my($self)=@_; + keys %{$self->{'tables'}}; +} + +=item table TABLENAME + +Returns the specified DBIx::DBSchema::Table object. + +=cut + +sub table { + my($self,$table)=@_; + $self->{'tables'}->{$table}; +} + +=item sql_string [ DATASRC ] + +Returns a list of SQL `CREATE' statements for this schema. + +If passed a DBI data source such as `DBI:mysql:database' or +`DBI:Pg:dbname=database', will use syntax specific to that database engine. +Currently supported databases are MySQL and PostgreSQL. + +If not passed a data source, or if there is no driver for the specified +database, will attempt to use generic SQL syntax. + +=cut + +sub sql_string { + my($self, $datasrc) = @_; + map { $self->table($_)->sql_create_table($datasrc); } $self->tables; +} + +=item pretty_print + +Returns the data in this schema as Perl source, suitable for assigning to a +hash. + +=cut + +sub pretty_print { + my($self) = @_; + join("},\n\n", + map { + my $table = $_; + "'$table' => {\n". + " 'columns' => [\n". + join("", map { + " '$_', ". + "'". $self->table($table)->column($_)->type. "', ". + "'". $self->table($table)->column($_)->null. "', ". + "'". $self->table($table)->column($_)->length. "'\n" + } $self->table($table)->columns + ). + " ],\n". + " 'primary_key' => '". $self->table($table)->primary_key. "',\n". + " 'unique' => [ ". join(', ', + map { "[ '". join("', '", @{$_}). "' ]" } + @{$self->table($table)->unique->lol_ref} + ). " ],\n". + " 'index' => [ ". join(', ', + map { "[ '". join("', '", @{$_}). "' ]" } + @{$self->table($table)->index->lol_ref} + ). " ],\n" + #" 'index' => [ ". " ],\n" + } $self->tables + ), "}\n"; +} + +=cut + +=item pretty_read HASHREF + +Creates a schema as specified by a data structure such as that created by +B method. + +=cut + +sub pretty_read { + die "unimplemented (pull from fs-setup)"; + my($proto) = @_; +} + +# private subroutines + +sub _load_driver { + my($dbh) = @_; + my $driver = $dbh->{Driver}->{Name}; + #require "DBIx/DBSchema/DBD/$driver.pm"; + #$driver; + eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver; +} + +sub _tables_from_dbh { + my($dbh) = @_; + my $sth = $dbh->table_info or die $dbh->errstr; + #map { $_->{TABLE_NAME} } grep { $_->{TABLE_TYPE} eq 'TABLE' } + # @{ $sth->fetchall_arrayref({ TABLE_NAME=>1, TABLE_TYPE=>1}) }; + map { $_->[0] } grep { $_->[1] =~ /^TABLE$/i } + @{ $sth->fetchall_arrayref([2,3]) }; +} + +=back + +=head1 AUTHOR + +Ivan Kohler + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Each DBIx::DBSchema object should have a name which corresponds to its name +within the SQL database engine (DBI data source). + +pretty_print is atrocious. + +=head1 SEE ALSO + +L, L, +L, L, +L, L, L, +L, L, L + +=cut + +1; + diff --git a/DBSchema/ColGroup.pm b/DBSchema/ColGroup.pm new file mode 100644 index 0000000..ceeb223 --- /dev/null +++ b/DBSchema/ColGroup.pm @@ -0,0 +1,141 @@ +package DBIx::DBSchema::ColGroup; + +use strict; +use vars qw(@ISA); +#use Exporter; + +#@ISA = qw(Exporter); +@ISA = qw(); + +=head1 NAME + +DBIx::DBSchema::ColGroup - Column group objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup; + + $colgroup = new DBIx::DBSchema::ColGroup ( $lol_ref ); + $colgroup = new DBIx::DBSchema::ColGroup ( \@lol ); + $colgroup = new DBIx::DBSchema::ColGroup ( + [ + [ 'single_column' ], + [ 'multiple_columns', 'another_column', ], + ] + ); + + $lol_ref = $colgroup->lol_ref; + + @sql_lists = $colgroup->sql_list; + + @singles = $colgroup->singles; + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup objects represent sets of sets of columns. (IOW a +"list of lists" - see L.) + +=head1 METHODS + +=over 4 + +=item new [ LOL_REF ] + +Creates a new DBIx::DBSchema::ColGroup object. Pass a reference to a list of +lists of column names. + +=cut + +sub new { + my($proto, $lol) = @_; + + my $class = ref($proto) || $proto; + my $self = { + 'lol' => $lol, + }; + + bless ($self, $class); + +} + +=item lol_ref + +Returns a reference to a list of lists of column names. + +=cut + +sub lol_ref { + my($self) = @_; + $self->{'lol'}; +} + +=item sql_list + +Returns a flat list of comma-separated values, for SQL statements. + +For example: + + @lol = ( + [ 'single_column' ], + [ 'multiple_columns', 'another_column', ], + ); + + $colgroup = new DBIx::DBSchema::ColGroup ( \@lol ); + + print join("\n", $colgroup->sql_list), "\n"; + +Will print: + + single_column + multiple_columns, another_column + +=cut + +sub sql_list { #returns a flat list of comman-separates lists (for sql) + my($self)=@_; + grep $_ ne '', map join(', ', @{$_}), @{$self->{'lol'}}; +} + +=item singles + +Returns a flat list of all single item lists. + +=cut + +sub singles { #returns single-field groups as a flat list + my($self)=@_; + #map ${$_}[0], grep scalar(@{$_}) == 1, @{$self->{'lol'}}; + map { + ${$_}[0] =~ /^(\w+)$/ + #aah! + or die "Illegal column ", ${$_}[0], " in colgroup!"; + $1; + } grep scalar(@{$_}) == 1, @{$self->{'lol'}}; +} + +=back + +=head1 AUTHOR + +Ivan Kohler + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L, L, +L, L, L, L, +L + +=cut + +1; + diff --git a/DBSchema/ColGroup/Index.pm b/DBSchema/ColGroup/Index.pm new file mode 100644 index 0000000..1a92baa --- /dev/null +++ b/DBSchema/ColGroup/Index.pm @@ -0,0 +1,37 @@ +package DBIx::DBSchema::ColGroup::Index; + +use strict; +use vars qw(@ISA); +use DBIx::DBSchema::ColGroup; + +@ISA=qw(DBIx::DBSchema::ColGroup); + +=head1 NAME + +DBIx::DBSchema::ColGroup::Index - Index column group object + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup::Index; + + # see DBIx::DBSchema::ColGroup methods + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup::Index objects represent the (non-unique) indices of a +database table (L). DBIx::DBSchema::ColGroup::Index +inherits from DBIx::DBSchema::ColGroup. + +=head1 BUGS + +Is this empty subclass needed? + +=head1 SEE ALSO + +L, L, +L, L, L + +=cut + +1; + diff --git a/DBSchema/ColGroup/Unique.pm b/DBSchema/ColGroup/Unique.pm new file mode 100644 index 0000000..450043f --- /dev/null +++ b/DBSchema/ColGroup/Unique.pm @@ -0,0 +1,38 @@ +package DBIx::DBSchema::ColGroup::Unique; + +use strict; +use vars qw(@ISA); +use DBIx::DBSchema::ColGroup; + +@ISA=qw(DBIx::DBSchema::ColGroup); + +=head1 NAME + +DBIx::DBSchema::ColGroup::Unique - Unique column group object + +=head1 SYNOPSIS + + use DBIx::DBSchema::ColGroup::Unique; + + # see DBIx::DBSchema::ColGroup methods + +=head1 DESCRIPTION + +DBIx::DBSchema::ColGroup::Unique objects represent the unique indices of a +database table (L). DBIx::DBSchema::ColGroup:Unique +inherits from DBIx::DBSchema::ColGroup. + +=head1 BUGS + +Is this empty subclass needed? + +=head1 SEE ALSO + +L, L, +L, L, L + +=cut + +1; + + diff --git a/DBSchema/Column.pm b/DBSchema/Column.pm new file mode 100644 index 0000000..b7ab18f --- /dev/null +++ b/DBSchema/Column.pm @@ -0,0 +1,198 @@ +package DBIx::DBSchema::Column; + +use strict; +use vars qw(@ISA); +#use Carp; +#use Exporter; + +#@ISA = qw(Exporter); +@ISA = qw(); + +=head1 NAME + +DBIx::DBSchema::Column - Column objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::Column; + + $column = new DBIx::DBSchema::Column ( $name, $sql_type, '' ); + $column = new DBIx::DBSchema::Column ( $name, $sql_type, 'NULL' ); + $column = new DBIx::DBSchema::Column ( $name, $sql_type, '', $length ); + $column = new DBIx::DBSchema::Column ( $name, $sql_type, 'NULL', $length ); + + $name = $column->name; + $column->name( 'name' ); + + $sql_type = $column->type; + $column->sql_type( 'sql_type' ); + + $null = $column->null; + $column->null( 'NULL' ); + $column->null( 'NOT NULL' ); + $column->null( '' ); + + $length = $column->length; + $column->length( '10' ); + $column->length( '8,2' ); + + $sql_line = $column->line; + $sql_line = $column->line($datasrc); + +=head1 DESCRIPTION + +DBIx::DBSchema::Column objects represent columns in tables (see +L). + +=head1 METHODS + +=over 4 + +=item new [ NAME [ , SQL_TYPE [ , NULL [ , LENGTH ] ] ] ] + +Creates a new DBIx::DBSchema::Column object. NAME is the name of the column. +SQL_TYPE is the SQL data type. NULL is the nullability of the column (the +empty string is equivalent to `NOT NULL'). LENGTH is the SQL length of the +column. + +=cut + +sub new { + my($proto,$name,$type,$null,$length)=@_; + + #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; + + $null =~ s/^NOT NULL$//i; + $null = 'NULL' if $null; + + my $class = ref($proto) || $proto; + my $self = { + 'name' => $name, + 'type' => $type, + 'null' => $null, + 'length' => $length, + }; + + bless ($self, $class); + +} + +=item name [ NAME ] + +Returns or sets the column name. + +=cut + +sub name { + my($self,$value)=@_; + if ( defined($value) ) { + #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; + $self->{'name'} = $value; + } else { + $self->{'name'}; + } +} + +=item type [ TYPE ] + +Returns or sets the column type. + +=cut + +sub type { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'type'} = $value; + } else { + $self->{'type'}; + } +} + +=item null [ NULL ] + +Returns or sets the column null flag (the empty string is equivalent to +`NOT NULL') + +=cut + +sub null { + my($self,$value)=@_; + if ( defined($value) ) { + $value =~ s/^NOT NULL$//i; + $value = 'NULL' if $value; + $self->{'null'} = $value; + } else { + $self->{'null'}; + } +} + +=item length [ LENGTH ] + +Returns or sets the column length. + +=cut + +sub length { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'length'} = $value; + } else { + $self->{'length'}; + } +} + +=item line [ $datasrc ] + +Returns an SQL column definition. + +If passed a DBI data source such as `DBI:mysql:database' or +`DBI:Pg:dbname=database', will use syntax specific to that database engine. +Currently supported databases are MySQL and PostgreSQL. Non-standard syntax +for other engines (if applicable) may also be supported in the future. + +=cut + +sub line { + my($self,$datasrc)=@_; + my($null)=$self->null; + if ( $datasrc =~ /^dbi:mysql:/i ) { #yucky mysql hack + $null ||= "NOT NULL" + } + if ( $datasrc =~ /^dbi:pg/i ) { #yucky Pg hack + $null ||= "NOT NULL"; + $null =~ s/^NULL$//; + } + join(' ', + $self->name, + $self->type. ( $self->length ? '('.$self->length.')' : '' ), + $null, + ); +} + +=back + +=head1 AUTHOR + +Ivan Kohler + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +line() has database-specific foo that probably ought to be abstracted into +the DBIx::DBSchema:DBD:: modules. + +=head1 SEE ALSO + +L, L, L, L + +=cut + +1; + diff --git a/DBSchema/DBD.pm b/DBSchema/DBD.pm new file mode 100644 index 0000000..a3a65f2 --- /dev/null +++ b/DBSchema/DBD.pm @@ -0,0 +1,74 @@ +package DBIx::DBSchema::DBD; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.01'; + +=head1 NAME + +DBIx::DBSchema::DBD - DBIx::DBSchema Driver Writer's Guide + +=head1 SYNOPSIS + + perldoc DBIx::DBSchema::DBD + +=head1 DESCRIPTION + +Drivers should be named DBIx::DBSchema::DBD::DatabaseName, where DatabaseName +is the same as the DBD:: driver for this database. Drivers should implement the +following class methods: + +=over 4 + +=item columns CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a listref of listrefs (see +L), each containing four elements: column name, column type, +nullability, and column length. + +=item primary_key CLASS DBI_DBH TABLE + +Given an active DBI database handle, return the primary key for the specified +table. + +=item unique CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a hashref of unique indices. The +keys of the hashref are index names, and the values are arrayrefs which point +a list of column names for each. See L and +L. + +=item index CLASS DBI_DBH TABLE + +Given an active DBI database handle, return a hashref of (non-unique) indices. +The keys of the hashref are index names, and the values are arrayrefs which +point a list of column names for each. See L and +L. + +=back + +=head1 AUTHOR + +Ivan Kohler + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L, L, L, +L, L, L, L, +L + +=cut + +1; + diff --git a/DBSchema/DBD/Pg.pm b/DBSchema/DBD/Pg.pm new file mode 100644 index 0000000..b41a98c --- /dev/null +++ b/DBSchema/DBD/Pg.pm @@ -0,0 +1,136 @@ +package DBIx::DBSchema::DBD::Pg; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.01'; + +=head1 NAME + +DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a PostgreSQL-native driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<errstr; + SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '$table' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid +END + $sth->execute or die $sth->errstr; + map { + [ + $_->{'attname'}, + $_->{'typname'}, + ! $_->{'attnotnull'}, + $_->{'attlen'} == -1 + ? $_->{'atttypmod'} - 4 + : '' + ] + } @{ $sth->fetchall_arrayref({}) }; +} + +sub primary_key { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<errstr; + SELECT a.attname, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '${table}_pkey' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid +END + $sth->execute or die $sth->errstr; + my $row = $sth->fetchrow_hashref or return ''; + $row->{'attname'}; +} + +sub unique { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } + grep { $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub index { + my($proto, $dbh, $table) = @_; + my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] } + grep { ! $proto->_is_unique($dbh, $_ ) } + $proto->_all_indices($dbh, $table) + }; +} + +sub _all_indices { + my($proto, $dbh, $table) = @_; + my $sth = $dbh->prepare(<errstr; + SELECT c2.relname + FROM pg_class c, pg_class c2, pg_index i + WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid +END + $sth->execute or die $sth->errstr; + map { $_->{'relname'} } + grep { $_->{'relname'} !~ /_pkey$/ } + @{ $sth->fetchall_arrayref({}) }; +} + +sub _index_fields { + my($proto, $dbh, $index) = @_; + my $sth = $dbh->prepare(<errstr; + SELECT a.attname, a.attnum + FROM pg_class c, pg_attribute a, pg_type t + WHERE c.relname = '$index' + AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid +END + $sth->execute or die $sth->errstr; + map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) }; +} + +sub _is_unique { + my($proto, $dbh, $index) = @_; + my $sth = $dbh->prepare(<errstr; + SELECT i.indisunique + FROM pg_index i, pg_class c, pg_am a + WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid +END + $sth->execute or die $sth->errstr; + my $row = $sth->fetchrow_hashref or die 'guru meditation #420'; + $row->{'indisunique'}; +} + +=head1 AUTHOR + +Ivan Kohler + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +Yes. + +=head1 SEE ALSO + +L, L, L, L + +=cut + +1; + diff --git a/DBSchema/DBD/mysql.pm b/DBSchema/DBD/mysql.pm new file mode 100644 index 0000000..08c457b --- /dev/null +++ b/DBSchema/DBD/mysql.pm @@ -0,0 +1,110 @@ +package DBIx::DBSchema::DBD::mysql; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.01'; + +=head1 NAME + +DBIx::DBSchema::DBD::mysql - MySQL native driver for DBIx::DBSchema + +=head1 SYNOPSIS + +use DBI; +use DBIx::DBSchema; + +$dbh = DBI->connect('dbi:mysql:database', 'user', 'pass'); +$schema = new_native DBIx::DBSchema $dbh; + +=head1 DESCRIPTION + +This module implements a MySQL-native driver for DBIx::DBSchema. + +=cut + +sub columns { + my($proto, $dbh, $table ) = @_; + my $sth = $dbh->prepare("SHOW COLUMNS FROM $table") or die $dbh->errstr; + $sth->execute or die $sth->errstr; + map { + $_->{'Type'} =~ /^(\w+)\(?([\d\,]+)?\)?( unsigned)?$/ + or die "Illegal type: ". $_->{'Type'}. "\n"; + my($type, $length) = ($1, $2); + [ $_->{'Field'}, $type, $_->{'Null'}, $length ] + } @{ $sth->fetchall_arrayref( {} ) }; +} + +#sub primary_key { +# my($proto, $dbh, $table ) = @_; +# my $primary_key = ''; +# my $sth = $dbh->prepare("SHOW INDEX FROM $table") +# or die $dbh->errstr; +# $sth->execute or die $sth->errstr; +# my @pkey = map { $_->{'Column_name'} } grep { +# $_->{'Key_name'} eq "PRIMARY" +# } @{ $sth->fetchall_arrayref( {} ) }; +# scalar(@pkey) ? $pkey[0] : ''; +#} + +sub primary_key { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $pkey; +} + +sub unique { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $unique_href; +} + +sub index { + my($proto, $dbh, $table) = @_; + my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table); + $index_href; +} + +sub _show_index { + my($proto, $dbh, $table ) = @_; + my $sth = $dbh->prepare("SHOW INDEX FROM $table") + or die $dbh->errstr; + $sth->execute or die $sth->errstr; + + my $pkey = ''; + my(%index, %unique); + foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) { + if ( $row->{'Key_name'} eq 'PRIMARY' ) { + $pkey = $row->{'Column_name'}; + } elsif ( $row->{'Non_unique'} ) { #index + push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'}; + } else { #unique + push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'}; + } + } + + ( $pkey, \%unique, \%index ); +} + +=head1 AUTHOR + +Ivan Kohler + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +=head1 SEE ALSO + +L, L, L, L + +=cut + +1; + diff --git a/DBSchema/Table.pm b/DBSchema/Table.pm new file mode 100644 index 0000000..b4f66b6 --- /dev/null +++ b/DBSchema/Table.pm @@ -0,0 +1,350 @@ +package DBIx::DBSchema::Table; + +use strict; +use vars qw(@ISA %create_params); +#use Carp; +use Exporter; +use DBIx::DBSchema::Column; +use DBIx::DBSchema::ColGroup::Unique; +use DBIx::DBSchema::ColGroup::Index; + +#@ISA = qw(Exporter); +@ISA = qw(); + +=head1 NAME + +DBIx::DBSchema::Table - Table objects + +=head1 SYNOPSIS + + use DBIx::DBSchema::Table; + + $table = new DBIx::DBSchema::Table ( + "table_name", + "primary_key", + $dbix_dbschema_colgroup_unique_object, + $dbix_dbschema_colgroup_index_object, + @dbix_dbschema_column_objects, + ); + + $table->addcolumn ( $dbix_dbschema_column_object ); + + $table_name = $table->name; + $table->name("table_name"); + + $primary_key = $table->primary_key; + $table->primary_key("primary_key"); + + $dbix_dbschema_colgroup_unique_object = $table->unique; + $table->unique( $dbix_dbschema__colgroup_unique_object ); + + $dbix_dbschema_colgroup_index_object = $table->index; + $table->index( $dbix_dbschema_colgroup_index_object ); + + @column_names = $table->columns; + + $dbix_dbschema_column_object = $table->column("column"); + + @sql_statements = $table->sql_create_table; + @sql_statements = $table->sql_create_table $datasrc; + +=head1 DESCRIPTION + +DBIx::DBSchema::Table objects represent a single database table. + +=head1 METHODS + +=over 4 + +=item new [ TABLE_NAME [ , PRIMARY_KEY [ , UNIQUE [ , INDEX [ , COLUMN... ] ] ] ] ] + +Creates a new DBIx::DBSchema::Table object. TABLE_NAME is the name of the +table. PRIMARY_KEY is the primary key (may be empty). UNIQUE is a +DBIx::DBSchema::ColGroup::Unique object (see +L). INDEX is a +DBIx::DBSchema::ColGroup::Index object (see +L). The rest of the arguments should be +DBIx::DBSchema::Column objects (see L). + +=cut + +sub new { + my($proto,$name,$primary_key,$unique,$index,@columns)=@_; + + my(%columns) = map { $_->name, $_ } @columns; + + #check $primary_key, $unique and $index to make sure they are $columns ? + # (and sanity check?) + + my $class = ref($proto) || $proto; + my $self = { + 'name' => $name, + 'primary_key' => $primary_key, + 'unique' => $unique, + 'index' => $index, + 'columns' => \%columns, + }; + + bless ($self, $class); + +} + +=item new_odbc DATABASE_HANDLE TABLE_NAME + +Creates a new DBIx::DBSchema::Table object from the supplied DBI database +handle for the specified table. This uses the experimental DBI type_info +method to create a table with standard (ODBC) SQL column types that most +closely correspond to any non-portable column types. Use this to import a +schema that you wish to use with many different database engines. Although +primary key and (unique) index information will only be imported from databases +with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of +column names and attributes *should* work for any database. + +=cut + +%create_params = ( +# undef => sub { '' }, + '' => sub { '' }, + 'max length' => sub { $_[0]->{PRECISION}->[$_[1]]; }, + 'precision,scale' => + sub { $_[0]->{PRECISION}->[$_[1]]. ','. $_[0]->{SCALE}->[$_[1]]; } +); + +sub new_odbc { + my( $proto, $dbh, $name) = @_; + #my $driver = DBIx::DBSchema::_load_driver($dbh); + my $driver = DBIx::DBSchema::_load_driver(DBI->connect("dbi:CSV:dbname=testfile", "postgres", "")); + my $sth = _null_sth($dbh, $name); + my $sthpos = 0; + $proto->new ( + $name, + scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), + DBIx::DBSchema::ColGroup::Unique->new( + $driver + ? [values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"}] + : [] + ), + DBIx::DBSchema::ColGroup::Index->new( + $driver + ? [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] + : [] + ), + map { + my $type_info = scalar($dbh->type_info($sth->{TYPE}->[$sthpos])) + or die "null return from DBI::type_info"; + new DBIx::DBSchema::Column + $_, + $type_info->{'TYPE_NAME'}, + $sth->{NULLABLE}->[$sthpos], + &{ + $create_params{ $type_info->{CREATE_PARAMS} } + }( $sth, $sthpos++ ) + } @{$sth->{NAME}} + ); +} + +=item new_native DATABASE_HANDLE TABLE_NAME + +Creates a new DBIx::DBSchema::Table object from the supplied DBI database +handle for the specified table. This uses database-native methods to read the +schema, and will preserve any non-portable column types. The method is only +available if there is a DBIx::DBSchema::DBD for the corresponding database +engine (currently, MySQL and PostgreSQL). + +=cut + +sub new_native { + my( $proto, $dbh, $name) = @_; + my $driver = DBIx::DBSchema::_load_driver($dbh); + $proto->new ( + $name, + scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"), + DBIx::DBSchema::ColGroup::Unique->new( + [ values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"} ] + ), + DBIx::DBSchema::ColGroup::Index->new( + [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ] + ), + map { + DBIx::DBSchema::Column->new( @{$_} ) + } eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)" + ); +} + +=item addcolumn COLUMN + +Adds this DBIx::DBSchema::Column object. + +=cut + +sub addcolumn { + my($self,$column)=@_; + ${$self->{'columns'}}{$column->name}=$column; #sanity check? +} + +=item name [ TABLE_NAME ] + +Returns or sets the table name. + +=cut + +sub name { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{name} = $value; + } else { + $self->{name}; + } +} + +=item primary_key [ PRIMARY_KEY ] + +Returns or sets the primary key. + +=cut + +sub primary_key { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{primary_key} = $value; + } else { + #$self->{primary_key}; + #hmm. maybe should untaint the entire structure when it comes off disk + # cause if you don't trust that, ? + $self->{primary_key} =~ /^(\w*)$/ + #aah! + or die "Illegal primary key: ", $self->{primary_key}; + $1; + } +} + +=item unique [ UNIQUE ] + +Returns or sets the DBIx::DBSchema::ColGroup::Unique object. + +=cut + +sub unique { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{unique} = $value; + } else { + $self->{unique}; + } +} + +=item index [ INDEX ] + +Returns or sets the DBIx::DBSchema::ColGroup::Index object. + +=cut + +sub index { + my($self,$value)=@_; + if ( defined($value) ) { + $self->{'index'} = $value; + } else { + $self->{'index'}; + } +} + +=item columns + +Returns a list consisting of the names of all columns. + +=cut + +sub columns { + my($self)=@_; + keys %{$self->{'columns'}}; +} + +=item column COLUMN_NAME + +Returns the column object (see L) for the specified +COLUMN_NAME. + +=cut + +sub column { + my($self,$column)=@_; + $self->{'columns'}->{$column}; +} + +=item sql_create_table [ DATASRC ] + +Returns a list of SQL statments to create this table. + +If passed a DBI data source such as `DBI:mysql:database', will use +MySQL-specific syntax. PostgreSQL is also supported (requires no special +syntax). Non-standard syntax for other engines (if applicable) may also be +supported in the future. + +=cut + +sub sql_create_table { + my($self,$datasrc)=@_; + + my(@columns)=map { $self->column($_)->line($datasrc) } $self->columns; + push @columns, "PRIMARY KEY (". $self->primary_key. ")" + if $self->primary_key; + if ( $datasrc =~ /^dbd:mysql:/i ) { #yucky mysql hack + push @columns, map "UNIQUE ($_)", $self->unique->sql_list; + push @columns, map "INDEX ($_)", $self->index->sql_list; + } + + "CREATE TABLE ". $self->name. " ( ". join(", ", @columns). " )", + ( map { + my($index) = $self->name. "__". $_ . "_index"; + $index =~ s/,\s*/_/g; + "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)" + } $self->unique->sql_list ), + ( map { + my($index) = $self->name. "__". $_ . "_index"; + $index =~ s/,\s*/_/g; + "CREATE INDEX $index ON ". $self->name. " ($_)" + } $self->index->sql_list ), + ; + +} + +# + +sub _null_sth { + my($dbh, $table) = @_; + my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0") + or die $dbh->errstr; + $sth->execute or die $sth->errstr; + $sth; +} + +=back + +=head1 AUTHOR + +Ivan Kohler + +=head1 COPYRIGHT + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=head1 BUGS + +sql_create_table() has database-specific foo that probably ought to be +abstracted into the DBIx::DBSchema::DBD:: modules. + +Some of the logic in new_odbc might be better abstracted into Column.pm etc. + +=head1 SEE ALSO + +L, L, +L, L, L + +=cut + +1; + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..165823a --- /dev/null +++ b/MANIFEST @@ -0,0 +1,14 @@ +Changes +MANIFEST +README +Makefile.PL +DBSchema.pm +test.pl +DBSchema/Table.pm +DBSchema/ColGroup.pm +DBSchema/ColGroup/Index.pm +DBSchema/ColGroup/Unique.pm +DBSchema/Column.pm +DBSchema/DBD.pm +DBSchema/DBD/mysql.pm +DBSchema/DBD/Pg.pm diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..4a76d59 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,10 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'DBIx::DBSchema', + 'VERSION_FROM' => 'DBSchema.pm', # finds $VERSION + 'PREREQ_PM' => { + 'DBI' => 0, + }, +); diff --git a/README b/README new file mode 100644 index 0000000..2d1c2e2 --- /dev/null +++ b/README @@ -0,0 +1,41 @@ +DBIx::DBSchema + +Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000 Mail Abuse Prevention System LLC +All rights reserved. +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +This module implements an OO-interface to database schemas. Using this module, +you can create a database schema with an OO Perl interface. You can read the +schema from an existing database. You can save the schema to disk and restore +it a different process. Most importantly, DBIx::DBSchema can write SQL +statements to create the given schema. + +Currently supported databases are MySQL and PostgreSQL. DBIx::DBSchema will +attempt to use generic SQL syntax for other databases. Assistance adding +support for other databases is welcomed. + +To install: + perl Makefile.PL + make + make test # nothing substantial yet + make install + +Documentation will then be available via `man DBIx::DBSchema' or +`perldoc DBIx::DBSchema'. + +Anonymous CVS access is available: + $ export CVSROOT=":pserver:anonymous@cleanwhisker.420.am:/home/cvs/cvsroot" + $ cvs login + (Logging in to anonymous@cleanwhisker.420.am) + CVS password: anonymous + $ cvs checkout DBIx-DBSchema +as well as . + +A mailing list is available. Send a blank message to +. + +Homepage: + +$Id: README,v 1.2 2000-09-27 11:51:36 ivan Exp $ diff --git a/test.pl b/test.pl new file mode 100644 index 0000000..2948bbe --- /dev/null +++ b/test.pl @@ -0,0 +1,20 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..1\n"; } +END {print "not ok 1\n" unless $loaded;} +use DBIx::DBSchema; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + -- 2.11.0