From: Jess Robinson Date: Fri, 6 Oct 2006 19:45:42 +0000 (+0000) Subject: Versioning! With tests! Woo! X-Git-Tag: v0.08240~406^2~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c9d2e0a20b79cf2c65ff86e8b400ff683b18627d;p=dbsrgits%2FDBIx-Class.git Versioning! With tests! Woo! --- diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 4df22c9..dbb14bc 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -5,6 +5,7 @@ use warnings; use Carp::Clan qw/^DBIx::Class/; use Scalar::Util qw/weaken/; +use File::Spec; require Module::Find; use base qw/DBIx::Class/; @@ -639,6 +640,7 @@ sub connection { my $storage = $storage_class->new($self); $storage->connect_info(\@info); $self->storage($storage); + $self->on_connect() if($self->can('on_connect')); return $self; } @@ -894,16 +896,41 @@ sub deploy { =over 4 -=item Arguments: \@databases, $version, $directory, $sqlt_args +=item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args =back Creates an SQL file based on the Schema, for each of the specified -database types, in the given directory. +database types, in the given directory. Given a previous version number, +this will also create a file containing the ALTER TABLE statements to +transform the previous schema into the current one. Note that these +statements may contain DROP TABLE or DROP COLUMN statements that can +potentially destroy data. + +The file names are created using the C method below, please +override this method in your schema if you would like a different file +name format. For the ALTER file, the same format is used, replacing +$version in the name with "$preversion-$version". + +If no arguments are passed, then the following default values are used: + +=over 4 + +=item databases - ['MySQL', 'SQLite', 'PostgreSQL'] + +=item version - $schema->VERSION + +=item directory - './' + +=item preversion - + +=back Note that this feature is currently EXPERIMENTAL and may not work correctly across all databases, or fully handle complex relationships. +WARNING: Please check all SQL files created, before applying them. + =cut sub create_ddl_dir { @@ -915,19 +942,30 @@ sub create_ddl_dir { =head2 ddl_filename (EXPERIMENTAL) - my $filename = $table->ddl_filename($type, $dir, $version) +=over 4 + +=item Arguments: $directory, $database-type, $version, $preversion + +=back + + my $filename = $table->ddl_filename($type, $dir, $version, $preversion) + +This method is called by C to compose a file name out of +the supplied directory, database type and version number. The default file +name format is: C<$dir$schema-$version-$type.sql>. -Creates a filename for a SQL file based on the table class name. Not -intended for direct end user use. +You may override this method in your schema if you wish to use a different +format. =cut sub ddl_filename { - my ($self, $type, $dir, $version) = @_; + my ($self, $type, $dir, $version, $pversion) = @_; my $filename = ref($self); $filename =~ s/::/-/; - $filename = "$dir$filename-$version-$type.sql"; + $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); + $filename =~ s/$version/$pversion-$version/ if($pversion); return $filename; } diff --git a/lib/DBIx/Class/Schema/Versioned.pm b/lib/DBIx/Class/Schema/Versioned.pm new file mode 100644 index 0000000..ba38ad7 --- /dev/null +++ b/lib/DBIx/Class/Schema/Versioned.pm @@ -0,0 +1,285 @@ +package DBIx::Class::Version::Table; +use base 'DBIx::Class'; +use strict; +use warnings; + +__PACKAGE__->load_components(qw/ Core/); +__PACKAGE__->table('SchemaVersions'); + +__PACKAGE__->add_columns + ( 'Version' => { + 'data_type' => 'VARCHAR', + 'is_auto_increment' => 0, + 'default_value' => undef, + 'is_foreign_key' => 0, + 'name' => 'Version', + 'is_nullable' => 0, + 'size' => '10' + }, + 'Installed' => { + 'data_type' => 'VARCHAR', + 'is_auto_increment' => 0, + 'default_value' => undef, + 'is_foreign_key' => 0, + 'name' => 'Installed', + 'is_nullable' => 0, + 'size' => '20' + }, + ); +__PACKAGE__->set_primary_key('Version'); + +package DBIx::Class::Version; +use base 'DBIx::Class::Schema'; +use strict; +use warnings; + +__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table'); + + +# --------------------------------------------------------------------------- +package DBIx::Class::Schema::Versioned; + +use strict; +use warnings; +use base 'DBIx::Class'; +use POSIX 'strftime'; +use Data::Dumper; + +__PACKAGE__->mk_classdata('_filedata'); +__PACKAGE__->mk_classdata('upgrade_directory'); + +sub on_connect +{ + my ($self) = @_; + my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()}); + my $vtable = $vschema->resultset('Table'); + my $pversion; + if(!$self->exists($vtable)) + { +# $vschema->storage->debug(1); + $vschema->storage->ensure_connected(); + $vschema->deploy(); + $pversion = 0; + } + else + { + my $psearch = $vtable->search(undef, + { select => [ + { 'max' => 'Installed' }, + ], + as => ['maxinstall'], + })->first; + $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'), + })->first; + $pversion = $pversion->Version if($pversion); + } +# warn("Previous version: $pversion\n"); + if($pversion eq $self->VERSION) + { + warn "This version is already installed\n"; + return 1; + } + +## use IC::DT? + + if(!$pversion) + { + $vtable->create({ Version => $self->VERSION, + Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime()) + }); + ## If we let the user do this, where does the Version table get updated? + warn "No previous version found, calling deploy to install this version.\n"; + $self->deploy(); + return 1; + } + + my $file = $self->ddl_filename( + $self->storage->sqlt_type, + $self->upgrade_directory, + $self->VERSION + ); + if(!$file) + { + # No upgrade path between these two versions + return 1; + } + + $file = $self->ddl_filename( + $self->storage->sqlt_type, + $self->upgrade_directory, + $self->VERSION, + $pversion, + ); +# $file =~ s/@{[ $self->VERSION ]}/"${pversion}-" . $self->VERSION/e; + 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>)); + close($fh); + @data = grep { $_ && $_ !~ /^-- / } @data; + @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data; + + $self->_filedata(\@data); + + ## 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->VERSION . + ", your database contains version $pversion, please call upgrade on your Schema.\n"; +# $self->upgrade($pversion, $self->VERSION); +} + +sub exists +{ + my ($self, $rs) = @_; + + my $c = eval { + $rs->search({ 1, 0 })->count; + }; + return 0 if $@ || !defined $c; + + return 1; +} + +sub backup +{ + my ($self) = @_; + ## Make each ::DBI::Foo do this + $self->storage->backup(); +} + +sub upgrade +{ + my ($self) = @_; + + ## overridable sub, per default just run all the commands. + + $self->backup(); + + $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); + + my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()}); + my $vtable = $vschema->resultset('Table'); + $vtable->create({ Version => $self->VERSION, + Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime()) + }); +} + + +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} ]); + + for (@statements) + { + $self->storage->debugfh->print("$_\n") if $self->storage->debug; +# print "Running \n>>$_<<\n"; + $self->storage->dbh->do($_) or warn "SQL was:\n $_"; + } + + return 1; +} + +=head1 NAME + +DBIx::Class::Versioning - 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/'); + + sub backup + { + my ($self) = @_; + # my special backup process + } + + 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); + } + +=head1 DESCRIPTION + +This module is a component designed to extend L +classes, to enable them to upgrade to newer schema layouts. To use this +module, you need to have called C on your Schema to +create your upgrade files to include with your delivery. + +A table called I 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 +in L. 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. + +NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff +returns SQL statements that SQLite does not support. + + +=head1 METHODS + +=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. + +C is called from C, make sure you call it, if you write your +own method. + +=head2 upgrade + +This is an overwritable method used to run your upgrade. The freeform method +allows you to run your upgrade any way you please, you can call C +any number of times to run the actual SQL commands, and in between you can +sandwich your data upgrading. For example, first run all the B +commands, then migrate your data from old to new tables/formats, then +issue the DROP commands when you are finished. + +=head2 run_upgrade + + $self->run_upgrade(qr/create/i); + +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 method, running whichever commands you specify via the +regex in the parameter. + +=head1 AUTHOR + +Jess Robinson diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index a0a34a8..4b63c4f 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -62,7 +62,6 @@ use Scalar::Util 'blessed'; sub _find_syntax { my ($self, $syntax) = @_; my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax; -# print STDERR "Found DBH $syntax >$dbhname< ", $syntax->{Driver}->{Name}, "\n"; if(ref($self) && $dbhname && $dbhname eq 'DB2') { return 'RowNumberOver'; } @@ -839,7 +838,7 @@ sub _execute { $self->throw_exception("'$sql' did not generate a statement."); } if ($self->debug) { - my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind; + my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind; $self->debugobj->query_end($sql, @debug_bind); } return (wantarray ? ($rv, $sth, @bind) : $rv); @@ -1080,7 +1079,7 @@ sub sqlt_type { shift->dbh->{Driver}->{Name} } =over 4 -=item Arguments: $schema \@databases, $version, $directory, $sqlt_args +=item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args =back @@ -1094,7 +1093,7 @@ across all databases, or fully handle complex relationships. sub create_ddl_dir { - my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_; + my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_; if(!$dir || !-d $dir) { @@ -1107,14 +1106,18 @@ sub create_ddl_dir $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} }; eval "use SQL::Translator"; - $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@; + $self->throw_exception("Can't create a ddl file without SQL::Translator: $@") if $@; - my $sqlt = SQL::Translator->new($sqltargs); + my $sqlt = SQL::Translator->new({ +# debug => 1, + add_drop_table => 1, + }); foreach my $db (@$databases) { $sqlt->reset(); $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); # $sqlt->parser_args({'DBIx::Class' => $schema); + $sqlt = $self->configure_sqlt($sqlt, $db); $sqlt->data($schema); $sqlt->producer($db); @@ -1122,24 +1125,97 @@ sub create_ddl_dir my $filename = $schema->ddl_filename($db, $dir, $version); if(-e $filename) { - $self->throw_exception("$filename already exists, skipping $db"); + warn("$filename already exists, skipping $db"); next; } - open($file, ">$filename") - or $self->throw_exception("Can't open $filename for writing ($!)"); + my $output = $sqlt->translate; -#use Data::Dumper; -# print join(":", keys %{$schema->source_registrations}); -# print Dumper($sqlt->schema); if(!$output) { - $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")"); + warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); next; } + if(!open($file, ">$filename")) + { + $self->throw_exception("Can't open $filename for writing ($!)"); + next; + } print $file $output; close($file); + + if($preversion) + { + eval "use SQL::Translator::Diff"; + if($@) + { + warn("Can't diff versions without SQL::Translator::Diff: $@"); + next; + } + + my $prefilename = $schema->ddl_filename($db, $dir, $preversion); + print "Previous version $prefilename\n"; + if(!-e $prefilename) + { + warn("No previous schema file found ($prefilename)"); + next; + } + #### We need to reparse the SQLite file we just wrote, so that + ## Diff doesnt get all confoosed, and Diff is *very* confused. + ## FIXME: rip Diff to pieces! +# my $target_schema = $sqlt->schema; +# unless ( $target_schema->name ) { +# $target_schema->name( $filename ); +# } + my @input; + push @input, {file => $prefilename, parser => $db}; + push @input, {file => $filename, parser => $db}; + my ( $source_schema, $source_db, $target_schema, $target_db ) = map { + my $file = $_->{'file'}; + my $parser = $_->{'parser'}; + + my $t = SQL::Translator->new; + $t->debug( 0 ); + $t->trace( 0 ); + $t->parser( $parser ) or die $t->error; + my $out = $t->translate( $file ) or die $t->error; + my $schema = $t->schema; + unless ( $schema->name ) { + $schema->name( $file ); + } + ($schema, $parser); + } @input; + + my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db, + $target_schema, $db, + {} + ); + my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion); + print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n"; + if(-e $difffile) + { + warn("$difffile already exists, skipping"); + next; + } + if(!open $file, ">$difffile") + { + $self->throw_exception("Can't write to $difffile ($!)"); + next; + } + print $file $diff; + close($file); + } } +} +sub configure_sqlt() { + my $self = shift; + my $tr = shift; + my $db = shift || $self->sqlt_type; + if ($db eq 'PostgreSQL') { + $tr->quote_table_names(0); + $tr->quote_field_names(0); + } + return $tr; } =head2 deployment_statements @@ -1172,6 +1248,17 @@ sub deployment_statements { $type ||= $self->sqlt_type; $version ||= $schema->VERSION || '1.x'; $dir ||= './'; + my $filename = $schema->ddl_filename($type, $dir, $version); + if(-f $filename) + { + my $file; + open($file, "<$filename") + or $self->throw_exception("Can't open $filename ($!)"); + my @rows = <$file>; + close($file); + return join('', @rows); + } + eval "use SQL::Translator"; if(!$@) { @@ -1184,21 +1271,9 @@ sub deployment_statements { return "SQL::Translator::Producer::${type}"->can('produce')->($tr); } - my $filename = $schema->ddl_filename($type, $dir, $version); - if(!-f $filename) - { -# $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs); - $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy"); - return; - } - my $file; - open($file, "<$filename") - or $self->throw_exception("Can't open $filename ($!)"); - my @rows = <$file>; - close($file); - - return join('', @rows); - + $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy"); + return; + } sub deploy { diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 2d7d9ad..f69fe0a 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -2,6 +2,9 @@ package DBIx::Class::Storage::DBI::SQLite; use strict; use warnings; +use POSIX 'strftime'; +use File::Copy; +use Path::Class; use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/; @@ -10,6 +13,34 @@ sub _dbh_last_insert_id { $dbh->func('last_insert_rowid'); } +sub backup +{ + my ($self) = @_; + + ## Where is the db file? + my $dsn = $self->connect_info()->[0]; + + my $dbname = $1 if($dsn =~ /dbname=([^;]+)/); + if(!$dbname) + { + $dbname = $1 if($dsn =~ /^dbi:SQLite:(.+)$/i); + } + $self->throw_exception("Cannot determine name of SQLite db file") + if(!$dbname || !-f $dbname); + +# print "Found database: $dbname\n"; + my $dbfile = file($dbname); +# my ($vol, $dir, $file) = File::Spec->splitpath($dbname); + my $file = $dbfile->basename(); + $file = strftime("%y%m%d%h%M%s", localtime()) . $file; + $file = "B$file" while(-f $file); + + my $res = copy($dbname, $file); + $self->throw_exception("Backup failed! ($!)") if(!$res); + + return $file; +} + 1; =head1 NAME diff --git a/t/94versioning.t b/t/94versioning.t new file mode 100644 index 0000000..81245e2 --- /dev/null +++ b/t/94versioning.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More; + +BEGIN { + eval "use DBD::SQLite; use SQL::Translator;"; + plan $@ + ? ( skip_all => 'needs DBD::SQLite and SQL::Translator for testing' ) + : ( tests => 6 ); +} + +use lib qw(t/lib); + +use_ok('DBICVersionOrig'); + +my $db_file = "t/var/versioning.db"; +unlink($db_file) if -e $db_file; +unlink($db_file . "-journal") if -e $db_file . "-journal"; +mkdir("t/var") unless -d "t/var"; +unlink('t/var/DBICVersion-Schema-1.0-SQLite.sql'); + +my $schema = DBICVersion::Schema->connect("dbi:SQLite:$db_file"); +# $schema->storage->ensure_connected(); + +is($schema->ddl_filename('SQLite', 't/var', '1.0'), 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Filename creation working'); +$schema->create_ddl_dir('SQLite', undef, 't/var'); + +ok(-f 't/var/DBICVersion-Schema-1.0-SQLite.sql', 'Created DDL file'); +## do this here or let Versioned.pm do it? +# $schema->deploy(); + +my $tvrs = $schema->resultset('Table'); +is($schema->exists($tvrs), 1, 'Created schema from DDL file'); + +eval "use DBICVersionNew"; +my $schema2 = DBICVersion::Schema->connect("dbi:SQLite:$db_file"); + +unlink('t/var/DBICVersion-Schema-2.0-SQLite.sql'); +unlink('t/var/DBICVersion-Schema-1.0-2.0-SQLite.sql'); +$schema2->create_ddl_dir('SQLite', undef, 't/var', '1.0'); +ok(-f 't/var/DBICVersion-Schema-1.0-2.0-SQLite.sql', 'Created DDL upgrade file'); + +## do this here or let Versioned.pm do it? +$schema2->upgrade(); +$tvrs = $schema2->resultset('Table'); +is($schema2->exists($tvrs), 1, 'Upgraded schema from DDL file'); diff --git a/t/lib/DBICVersionNew.pm b/t/lib/DBICVersionNew.pm new file mode 100644 index 0000000..8718447 --- /dev/null +++ b/t/lib/DBICVersionNew.pm @@ -0,0 +1,46 @@ +package DBICVersion::Table; + +use base 'DBIx::Class'; +use strict; +use warnings; + +__PACKAGE__->load_components(qw/ Core/); +__PACKAGE__->table('TestVersion'); + +__PACKAGE__->add_columns + ( 'Version' => { + 'data_type' => 'INTEGER', + 'is_auto_increment' => 1, + 'default_value' => undef, + 'is_foreign_key' => 0, + 'is_nullable' => 0, + 'size' => '' + }, + 'VersionName' => { + 'data_type' => 'VARCHAR', + 'is_auto_increment' => 0, + 'default_value' => undef, + 'is_foreign_key' => 0, + 'is_nullable' => 1, + 'size' => '20' + }, + ); + +__PACKAGE__->set_primary_key('Version'); + +package DBICVersion::Schema; +use base 'DBIx::Class::Schema'; +use strict; +use warnings; + +our $VERSION = '2.0'; + +__PACKAGE__->register_class('Table', 'DBICVersion::Table'); +__PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); + +sub upgrade_directory +{ + return 't/var/'; +} + +1; diff --git a/t/lib/DBICVersionOrig.pm b/t/lib/DBICVersionOrig.pm new file mode 100644 index 0000000..5a12ce4 --- /dev/null +++ b/t/lib/DBICVersionOrig.pm @@ -0,0 +1,46 @@ +package DBICVersion::Table; + +use base 'DBIx::Class'; +use strict; +use warnings; + +__PACKAGE__->load_components(qw/ Core/); +__PACKAGE__->table('TestVersion'); + +__PACKAGE__->add_columns + ( 'Version' => { + 'data_type' => 'INTEGER', + 'is_auto_increment' => 1, + 'default_value' => undef, + 'is_foreign_key' => 0, + 'is_nullable' => 0, + 'size' => '' + }, + 'VersionName' => { + 'data_type' => 'VARCHAR', + 'is_auto_increment' => 0, + 'default_value' => undef, + 'is_foreign_key' => 0, + 'is_nullable' => 0, + 'size' => '10' + }, + ); + +__PACKAGE__->set_primary_key('Version'); + +package DBICVersion::Schema; +use base 'DBIx::Class::Schema'; +use strict; +use warnings; + +our $VERSION = '1.0'; + +__PACKAGE__->register_class('Table', 'DBICVersion::Table'); +__PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); + +sub upgrade_directory +{ + return 't/var/'; +} + +1;