use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util qw/weaken/;
+use File::Spec;
require Module::Find;
use base qw/DBIx::Class/;
my $storage = $storage_class->new($self);
$storage->connect_info(\@info);
$self->storage($storage);
+ $self->on_connect() if($self->can('on_connect'));
return $self;
}
=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<ddl_filename> 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 - <none>
+
+=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 {
=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<create_ddl_dir> 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;
}
--- /dev/null
+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<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.
+
+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<backup> is called from C<upgrade>, make sure you call it, if you write your
+own <upgrade> 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<run_upgrade>
+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<CREATE>
+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<upgrade> method, running whichever commands you specify via the
+regex in the parameter.
+
+=head1 AUTHOR
+
+Jess Robinson <castaway@desert-island.demon.co.uk>
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';
}
$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);
=over 4
-=item Arguments: $schema \@databases, $version, $directory, $sqlt_args
+=item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
=back
sub create_ddl_dir
{
- my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
+ my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
if(!$dir || !-d $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);
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
$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(!$@)
{
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 {
use strict;
use warnings;
+use POSIX 'strftime';
+use File::Copy;
+use Path::Class;
use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
$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
--- /dev/null
+#!/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');
--- /dev/null
+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;
--- /dev/null
+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;
projects / dbsrgits/DBIx-Class.git / commitdiff