X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=DBSchema.pm;h=b9021db1779eed692a4e01bef5b554e21a3c8600;hb=018cfabc5bdc2988dcbf595c26888f3cfa84c69a;hp=ab9b85a92573d6e0d5bd988777f01ced6b14bbe0;hpb=7d5538189564cc786eacb4a2969a2ad19cbdf84c;p=DBIx-DBSchema.git diff --git a/DBSchema.pm b/DBSchema.pm index ab9b85a..b9021db 100644 --- a/DBSchema.pm +++ b/DBSchema.pm @@ -1,20 +1,19 @@ package DBIx::DBSchema; use strict; -use vars qw(@ISA $VERSION); -#use Exporter; -use Carp qw(confess); -use DBI; -use FreezeThaw qw(freeze thaw cmpStr); -use DBIx::DBSchema::Table; +use Storable; +use DBIx::DBSchema::_util qw(_load_driver _dbh _parse_opt); +use DBIx::DBSchema::Table 0.08; +use DBIx::DBSchema::Index; use DBIx::DBSchema::Column; -use DBIx::DBSchema::ColGroup::Unique; -use DBIx::DBSchema::ColGroup::Index; +use DBIx::DBSchema::ForeignKey; -#@ISA = qw(Exporter); -@ISA = (); +our $VERSION = '0.44_02'; +$VERSION = eval $VERSION; # modperlstyle: convert the string into a number -$VERSION = "0.15"; +our $DEBUG = 0; + +our $errstr; =head1 NAME @@ -31,7 +30,7 @@ DBIx::DBSchema - Database-independent schema objects $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); @@ -55,12 +54,15 @@ 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 a different process. Most importantly, DBIx::DBSchema can write SQL -CREATE statements statements for different databases from a single source. +it in a different process. You can write SQL CREATE statements statements for +different databases from a single source. You can transform one schema to +another, adding any necessary new columns, tables, indices and foreign keys. -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. +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 @@ -95,13 +97,14 @@ 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. +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) = (shift, shift); - $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr unless ref($dbh); + my($proto, $dbh) = ( shift, _dbh(@_) ); $proto->new( map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh) ); @@ -118,8 +121,7 @@ only available if there is a DBIx::DBSchema::DBD for the corresponding database =cut sub new_native { - my($proto, $dbh) = (shift, shift); - $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr unless ref($dbh); + my($proto, $dbh) = (shift, _dbh(@_) ); $proto->new( map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh) ); @@ -127,18 +129,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 @@ -148,14 +173,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 @@ -200,8 +219,10 @@ 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. +a DBI connection will be opened and used to check the database version as well +as for more reliable quoting and type mapping. Note that the database +connection will be used passively, B to actually run the CREATE +statements. 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. @@ -213,15 +234,119 @@ specified database, will attempt to use generic SQL syntax. =cut sub sql { - my($self, $dbh) = (shift, shift); - my $created_dbh = 0; - unless ( ref($dbh) || ! @_ ) { - $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr; - $created_dbh = 1; + my($self, $dbh) = ( shift, _dbh(@_) ); + ( + ( map { $self->table($_)->sql_create_table($dbh); } $self->tables ), + ( map { $self->table($_)->sql_add_constraints($dbh); } $self->tables ), + ); +} + +=item sql_update_schema [ OPTIONS_HASHREF, ] 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. + +Right now this method knows how to add new tables and alter existing tables, +including indices. If specifically requested by passing an options hashref +with B set true before all other arguments, it will also drop +tables. + +See L, +L and +L for additional specifics and +limitations. + +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 used to check the database version as well +as for more reliable quoting and type mapping. Note that the database +connection will be used passively, B to actually run the CREATE +statements. + +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. + +=cut + +#gosh, false laziness w/DBSchema::Table::sql_alter_schema + +sub sql_update_schema { + my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); + + my @r = (); + my @later = (); + + 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, $opt ); + push @later, + $self->table($table)->sql_alter_constraints( $new->table($table), + $dbh, $opt ); + + } else { + + warn "table $table does not exist.\n" if $DEBUG; + + push @r, $new->table($table)->sql_create_table( $dbh ); + push @later, $new->table($table)->sql_add_constraints( $dbh ); + + } + + } + + if ( $opt->{'drop_tables'} ) { + + warn "drop_tables enabled\n" if $DEBUG; + + # drop tables not in $new + foreach my $table ( grep !$new->table($_), $self->tables ) { + + warn "table $table should be dropped.\n" if $DEBUG; + + push @r, $self->table($table)->sql_drop_table( $dbh ); + + } + } - my @r = map { $self->table($_)->sql_create_table($dbh); } $self->tables; - $dbh->disconnect if $created_dbh; + + push @r, @later; + + warn join("\n", @r). "\n" + if $DEBUG > 1; + @r; + +} + +=item update_schema [ OPTIONS_HASHREF, ] 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(@_) ); + my($self, $opt, $new, $dbh) = ( shift, _parse_opt(\@_), shift, _dbh(@_) ); + + foreach my $statement ( $self->sql_update_schema( $opt, $new, $dbh ) ) { + $dbh->do( $statement ) + or die "Error: ". $dbh->errstr. "\n executing: $statement"; + } + } =item pretty_print @@ -233,45 +358,99 @@ 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( $_ ". - #$self->table($table)->column($_)->type. " ". - #( $self->table($table)->column($_)->null ? 'NULL' : 0 ). " ". - #$self->table($table)->column($_)->length. " ),\n" + #$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. "', ". - "'". $self->table($table)->column($_)->default. "', ". - "'". $self->table($table)->column($_)->local. "',\n" - } $self->table($table)->columns + "'". $table->column($_)->type. "', ". + "'". $table->column($_)->null. "', ". + "'". $table->column($_)->length. "', ". + + ( ref($table->column($_)->default) + ? "\\'". ${ $table->column($_)->default }. "'" + : "'". $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". + + #foreign_keys + " 'foreign_keys' => [ ". join( ",\n ", + + map { my $name = $_->constraint; + "'$name' => { \n". + " },\n"; + } + $table->foreign_keys + + ). "\n ], \n" + + ; + } $self->tables - ), "}\n"; + ). "}\n"; } -=cut - =item pretty_read HASHREF +This method is B recommended. If you need to load and save your schema +to a file, see the L and L methods. + Creates a schema as specified by a data structure such as that created by B method. @@ -279,44 +458,52 @@ B method. sub pretty_read { my($proto, $href) = @_; + my $schema = $proto->new( map { - my(@columns); - while ( @{$href->{$_}{'columns'}} ) { + + my $tablename = $_; + my $info = $href->{$tablename}; + + my @columns; + while ( @{$info->{'columns'}} ) { push @columns, DBIx::DBSchema::Column->new( - splice @{$href->{$_}{'columns'}}, 0, 6 + splice @{$info->{'columns'}}, 0, 6 ); } - DBIx::DBSchema::Table->new( - $_, - $href->{$_}{'primary_key'}, - DBIx::DBSchema::ColGroup::Unique->new($href->{$_}{'unique'}), - DBIx::DBSchema::ColGroup::Index->new($href->{$_}{'index'}), - @columns, - ); - } (keys %{$href}) ); -} -# private subroutines + DBIx::DBSchema::Table->new({ + 'name' => $tablename, + 'primary_key' => $info->{'primary_key'}, + 'columns' => \@columns, + + #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'} } + ], + } ); -sub _load_driver { - my($dbh) = @_; - my $driver; - if ( ref($dbh) ) { - $driver = $dbh->{Driver}->{Name}; - } else { - $dbh =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect - or '' =~ /()/; # ensure $1 etc are empty if match fails - $driver = $1 or confess "can't parse data source: $dbh"; - } + } (keys %{$href}) ); - #require "DBIx/DBSchema/DBD/$driver.pm"; - #$driver; - eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver; } +# private subroutines + 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 } @@ -325,34 +512,77 @@ 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 and fixes to quiet down +internal usage of the old API. + +Slaven Rezic contributed column and table dropping, Pg +bugfixes and more. + +=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-2013 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: need to support dropping, NOT VALID, reverse engineering w/mysql + +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). +Need to support "using" index attribute in pretty_read and in reverse +engineering + +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 + +=head2 PRETTY_ BUGS + 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. +perhaps we should just get rid of pretty_read entirely. pretty_print is useful +for debugging, but pretty_read is pretty bunk. + =head1 SEE ALSO -L, L, -L, L, -L, L, L, -L, L, L +L, L, +L, L, +L, L, L, +L =cut