X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=DBSchema.pm;h=643e174637a8fd8a0e3b44d928ba3f69b2d79dd7;hb=c09b11401093a3ce923b631ffdd8a8c4a26c35aa;hp=96aa843d380d2b3218cd89d2e804e52bd7eacb0a;hpb=4aee638ca0827f3a9439f5f40eee18fbe11c89e2;p=DBIx-DBSchema.git

diff --git a/DBSchema.pm b/DBSchema.pm
index 96aa843..643e174 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 vars qw($VERSION $DEBUG $errstr);
 use Storable;
-use DBIx::DBSchema::Table;
+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;
 
-#@ISA = qw(Exporter);
-@ISA = ();
+$VERSION = "0.38_01";
+$VERSION = eval $VERSION; # modperlstyle: convert the string into a number
 
-$VERSION = "0.24";
+$DEBUG = 0;
 
 =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,13 +54,16 @@ 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.  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 and PostgreSQL.  Sybase support is
-partially implemented.  DBIx::DBSchema will attempt to use generic SQL syntax
-for other databases.  Assistance adding support for other databases is
-welcomed.  See L<DBIx::DBSchema::DBD>, "Driver Writer's Guide and Base Class".
+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<DBIx::DBSchema::DBD>, "Driver Writer's Guide and
+Base Class".
 
 =head1 METHODS
 
@@ -103,8 +105,7 @@ 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)
   );
@@ -121,8 +122,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)
   );
@@ -130,7 +130,8 @@ 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
 
@@ -143,12 +144,23 @@ sub load {
   eval { $self = Storable::retrieve($file); };
 
   if ( $@ && $@ =~ /not.*storable/i ) { #then try FreezeThaw
+    my $olderror = $@;
+
     eval "use FreezeThaw;";
-    die $@ if $@;
-    open(FILE,"<$file") or die "Can't open $file: $!";
-    my $string = join('',<FILE>);
-    close FILE or die "Can't close $file: $!";
-    ($self) = FreezeThaw::thaw($string);
+    if ( $@ ) {
+      $@ = $olderror;
+    } else { 
+      open(FILE,"<$file")
+        or do { $errstr = "Can't open $file: $!"; return ''; };
+      my $string = join('',<FILE>);
+      close FILE
+        or do { $errstr = "Can't close $file: $!"; return ''; };
+      ($self) = FreezeThaw::thaw($string);
+    }
+  }
+
+  unless ( $self ) {
+    $errstr = $@;
   }
 
   $self;
@@ -208,8 +220,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<not> 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.
@@ -221,15 +235,111 @@ 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;
+}
+
+=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<drop_tables> set true before all other arguments, it will also drop
+tables.
+
+See L<DBIx::DBSchema::Table/sql_alter_table>,
+L<DBIx::DBSchema::Column/sql_add_coumn> and
+L<DBIx::DBSchema::Column/sql_alter_column> 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<not> 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 = ();
+
+  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
+                                                    );
+
+    } else {
+  
+      warn "table $table does not exist.\n" if $DEBUG;
+
+      push @r, 
+        $new->table($table)->sql_create_table( $dbh );
+  
+    }
+  
   }
-  my @r = map { $self->table($_)->sql_create_table($dbh); } $self->tables;
-  $dbh->disconnect if $created_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 );
+
+    }
+
+  }
+
+  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
@@ -241,37 +351,77 @@ 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"
+
     } $self->tables
   ). "}\n";
 }
@@ -280,6 +430,9 @@ sub pretty_print {
 
 =item pretty_read HASHREF
 
+This method is B<not> recommended.  If you need to load and save your schema
+to a file, see the L</load|load> and L</save|save> methods.
+
 Creates a schema as specified by a data structure such as that created by
 B<pretty_print> method.
 
@@ -287,44 +440,56 @@ B<pretty_print> 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,
+
+      #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'} }
+                       ],
+    } );
 
-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 or die $@;
 }
 
+# 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 }
@@ -333,35 +498,74 @@ sub _tables_from_dbh {
 
 =back
 
-=head1 AUTHOR
+=head1 AUTHORS
 
 Ivan Kohler <ivan-dbix-dbschema@420.am>
 
 Charles Shapiro <charles.shapiro@numethods.com> and Mitchell Friedman
 <mitchell.friedman@numethods.com> contributed the start of a Sybase driver.
 
+Daniel Hanks <hanksdc@about-inc.com> contributed the Oracle driver.
+
+Jesse Vincent contributed the SQLite driver and fixes to quiet down
+internal usage of the old API.
+
+Slaven Rezic <srezic@cpan.org> 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-2005 Ivan Kohler
+Copyright (c) 2000-2007 Ivan Kohler
 Copyright (c) 2000 Mail Abuse Prevention System LLC
+Copyright (c) 2007-2010 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.
+
+sql_update_schema doesn't deal with deleted 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 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<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup>,
-L<DBIx::DBSchema::ColGroup::Unique>, L<DBIx::DBSchema::ColGroup::Index>,
+L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::Index>,
 L<DBIx::DBSchema::Column>, L<DBIx::DBSchema::DBD>,
 L<DBIx::DBSchema::DBD::mysql>, L<DBIx::DBSchema::DBD::Pg>, L<FS::Record>,
 L<DBI>