sanified layout of Versioned.pm and documented changes
Luke Saunders [Sat, 9 Feb 2008 15:26:50 +0000 (15:26 +0000)]
lib/DBIx/Class/Schema/Versioned.pm
t/94versioning.t

index 9b923a6..9416583 100644 (file)
@@ -37,6 +37,58 @@ __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
 
 
 # ---------------------------------------------------------------------------
+
+=head1 NAME
+
+DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+
+=head1 SYNOPSIS
+
+  package Library::Schema;
+  use base qw/DBIx::Class::Schema/;   
+  # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
+  __PACKAGE__->load_classes(qw/CD Book DVD/);
+
+  __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
+  __PACKAGE__->upgrade_directory('/path/to/upgrades/');
+  __PACKAGE__->backup_directory('/path/to/backups/');
+
+
+=head1 DESCRIPTION
+
+This module is a component designed to extend L<DBIx::Class::Schema>
+classes, to enable them to upgrade to newer schema layouts. To use this
+module, you need to have called C<create_ddl_dir> on your Schema to
+create your upgrade files to include with your delivery.
+
+A table called I<SchemaVersions> is created and maintained by the
+module. This contains two fields, 'Version' and 'Installed', which
+contain each VERSION of your Schema, and the date+time it was installed.
+
+The actual upgrade is called manually by calling C<upgrade> on your
+schema object. Code is run at connect time to determine whether an
+upgrade is needed, if so, a warning "Versions out of sync" is
+produced.
+
+So you'll probably want to write a script which generates your DDLs and diffs
+and another which executes the upgrade.
+
+NB: At the moment, only SQLite and MySQL are supported. This is due to
+spotty behaviour in the SQL::Translator producers, please help us by
+them.
+
+=head1 METHODS
+
+=head2 upgrade_directory
+
+Use this to set the directory your upgrade files are stored in.
+
+=head2 backup_directory
+
+Use this to set the directory you want your backups stored in.
+
+=cut
+
 package DBIx::Class::Schema::Versioned;
 
 use strict;
@@ -49,6 +101,16 @@ __PACKAGE__->mk_classdata('_filedata');
 __PACKAGE__->mk_classdata('upgrade_directory');
 __PACKAGE__->mk_classdata('backup_directory');
 __PACKAGE__->mk_classdata('do_backup');
