X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=DBSchema.pm;h=4ff8fa0ae6f22b59e8700607e85a335ba3447108;hb=b604a6e28009f97d206156bf3fa1eeeb6b5063f9;hp=e052bd6b85161553a6dd7ab4d2893394bd5528d1;hpb=188c6f3bf205ca0397299a97a11c5396ae190e66;p=DBIx-DBSchema.git diff --git a/DBSchema.pm b/DBSchema.pm index e052bd6..4ff8fa0 100644 --- a/DBSchema.pm +++ b/DBSchema.pm @@ -1,17 +1,19 @@ 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; +use vars qw($VERSION $DEBUG $errstr); +use Storable; +use DBIx::DBSchema::_util qw(_load_driver _dbh); +use DBIx::DBSchema::Table 0.05; +use DBIx::DBSchema::Index; +use DBIx::DBSchema::Column; +use DBIx::DBSchema::ColGroup::Unique; +use DBIx::DBSchema::ColGroup::Index; -#@ISA = qw(Exporter); -@ISA = (); +$VERSION = "0.34_01"; +$VERSION = eval $VERSION; # modperlstyle: convert the string into a number -$VERSION = "0.1"; +$DEBUG = 0; =head1 NAME @@ -22,12 +24,13 @@ DBIx::DBSchema - Database-independent schema objects 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_odbc DBIx::DBSchema $dsn, $user, $pass; $schema = new_native DBIx::DBSchema $dbh; + $schema = new_native DBIx::DBSchema $dsn, $user, $pass; $schema->save("filename"); - $schema = load DBIx::DBSchema "filename"; + $schema = load DBIx::DBSchema "filename" or die $DBIx::DBSchema::errstr; $schema->addtable($dbix_dbschema_table_object); @@ -35,17 +38,33 @@ DBIx::DBSchema - Database-independent schema objects $DBIx_DBSchema_table_object = $schema->table("table_name"); - $sql_string = $schema->sql($dsn); + @sql = $schema->sql($dbh); + @sql = $schema->sql($dsn, $username, $password); + @sql = $schema->sql($dsn); #doesn't connect to database - less reliable $perl_code = $schema->pretty_print; %hash = eval $perl_code; - $schema = pretty_read DBIx::DBSchema \%hash; + use DBI qw(:sql_types); $schema = pretty_read DBIx::DBSchema \%hash; =head1 DESCRIPTION DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and represent a database schema. +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 in a different process. You can write SQL CREATE statements statements for +different databases from a single source. In recent versions, you can +transform one schema to another, adding any necessary new columns and tables +(and, as of 0.33, indices). + +Currently supported databases are MySQL, PostgreSQL and SQLite. Sybase and +Oracle drivers are partially implemented. DBIx::DBSchema will attempt to use +generic SQL syntax for other databases. Assistance adding support for other +databases is welcomed. See L, "Driver Writer's Guide and +Base Class". + =head1 METHODS =over 4 @@ -69,68 +88,41 @@ sub new { } -=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 +=item new_odbc DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ] -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. +Creates a new DBIx::DBSchema object from an existing data source, which can be +specified by passing an open DBI database handle, or by passing the DBI data +source name, username, and password. 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. Note that this +method only uses "ODBC" column types; it does not require or use an ODBC +driver. =cut sub new_odbc { - my($proto, $dbh) = @_; + my($proto, $dbh) = ( shift, _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 +=item new_native DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ] -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). +Creates a new DBIx::DBSchema object from an existing data source, which can be +specified by passing an open DBI database handle, or by passing the DBI data +source name, username and password. 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) = @_; + my($proto, $dbh) = (shift, _dbh(@_) ); $proto->new( map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh) ); @@ -138,18 +130,41 @@ sub new_native { =item load FILENAME -Loads a DBIx::DBSchema object from a file. +Loads a DBIx::DBSchema object from a file. If there is an error, returns +false and puts an error message in $DBIx::DBSchema::errstr; =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? + + my $self; + + #first try Storable + eval { $self = Storable::retrieve($file); }; + + if ( $@ && $@ =~ /not.*storable/i ) { #then try FreezeThaw + my $olderror = $@; + + eval "use FreezeThaw;"; + if ( $@ ) { + $@ = $olderror; + } else { + open(FILE,"<$file") + or do { $errstr = "Can't open $file: $!"; return ''; }; + my $string = join('',); + close FILE + or do { $errstr = "Can't close $file: $!"; return ''; }; + ($self) = FreezeThaw::thaw($string); + } + } + + unless ( $self ) { + $errstr = $@; + } + $self; + } =item save FILENAME @@ -159,14 +174,8 @@ 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)); + #my($self, $file) = @_; + Storable::nstore(@_); } =item addtable TABLE_OBJECT @@ -202,22 +211,118 @@ sub table { $self->{'tables'}->{$table}; } -=item sql_string [ DATASRC ] +=item sql [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] Returns a list of SQL `CREATE' statements for this schema. -If passed a DBI data source such as `DBI:mysql:database' or +The data source can be specified by passing an open DBI database handle, or by +passing the DBI data source name, username and password. + +Although the username and password are optional, it is best to call this method +with a database handle or data source including a valid username and password - +a DBI connection will be opened and the quoting and type mapping will be more +reliable. + +If passed a DBI data source (or handle) 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. +If not passed a data source (or handle), 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; +sub sql { + my($self, $dbh) = ( shift, _dbh(@_) ); + map { $self->table($_)->sql_create_table($dbh); } $self->tables; +} + +=item sql_update_schema PROTOTYPE_SCHEMA [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ] + +Returns a list of SQL statements to update this schema so that it is idential +to the provided prototype schema, also a DBIx::DBSchema object. + + #Optionally, the data source can be specified by passing an open DBI database + #handle, or by passing the DBI data source name, username and password. + # + #If passed a DBI data source (or handle) 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 handle), or if there is no driver for the + #specified database, will attempt to use generic SQL syntax. + +Right now this method knows how to add new tables and alter existing tables. +It doesn't know how to drop tables yet. + +See L, +L and +L for additional specifics and +limitations. + +=cut + +#gosh, false laziness w/DBSchema::Table::sql_alter_schema + +sub sql_update_schema { + my($self, $new, $dbh) = ( shift, shift, _dbh(@_) ); + + my @r = (); + + foreach my $table ( $new->tables ) { + + if ( $self->table($table) ) { + + warn "$table exists\n" if $DEBUG > 1; + + push @r, + $self->table($table)->sql_alter_table( $new->table($table), $dbh ); + + } else { + + warn "table $table does not exist.\n" if $DEBUG; + + push @r, + $new->table($table)->sql_create_table( $dbh ); + + } + + } + + # drop tables not in $new + foreach my $table ( $self->tables ) { + + if ( !$new->table($table) ) { + + warn "table $table should be dropped.\n" if $DEBUG; + + push @r, + $self->table($table)->sql_drop_table( $dbh ); + } + } + + warn join("\n", @r). "\n" + if $DEBUG > 1; + + @r; + +} + +=item update_schema PROTOTYPE_SCHEMA, DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] + +Same as sql_update_schema, except actually runs the SQL commands to update +the schema. Throws a fatal error if any statement fails. + +=cut + +sub update_schema { + my($self, $new, $dbh) = ( shift, shift, _dbh(@_) ); + + foreach my $statement ( $self->sql_update_schema( $new, $dbh ) ) { + $dbh->do( $statement ) + or die "Error: ". $dbh->errstr. "\n executing: $statement"; + } + } =item pretty_print @@ -229,31 +334,74 @@ hash. sub pretty_print { my($self) = @_; + join("},\n\n", map { - my $table = $_; - "'$table' => {\n". + my $tablename = $_; + my $table = $self->table($tablename); + my %indices = $table->indices; + + "'$tablename' => {\n". " 'columns' => [\n". join("", map { + #cant because -w complains about , in qw() + # (also biiiig problems with empty lengths) + #" qw( $_ ". + #$table->column($_)->type. " ". + #( $table->column($_)->null ? 'NULL' : 0 ). " ". + #$table->column($_)->length. " ),\n" " '$_', ". - "'". $self->table($table)->column($_)->type. "', ". - "'". $self->table($table)->column($_)->null. "', ". - "'". $self->table($table)->column($_)->length. "'\n" - } $self->table($table)->columns + "'". $table->column($_)->type. "', ". + "'". $table->column($_)->null. "', ". + "'". $table->column($_)->length. "', ". + "'". $table->column($_)->default. "', ". + "'". $table->column($_)->local. "',\n" + } $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" + " 'primary_key' => '". $table->primary_key. "',\n". + + #old style index representation.. + + ( + $table->{'unique'} # $table->_unique + ? " 'unique' => [ ". join(', ', + map { "[ '". join("', '", @{$_}). "' ]" } + @{$table->_unique->lol_ref} + ). " ],\n" + : '' + ). + + ( $table->{'index'} # $table->_index + ? " 'index' => [ ". join(', ', + map { "[ '". join("', '", @{$_}). "' ]" } + @{$table->_index->lol_ref} + ). " ],\n" + : '' + ). + + #new style indices + " 'indices' => { ". join( ",\n ", + + map { my $iname = $_; + my $index = $indices{$iname}; + "'$iname' => { \n". + ( $index->using + ? " 'using' => '". $index->using ."',\n" + : '' + ). + " 'unique' => ". $index->_unique .",\n". + " 'columns' => [ '". + join("', '", @{$index->columns} ). + "' ],\n". + " },\n"; + } + keys %indices + + ). "\n }, \n" + } $self->tables - ), "}\n"; + ). "}\n"; } =cut @@ -266,23 +414,57 @@ B method. =cut sub pretty_read { - die "unimplemented (pull from fs-setup)"; - my($proto) = @_; + my($proto, $href) = @_; + + my $schema = $proto->new( map { + + my $tablename = $_; + my $info = $href->{$tablename}; + + my @columns; + while ( @{$info->{'columns'}} ) { + push @columns, DBIx::DBSchema::Column->new( + splice @{$info->{'columns'}}, 0, 6 + ); + } + + DBIx::DBSchema::Table->new({ + 'name' => $tablename, + 'primary_key' => $info->{'primary_key'}, + 'columns' => \@columns, + + #old-style indices + 'unique' => DBIx::DBSchema::ColGroup::Unique->new($info->{'unique'}), + 'index' => DBIx::DBSchema::ColGroup::Index->new($info->{'index'}), + + #new-style indices + 'indices' => [ map { my $idx_info = $info->{'indices'}{$_}; + DBIx::DBSchema::Index->new({ + 'name' => $_, + #'using' => + 'unique' => $idx_info->{'unique'}, + 'columns' => $idx_info->{'columns'}, + }); + } + keys %{ $info->{'indices'} } + ], + } ); + + } (keys %{$href}) ); + } # 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; + my $driver = _load_driver($dbh); + my $db_catalog = + scalar(eval "DBIx::DBSchema::DBD::$driver->default_db_catalog"); + my $db_schema = + scalar(eval "DBIx::DBSchema::DBD::$driver->default_db_schema"); + my $sth = $dbh->table_info($db_catalog, $db_schema, '', 'TABLE') + 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 } @@ -291,31 +473,75 @@ sub _tables_from_dbh { =back -=head1 AUTHOR +=head1 AUTHORS Ivan Kohler +Charles Shapiro and Mitchell Friedman + contributed the start of a Sybase driver. + +Daniel Hanks contributed the Oracle driver. + +Jesse Vincent contributed the SQLite driver. + +=head1 CONTRIBUTIONS + +Contributions are welcome! I'm especially keen on any interest in the top +items/projects below under BUGS. + =head1 COPYRIGHT -Copyright (c) 2000 Ivan Kohler +Copyright (c) 2000-2007 Ivan Kohler Copyright (c) 2000 Mail Abuse Prevention System LLC +Copyright (c) 2007 Freeside Internet Services, Inc. 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 BUGS AND TODO + +Multiple primary keys are not yet supported. + +Foreign keys and other constraints are not yet supported. + +Eventually it would be nice to have additional transformations (deleted, +modified columns, deleted tables). sql_update_schema doesn't drop tables +or deal with deleted or modified columns yet. + +Need to port and test with additional databases 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. +pretty_print is actually pretty ugly. + +pretty_print isn't so good about quoting values... save/load is a much better +alternative to using pretty_print/pretty_read + +pretty_read is pretty ugly too. + +pretty_read should *not* create and pass in old-style unique/index indices +when nothing is given in the read. + +Perhaps pretty_read should eval column types so that we can use DBI +qw(:sql_types) here instead of externally. + +Need to support "using" index attribute in pretty_read and in reverse +engineering + +perhaps we should just get rid of pretty_read entirely. pretty_print is useful +for debugging, but pretty_read is pretty bunk. + +sql CREATE TABLE output should convert integers +(i.e. use DBI qw(:sql_types);) to local types using DBI->type_info plus a hash +to fudge things =head1 SEE ALSO -L, L, -L, L, -L, L, L, -L, L, L +L, L, +L, L, +L, L, L, +L =cut