+__PACKAGE__->mk_classdata('do_diff_on_init');
+
+=head2 schema_version
+
+Returns the current schema class' $VERSION; does -not- use $schema->VERSION
+since that varies in results depending on if version.pm is installed, and if
+so the perl or XS versions. If you want this to change, bug the version.pm
+author to make vpp and vxs behave the same.
+
+=cut
 
 sub schema_version {
   my ($self) = @_;
@@ -61,49 +123,12 @@ sub schema_version {
   return $version;
 }
 
-sub connection {
-  my $self = shift;
-  $self->next::method(@_);
-  $self->_on_connect;
-  return $self;
-}
-
-sub _on_connect
-{
-    my ($self) = @_;
-    $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
-
-    my $pversion = $self->get_db_version();
-
-    if($pversion eq $self->schema_version)
-    {
-        warn "This version is already installed\n";
-        return 1;
-    }
-
-    if(!$pversion)
-    {
-        warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
-        return 1;
-    }
+=head2 get_db_version
 
-    my $file = $self->ddl_filename(
-                                   $self->storage->sqlt_type,
-                                   $self->upgrade_directory,
-                                   $self->schema_version
-                                   );
-    if(!$file)
-    {
-        # No upgrade path between these two versions
-        return 1;
-    }
+Returns the version that your database is currently at. This is determined by the values in the
+SchemaVersions table that $self->upgrade writes to.
 
-
-    ## Don't do this yet, do only on command?
-    ## If we do this later, where does the Version table get updated??
-    warn "Versions out of sync. This is " . $self->schema_version . 
-        ", your database contains version $pversion, please call upgrade on your Schema.\n";
-}
+=cut
 
 sub get_db_version
 {
@@ -136,6 +161,17 @@ sub _source_exists
     return 1;
 }
 
+=head2 backup
+
+This is an overwritable method which is called just before the upgrade, to
+allow you to make a backup of the database. Per default this method attempts
+to call C<< $self->storage->backup >>, to run the standard backup on each
+database type. 
+
+This method should return the name of the backup file, if appropriate..
+
+=cut
+
 sub backup
 {
     my ($self) = @_;
@@ -143,221 +179,142 @@ sub backup
     $self->storage->backup($self->backup_directory());
 }
 
-sub upgrade
-{
-    my ($self, $params) = @_;
-    $params ||= {};
-    my $db_version = $self->get_db_version();
-
-    my %driver_to_db_map = (
-                            'mysql' => 'MySQL'
-                           );
-    if (!$db_version) {
-      my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
-      unless ($db) {
-        print "Sorry, this is an unsupported DB\n";
-        return;
-      }
-
-      if ($params->{create_diff}) {
-        require SQL::Translator;
-        require SQL::Translator::Diff;
-        my $db_tr = SQL::Translator->new({ 
-          add_drop_table => 1, 
-          parser => 'DBI',
-          parser_args => { dbh => $self->storage->dbh }
-        });
-        
-        $db_tr->producer($db);
-        my $dbic_tr = SQL::Translator->new;
-        $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
-        $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
-        $dbic_tr->data($self);
-        $dbic_tr->producer($db);
-        
-        $db_tr->schema->name('db_schema');
-        $dbic_tr->schema->name('dbic_schema');
-        
-        # is this really necessary?
-        foreach my $tr ($db_tr, $dbic_tr) {
-          my $data = $tr->data;
-          $tr->parser->($tr, $$data);
-        }
-        
-        my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db, 
-                                                      $dbic_tr->schema, $db,
-                                                      { caseopt => 1 });
-        
-        my $filename = $self->ddl_filename(
-                                           $db,
-                                           $self->upgrade_directory,
-                                           $self->schema_version,
-                                           'PRE',
-                                           );
-        my $file;
-        if(!open($file, ">$filename")) {
-          $self->throw_exception("Can't open $filename for writing ($!)");
-          next;
-        }
-        print $file $diff;
-        close($file);
-        
-        print "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
-      }
-
-      # create versions table
-      $self->{vschema}->deploy;
-    } else {
-      if ($db_version eq $self->schema_version) {
-        print "Upgrade not necessary\n";
-        return;
-      }
-
-      my $file = $self->ddl_filename(
-                                 $self->storage->sqlt_type,
-                                 $self->upgrade_directory,
-                                 $self->schema_version,
-                                 $db_version,
-                                 );
-
-      if(!-f $file)
-      {
-         warn "Upgrade not possible, no upgrade file found ($file)\n";
-         return;
-      }
-
-      my $fh;
-      open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
-      my @data = split(/\n/, join('', <$fh>));
-      @data = grep(!/^--/, @data);
-      @data = split(/;/, join('', @data));
-      close($fh);
-      @data = grep { $_ && $_ !~ /^-- / } @data;
-      @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
-      
-      $self->_filedata(\@data);
-      $self->backup() if($self->do_backup);
-
-      $self->txn_do(sub {
-        $self->do_upgrade();
-      });
-    }
-
-    my $vtable = $self->{vschema}->resultset('Table');
-    $vtable->create({ Version => $self->schema_version,
-                      Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
-                      });
-
-}
+# is this just a waste of time?
+sub _create_db_to_schema_diff {
+  my $self = shift;
 
-sub do_upgrade
-{
-    my ($self) = @_;
+  my %driver_to_db_map = (
+                          'mysql' => 'MySQL'
+                         );
 
-    ## overridable sub, per default just run all the commands.
-    $self->run_upgrade(qr/create/i);
-    $self->run_upgrade(qr/alter table .*? add/i);
-    $self->run_upgrade(qr/alter table .*? (?!drop)/i);
-    $self->run_upgrade(qr/alter table .*? drop/i);
-    $self->run_upgrade(qr/drop/i);
-}
+  my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
+  unless ($db) {
+    print "Sorry, this is an unsupported DB\n";
+    return;
+  }
 
-sub run_upgrade
-{
-    my ($self, $stm) = @_;
-#    print "Reg: $stm\n";
-    my @statements = grep { $_ =~ $stm } @{$self->_filedata};
-#    print "Statements: ", join("\n", @statements), "\n";
-    $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
+  require SQL::Translator;
+  require SQL::Translator::Diff;
+
+  my $db_tr = SQL::Translator->new({ 
+                                    add_drop_table => 1, 
+                                    parser => 'DBI',
+                                    parser_args => { dbh => $self->storage->dbh }
+                                   });
+
+  $db_tr->producer($db);
+  my $dbic_tr = SQL::Translator->new;
+  $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
+  $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
+  $dbic_tr->data($self);
+  $dbic_tr->producer($db);
+
+  $db_tr->schema->name('db_schema');
+  $dbic_tr->schema->name('dbic_schema');
+
+  # is this really necessary?
+  foreach my $tr ($db_tr, $dbic_tr) {
+    my $data = $tr->data;
+    $tr->parser->($tr, $$data);
+  }
 
-    for (@statements)
-    {      
-        $self->storage->debugobj->query_start($_) if $self->storage->debug;
-        $self->storage->dbh->do($_) or warn "SQL was:\n $_";
-        $self->storage->debugobj->query_end($_) if $self->storage->debug;
+  my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db, 
+                                                $dbic_tr->schema, $db,
+                                                { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
+
+  my $filename = $self->ddl_filename(
+                                         $db,
+                                         $self->upgrade_directory,
+                                         $self->schema_version,
+                                         'PRE',
+                                    );
+  my $file;
+  if(!open($file, ">$filename"))
+    {
+      $self->throw_exception("Can't open $filename for writing ($!)");
+      next;
     }
+  print $file $diff;
+  close($file);
 
-    return 1;
+  print "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
 }
 
-1;
+=head2 upgrade
 
-=head1 NAME
+Call this to attempt to upgrade your database from the version it is at to the version
+this DBIC schema is at. 
 
-DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
+have created this using $schema->create_ddl_dir.
 
-=head1 SYNOPSIS
+=cut
 
-  package Library::Schema;
-  use base qw/DBIx::Class::Schema/;   
-  # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
-  __PACKAGE__->load_classes(qw/CD Book DVD/);
+sub upgrade
+{
+  my ($self) = @_;
+  my $db_version = $self->get_db_version();
 
-  __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
-  __PACKAGE__->upgrade_directory('/path/to/upgrades/');
-  __PACKAGE__->backup_directory('/path/to/backups/');
+  # db unversioned
+  unless ($db_version) {
+    # set version in SchemaVersions table, can't actually upgrade as we don 't know what version the DB is at
+    $self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
 
-  sub backup
-  {
-    my ($self) = @_;
-    # my special backup process
+    # create versions table and version row
+    $self->{vschema}->deploy;
+    $self->_set_db_version;
+    return;
   }
 
-  sub upgrade
-  {
-    my ($self) = @_;
-
-    ## overridable sub, per default just runs all the commands.
-
-    $self->run_upgrade(qr/create/i);
-    $self->run_upgrade(qr/alter table .*? add/i);
-    $self->run_upgrade(qr/alter table .*? (?!drop)/i);
-    $self->run_upgrade(qr/alter table .*? drop/i);
-    $self->run_upgrade(qr/drop/i);
-    $self->run_upgrade(qr//i);   
+  # db and schema at same version. do nothing
+  if ($db_version eq $self->schema_version) {
+    print "Upgrade not necessary\n";
+    return;
   }
 
-=head1 DESCRIPTION
-
-This module is a component designed to extend L<DBIx::Class::Schema>
-classes, to enable them to upgrade to newer schema layouts. To use this
-module, you need to have called C<create_ddl_dir> on your Schema to
-create your upgrade files to include with your delivery.
-
-A table called I<SchemaVersions> is created and maintained by the
-module. This contains two fields, 'Version' and 'Installed', which
-contain each VERSION of your Schema, and the date+time it was installed.
-
-If you would like to influence which levels of version change need
-upgrades in your Schema, you can override the method C<ddl_filename>
-in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
-path between the two versions supplied. By default, every change in
-your VERSION is regarded as needing an upgrade.
-
-The actual upgrade is called manually by calling C<upgrade> on your
-schema object. Code is run at connect time to determine whether an
-upgrade is needed, if so, a warning "Versions out of sync" is
-produced.
-
-NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
-returns SQL statements that SQLite does not support.
+  my $upgrade_file = $self->ddl_filename(
+                                         $self->storage->sqlt_type,
+                                         $self->upgrade_directory,
+                                         $self->schema_version,
+                                         $db_version,
+                                        );
 
+  unless (-f $upgrade_file) {
+    warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
+    return;
+  }
 
-=head1 METHODS
+  # backup if necessary then apply upgrade
+  $self->_filedata($self->_read_sql_file($upgrade_file));
+  $self->backup() if($self->do_backup);
+  $self->txn_do(sub { $self->do_upgrade() });
 
-=head2 backup
+  # set row in SchemaVersions table
+  $self->_set_db_version;
+}
 
-This is an overwritable method which is called just before the upgrade, to
-allow you to make a backup of the database. Per default this method attempts
-to call C<< $self->storage->backup >>, to run the standard backup on each
-database type. 
+sub _set_db_version {
+  my $self = shift;
 
-This method should return the name of the backup file, if appropriate..
+  my $vtable = $self->{vschema}->resultset('Table');
+  $vtable->create({ Version => $self->schema_version,
+                      Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
+                      });
 
-=head2 upgrade
+}
 
-This is the main upgrade method which calls the overridable do_upgrade and
-also handles the backups and updating of the SchemaVersion table.
+sub _read_sql_file {
+  my $self = shift;
+  my $file = shift || return;
+
+  my $fh;
+  open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
+  my @data = split(/[;\n]/, join('', <$fh>));
+  close($fh);
+  @data = grep { $_ && $_ !~ /^-- / } @data;
+  @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
+  return \@data;
+}
 
 =head2 do_upgrade
 
@@ -368,6 +325,22 @@ sandwich your data upgrading. For example, first run all the B<CREATE>
 commands, then migrate your data from old to new tables/formats, then 
 issue the DROP commands when you are finished.
 
+Will run the whole file as it is by default.
+
+=cut
+
+sub do_upgrade
+{
+    my ($self) = @_;
+
+    ## overridable sub, per default just run all the commands.
+    $self->run_upgrade(qr/create/i);
+    $self->run_upgrade(qr/alter table .*? add/i);
+    $self->run_upgrade(qr/alter table .*? (?!drop)/i);
+    $self->run_upgrade(qr/alter table .*? drop/i);
+    $self->run_upgrade(qr/drop/i);
+}
+
 =head2 run_upgrade
 
  $self->run_upgrade(qr/create/i);
@@ -375,23 +348,67 @@ issue the DROP commands when you are finished.
 Runs a set of SQL statements matching a passed in regular expression. The
 idea is that this method can be called any number of times from your
 C<upgrade> method, running whichever commands you specify via the
-regex in the parameter.
+regex in the parameter. Probably won't work unless called from the overridable
+do_upgrade method.
 
-=head2 upgrade_directory
+=cut
 
-Use this to set the directory your upgrade files are stored in.
+sub run_upgrade
+{
+    my ($self, $stm) = @_;
 
-=head2 backup_directory
+    return unless ($self->_filedata);
+    my @statements = grep { $_ =~ $stm } @{$self->_filedata};
+    $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 
-Use this to set the directory you want your backups stored in.
+    for (@statements)
+    {      
+        $self->storage->debugobj->query_start($_) if $self->storage->debug;
+        $self->storage->dbh->do($_) or warn "SQL was:\n $_";
+        $self->storage->debugobj->query_end($_) if $self->storage->debug;
+    }
 
-=head2 schema_version
+    return 1;
+}
 
-Returns the current schema class' $VERSION; does -not- use $schema->VERSION
-since that varies in results depending on if version.pm is installed, and if
-so the perl or XS versions. If you want this to change, bug the version.pm
-author to make vpp and vxs behave the same.
+sub connection {
+  my $self = shift;
+  $self->next::method(@_);
+  $self->_on_connect;
+  return $self;
+}
+
+sub _on_connect
+{
+  my ($self) = @_;
+  $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
+
+  my $pversion = $self->get_db_version();
+
+  if($pversion eq $self->schema_version)
+    {
+        warn "This version is already installed\n";
+        return 1;
+    }
 
-=head1 AUTHOR
+  if(!$pversion)
+    {
+        warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
+        return 1;
+    }
+
+  warn "Versions out of sync. This is " . $self->schema_version . 
+    ", your database contains version $pversion, please call upgrade on your Schema.\n";
+}
+
+1;
+
+
+=head1 AUTHORS
 
 Jess Robinson <castaway@desert-island.demon.co.uk>
+Luke Saunders <luke@shadowcatsystems.co.uk>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
index ceae0e7..86dd11b 100644 (file)
@@ -12,7 +12,7 @@ BEGIN {
   ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/};
 
   plan skip_all => 'Set $ENV{DBICTEST_MYSQL_DSN}, _USER and _PASS to run this test'
-    unless ($dsn && $user);
+    unless ($dsn);
 
 
     eval "use DBD::mysql; use SQL::Translator 0.08;";
@@ -22,7 +22,6 @@ BEGIN {
 }
 
 use lib qw(t/lib);
-
 use_ok('DBICVersionOrig');
 
 my $schema_orig = DBICVersion::Schema->connect($dsn, $user, $pass);