-package DBIx::Class::Version::Table;
-use base 'DBIx::Class';
+package # Hide from PAUSE
+ DBIx::Class::Version::Table;
+use base 'DBIx::Class::Core';
use strict;
use warnings;
-__PACKAGE__->load_components(qw/ Core/);
-__PACKAGE__->table('SchemaVersions');
+__PACKAGE__->table('dbix_class_schema_versions');
__PACKAGE__->add_columns
- ( 'Version' => {
+ ( 'version' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Version',
+ 'name' => 'version',
'is_nullable' => 0,
'size' => '10'
},
- 'Installed' => {
+ 'installed' => {
'data_type' => 'VARCHAR',
'is_auto_increment' => 0,
'default_value' => undef,
'is_foreign_key' => 0,
- 'name' => 'Installed',
+ 'name' => 'installed',
'is_nullable' => 0,
'size' => '20'
},
);
+__PACKAGE__->set_primary_key('version');
+
+package # Hide from PAUSE
+ DBIx::Class::Version::TableCompat;
+use base 'DBIx::Class::Core';
+__PACKAGE__->table('SchemaVersions');
+
+__PACKAGE__->add_columns
+ ( 'Version' => {
+ 'data_type' => 'VARCHAR',
+ },
+ 'Installed' => {
+ 'data_type' => 'VARCHAR',
+ },
+ );
__PACKAGE__->set_primary_key('Version');
-package DBIx::Class::Version;
+package # Hide from PAUSE
+ DBIx::Class::Version;
use base 'DBIx::Class::Schema';
use strict;
use warnings;
__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
+package # Hide from PAUSE
+ DBIx::Class::VersionCompat;
+use base 'DBIx::Class::Schema';
+use strict;
+use warnings;
+
+__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
+
# ---------------------------------------------------------------------------
+
+=head1 NAME
+
+DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+
+=head1 SYNOPSIS
+
+ package MyApp::Schema;
+ use base qw/DBIx::Class::Schema/;
+
+ our $VERSION = 0.001;
+
+ # load MyApp::Schema::CD, MyApp::Schema::Book, MyApp::Schema::DVD
+ __PACKAGE__->load_classes(qw/CD Book DVD/);
+
+ __PACKAGE__->load_components(qw/Schema::Versioned/);
+ __PACKAGE__->upgrade_directory('/path/to/upgrades/');
+
+
+=head1 DESCRIPTION
+
+This module provides methods to apply DDL changes to your database using SQL
+diff files. Normally these diff files would be created using
+L<DBIx::Class::Schema/create_ddl_dir>.
+
+A table called I<dbix_class_schema_versions> is created and maintained by the
+module. This is used to determine which version your database is currently at.
+Similarly the $VERSION in your DBIC schema class is used to determine the
+current DBIC schema version.
+
+The upgrade is initiated manually by calling C<upgrade> on your schema object,
+this will attempt to upgrade the database from its current version to the current
+schema version using a diff from your I<upgrade_directory>. If a suitable diff is
+not found then no upgrade is possible.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::DeploymentHandler> is a much more powerful alternative to this
+module. Examples of things it can do that this module cannot do include
+
+=over
+
+=item *
+
+Downgrades in addition to upgrades
+
+=item *
+
+Multiple sql files files per upgrade/downgrade/install
+
+=item *
+
+Perl scripts allowed for upgrade/downgrade/install
+
+=item *
+
+Just one set of files needed for upgrade, unlike this module where one might
+need to generate C<factorial(scalar @versions)>
+
+=back
+
+=head1 GETTING STARTED
+
+Firstly you need to setup your schema class as per the L</SYNOPSIS>, make sure
+you have specified an upgrade_directory and an initial $VERSION.
+
+Then you'll need two scripts, one to create DDL files and diffs and another to perform
+upgrades. Your creation script might look like a bit like this:
+
+ use strict;
+ use Pod::Usage;
+ use Getopt::Long;
+ use MyApp::Schema;
+
+ my ( $preversion, $help );
+ GetOptions(
+ 'p|preversion:s' => \$preversion,
+ ) or die pod2usage;
+
+ my $schema = MyApp::Schema->connect(
+ $dsn,
+ $user,
+ $password,
+ );
+ my $sql_dir = './sql';
+ my $version = $schema->schema_version();
+ $schema->create_ddl_dir( 'MySQL', $version, $sql_dir, $preversion );
+
+Then your upgrade script might look like so:
+
+ use strict;
+ use MyApp::Schema;
+
+ my $schema = MyApp::Schema->connect(
+ $dsn,
+ $user,
+ $password,
+ );
+
+ if (!$schema->get_db_version()) {
+ # schema is unversioned
+ $schema->deploy();
+ } else {
+ $schema->upgrade();
+ }
+
+The script above assumes that if the database is unversioned then it is empty
+and we can safely deploy the DDL to it. However things are not always so simple.
+
+if you want to initialise a pre-existing database where the DDL is not the same
+as the DDL for your current schema version then you will need a diff which
+converts the database's DDL to the current DDL. The best way to do this is
+to get a dump of the database schema (without data) and save that in your
+SQL directory as version 0.000 (the filename must be as with
+L<DBIx::Class::Schema/ddl_filename>) then create a diff using your create DDL
+script given above from version 0.000 to the current version. Then hand check
+and if necessary edit the resulting diff to ensure that it will apply. Once you have
+done all that you can do this:
+
+ if (!$schema->get_db_version()) {
+ # schema is unversioned
+ $schema->install("0.000");
+ }
+
+ # this will now apply the 0.000 to current version diff
+ $schema->upgrade();
+
+In the case of an unversioned database the above code will create the
+dbix_class_schema_versions table and write version 0.000 to it, then
+upgrade will then apply the diff we talked about creating in the previous paragraph
+and then you're good to go.
+
+=cut
+
package DBIx::Class::Schema::Versioned;
use strict;
use warnings;
-use base 'DBIx::Class';
-use POSIX 'strftime';
-use Data::Dumper;
+use base 'DBIx::Class::Schema';
+
+use DBIx::Class::Carp;
+use Time::HiRes qw/gettimeofday/;
+use Try::Tiny;
+use namespace::clean;
__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');
-sub schema_version {
- my ($self) = @_;
- my $class = ref($self)||$self;
- my $version;
- {
- no strict 'refs';
- $version = ${"${class}::VERSION"};
+
+=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 (note that backups
+are disabled by default).
+
+=cut
+
+=head2 install
+
+=over 4
+
+=item Arguments: $db_version
+
+=back
+
+Call this to initialise a previously unversioned database. The table 'dbix_class_schema_versions' will be created which will be used to store the database version.
+
+Takes one argument which should be the version that the database is currently at. Defaults to the return value of L</schema_version>.
+
+See L</getting_started> for more details.
+
+=cut
+
+sub install
+{
+ my ($self, $new_version) = @_;
+
+ # must be called on a fresh database
+ if ($self->get_db_version()) {
+ $self->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
+ }
+
+ # default to current version if none passed
+ $new_version ||= $self->schema_version();
+
+ if ($new_version) {
+ # create versions table and version row
+ $self->{vschema}->deploy;
+ $self->_set_db_version({ version => $new_version });
}
- return $version;
}
-sub connection {
+=head2 deploy
+
+Same as L<DBIx::Class::Schema/deploy> but also calls C<install>.
+
+=cut
+
+sub deploy {
my $self = shift;
$self->next::method(@_);
- $self->_on_connect;
- return $self;
+ $self->install();
}
-sub _on_connect
-{
+=head2 create_upgrade_path
+
+=over 4
+
+=item Arguments: { upgrade_file => $file }
+
+=back
+
+Virtual method that should be overridden to create an upgrade file.
+This is useful in the case of upgrading across multiple versions
+to concatenate several files to create one upgrade file.
+
+You'll probably want the db_version retrieved via $self->get_db_version
+and the schema_version which is retrieved via $self->schema_version
+
+=cut
+
+sub create_upgrade_path {
+ ## override this method
+}
+
+=head2 ordered_schema_versions
+
+=over 4
+
+=item Returns: a list of version numbers, ordered from lowest to highest
+
+=back
+
+Virtual method that should be overridden to return an ordered list
+of schema versions. This is then used to produce a set of steps to
+upgrade through to achieve the required schema version.
+
+You may want the db_version retrieved via $self->get_db_version
+and the schema_version which is retrieved via $self->schema_version
+
+=cut
+
+sub ordered_schema_versions {
+ ## override this method
+}
+
+=head2 upgrade
+
+Call this to attempt to upgrade your database from the version it
+is at to the version this DBIC schema is at. If they are the same
+it does nothing.
+
+It will call L</ordered_schema_versions> to retrieve an ordered
+list of schema versions (if ordered_schema_versions returns nothing
+then it is assumed you can do the upgrade as a single step). It
+then iterates through the list of versions between the current db
+version and the schema version applying one update at a time until
+all relevant updates are applied.
+
+The individual update steps are performed by using
+L</upgrade_single_step>, which will apply the update and also
+update the dbix_class_schema_versions table.
+
+=cut
+
+sub upgrade {
my ($self) = @_;
- $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
+ my $db_version = $self->get_db_version();
- my $pversion = $self->get_db_version();
+ # db unversioned
+ unless ($db_version) {
+ carp 'Upgrade not possible as database is unversioned. Please call install first.';
+ return;
+ }
- if($pversion eq $self->schema_version)
- {
- warn "This version is already installed\n";
- return 1;
+ # db and schema at same version. do nothing
+ if ( $db_version eq $self->schema_version ) {
+ carp 'Upgrade not necessary';
+ return;
}
- if(!$pversion)
+ my @version_list = $self->ordered_schema_versions;
+
+ # if nothing returned then we preload with min/max
+ @version_list = ( $db_version, $self->schema_version )
+ unless ( scalar(@version_list) );
+
+ # catch the case of someone returning an arrayref
+ @version_list = @{ $version_list[0] }
+ if ( ref( $version_list[0] ) eq 'ARRAY' );
+
+ # remove all versions in list above the required version
+ while ( scalar(@version_list)
+ && ( $version_list[-1] ne $self->schema_version ) )
{
- warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
- return 1;
+ pop @version_list;
}
- 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;
+ # remove all versions in list below the current version
+ while ( scalar(@version_list) && ( $version_list[0] ne $db_version ) ) {
+ shift @version_list;
}
+ # check we have an appropriate list of versions
+ if ( scalar(@version_list) < 2 ) {
+ die;
+ }
- ## 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";
+ # do sets of upgrade
+ while ( scalar(@version_list) >= 2 ) {
+ $self->upgrade_single_step( $version_list[0], $version_list[1] );
+ shift @version_list;
+ }
}
-sub get_db_version
-{
- my ($self, $rs) = @_;
+=head2 upgrade_single_step
- my $vtable = $self->{vschema}->resultset('Table');
- return 0 unless ($self->_source_exists($vtable));
-
- my $psearch = $vtable->search(undef,
- { select => [
- { 'max' => 'Installed' },
- ],
- as => ['maxinstall'],
- })->first;
- my $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
- })->first;
- $pversion = $pversion->Version if($pversion);
- return $pversion;
-}
+=over 4
-sub _source_exists
-{
- my ($self, $rs) = @_;
+=item Arguments: db_version - the version currently within the db
- my $c = eval {
- $rs->search({ 1, 0 })->count;
- };
- return 0 if $@ || !defined $c;
+=item Arguments: target_version - the version to upgrade to
- return 1;
-}
+=back
-sub backup
-{
- my ($self) = @_;
- ## Make each ::DBI::Foo do this
- $self->storage->backup($self->backup_directory());
-}
+Call this to attempt to upgrade your database from the
+I<db_version> to the I<target_version>. If they are the same it
+does nothing.
+
+It requires an SQL diff file to exist in your I<upgrade_directory>,
+normally you will have created this using L<DBIx::Class::Schema/create_ddl_dir>.
-sub upgrade
+If successful the dbix_class_schema_versions table is updated with
+the I<target_version>.
+
+This method may be called repeatedly by the upgrade method to
+upgrade through a series of updates.
+
+=cut
+
+sub upgrade_single_step
{
- my ($self) = @_;
- my $db_version = $self->get_db_version();
+ my ($self,
+ $db_version,
+ $target_version) = @_;
+
+ # db and schema at same version. do nothing
+ if ($db_version eq $target_version) {
+ carp 'Upgrade not necessary';
+ return;
+ }
- if (!$db_version) {
- my %driver_to_db_map = (
- 'mysql' => 'MySQL',
- 'Pg' => 'PostgreSQL',
- 'Oracle' => 'Oracle'
- );
- my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
- unless ($db) {
- print "Sorry, this is an unsupported DB\n";
- return;
- }
-
- 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,
- { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
-
- my $filename = $self->ddl_filename(
- $self->storage->sqlt_type,
- $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);
-
- # create versions table
- $self->{vschema}->deploy;
+ # strangely the first time this is called can
+ # differ to subsequent times. so we call it
+ # here to be sure.
+ # XXX - just fix it
+ $self->storage->sqlt_type;
- 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";
- } else {
- 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>));
- 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 $upgrade_file = $self->ddl_filename(
+ $self->storage->sqlt_type,
+ $target_version,
+ $self->upgrade_directory,
+ $db_version,
+ );
- my $vtable = $self->{vschema}->resultset('Table');
- $vtable->create({ Version => $self->schema_version,
- Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
- });
+ $self->create_upgrade_path({ upgrade_file => $upgrade_file });
+
+ unless (-f $upgrade_file) {
+ carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one";
+ return;
+ }
+
+ carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
+ # 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() });
+
+ # set row in dbix_class_schema_versions table
+ $self->_set_db_version({version => $target_version});
}
+=head2 do_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. Will run the whole file as it is by default.
+
+=cut
+
sub do_upgrade
{
- my ($self) = @_;
+ 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);
+ # just run all the commands (including inserts) in order
+ $self->run_upgrade(qr/.*?/);
}
+=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<do_upgrade> method, running whichever commands you specify via the
+regex in the parameter. Probably won't work unless called from the overridable
+do_upgrade method.
+
+=cut
+
sub run_upgrade
{
my ($self, $stm) = @_;
-# print "Reg: $stm\n";
+
+ return unless ($self->_filedata);
my @statements = grep { $_ =~ $stm } @{$self->_filedata};
-# print "Statements: ", join("\n", @statements), "\n";
$self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
for (@statements)
{
$self->storage->debugobj->query_start($_) if $self->storage->debug;
- $self->storage->dbh->do($_) or warn "SQL was:\n $_";
+ $self->apply_statement($_);
$self->storage->debugobj->query_end($_) if $self->storage->debug;
}
return 1;
}
-1;
+=head2 apply_statement
-=head1 NAME
+Takes an SQL statement and runs it. Override this if you want to handle errors
+differently.
-DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
+=cut
-=head1 SYNOPSIS
+sub apply_statement {
+ my ($self, $statement) = @_;
- 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/);
+ $self->storage->dbh->do($_) or carp "SQL was: $_";
+}
- __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
- __PACKAGE__->upgrade_directory('/path/to/upgrades/');
- __PACKAGE__->backup_directory('/path/to/backups/');
+=head2 get_db_version
- sub backup
- {
- my ($self) = @_;
- # my special backup process
- }
+Returns the version that your database is currently at. This is determined by the values in the
+dbix_class_schema_versions table that C<upgrade> and C<install> write to.
+
+=cut
+
+sub get_db_version
+{
+ my ($self, $rs) = @_;
+
+ my $vtable = $self->{vschema}->resultset('Table');
+ my $version = try {
+ $vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
+ ->get_column ('version')
+ ->next;
+ };
+ return $version || 0;
+}
+
+=head2 schema_version
+
+Returns the current schema class' $VERSION
+
+=cut
+
+=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..
+
+This method is disabled by default. Set $schema->do_backup(1) to enable it.
+
+=cut
- sub upgrade
- {
+sub backup
+{
my ($self) = @_;
+ ## Make each ::DBI::Foo do this
+ $self->storage->backup($self->backup_directory());
+}
- ## overridable sub, per default just runs all the commands.
+=head2 connection
- $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);
- }
+Overloaded method. This checks the DBIC schema version against the DB version and
+warns if they are not the same or if the DB is unversioned. It also provides
+compatibility between the old versions table (SchemaVersions) and the new one
+(dbix_class_schema_versions).
-=head1 DESCRIPTION
+To avoid the checks on connect, set the environment var DBIC_NO_VERSION_CHECK or alternatively you can set the ignore_version attr in the forth argument like so:
-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.
+ my $schema = MyApp::Schema->connect(
+ $dsn,
+ $user,
+ $password,
+ { ignore_version => 1 },
+ );
-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.
+=cut
-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.
+sub connection {
+ my $self = shift;
+ $self->next::method(@_);
+ $self->_on_connect();
+ return $self;
+}
-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.
+sub _on_connect
+{
+ my ($self) = @_;
-NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
-returns SQL statements that SQLite does not support.
+ my $conn_info = $self->storage->connect_info;
+ $self->{vschema} = DBIx::Class::Version->connect(@$conn_info);
+ my $conn_attrs = $self->{vschema}->storage->_dbic_connect_attributes || {};
+ my $vtable = $self->{vschema}->resultset('Table');
-=head1 METHODS
+ # useful when connecting from scripts etc
+ return if ($conn_attrs->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $conn_attrs->{ignore_version}));
-=head2 backup
+ # check for legacy versions table and move to new if exists
+ unless ($self->_source_exists($vtable)) {
+ my $vtable_compat = DBIx::Class::VersionCompat->connect(@$conn_info)->resultset('TableCompat');
+ if ($self->_source_exists($vtable_compat)) {
+ $self->{vschema}->deploy;
+ map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
+ $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
+ }
+ }
-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.
+ my $pversion = $self->get_db_version();
-This method should return the name of the backup file, if appropriate..
+ if($pversion eq $self->schema_version)
+ {
+ #carp "This version is already installed";
+ return 1;
+ }
-=head2 upgrade
+ if(!$pversion)
+ {
+ carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.";
+ return 1;
+ }
-This is the main upgrade method which calls the overridable do_upgrade and
-also handles the backups and updating of the SchemaVersion table.
+ carp "Versions out of sync. This is " . $self->schema_version .
+ ", your database contains version $pversion, please call upgrade on your Schema.";
+}
-=head2 do_upgrade
+# is this just a waste of time? if not then merge with DBI.pm
+sub _create_db_to_schema_diff {
+ my $self = shift;
-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.
+ my %driver_to_db_map = (
+ 'mysql' => 'MySQL'
+ );
-=head2 run_upgrade
+ my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
+ unless ($db) {
+ print "Sorry, this is an unsupported DB\n";
+ return;
+ }
- $self->run_upgrade(qr/create/i);
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) {
+ $self->throw_exception("Unable to proceed without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
-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.
+ 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->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);
+ }
-=head2 upgrade_directory
+ 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->schema_version,
+ $self->upgrade_directory,
+ 'PRE',
+ );
+ my $file;
+ if(!open($file, ">$filename"))
+ {
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
+ }
+ print $file $diff;
+ close($file);
-Use this to set the directory your upgrade files are stored in.
+ carp "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.";
+}
-=head2 backup_directory
-Use this to set the directory you want your backups stored in.
+sub _set_db_version {
+ my $self = shift;
+ my ($params) = @_;
+ $params ||= {};
+
+ my $version = $params->{version} ? $params->{version} : $self->schema_version;
+ my $vtable = $self->{vschema}->resultset('Table');
+
+ ##############################################################################
+ # !!! NOTE !!!
+ ##############################################################################
+ #
+ # The travesty below replaces the old nice timestamp format of %Y-%m-%d %H:%M:%S
+ # This is necessary since there are legitimate cases when upgrades can happen
+ # back to back within the same second. This breaks things since we relay on the
+ # ability to sort by the 'installed' value. The logical choice of an autoinc
+ # is not possible, as it will break multiple legacy installations. Also it is
+ # not possible to format the string sanely, as the column is a varchar(20).
+ # The 'v' character is added to the front of the string, so that any version
+ # formatted by this new function will sort _after_ any existing 200... strings.
+ my @tm = gettimeofday();
+ my @dt = gmtime ($tm[0]);
+ my $o = $vtable->create({
+ version => $version,
+ installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f",
+ $dt[5] + 1900,
+ $dt[4] + 1,
+ $dt[3],
+ $dt[2],
+ $dt[1],
+ $dt[0],
+ int($tm[1] / 1000), # convert to millisecs
+ ),
+ });
+}
+
+sub _read_sql_file {
+ my $self = shift;
+ my $file = shift || return;
-=head2 schema_version
+ open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
+ my @data = split /\n/, join '', <$fh>;
+ close $fh;
+
+ @data = split /;/,
+ join '',
+ grep { $_ &&
+ !/^--/ &&
+ !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/mi }
+ @data;
+
+ return \@data;
+}
+
+sub _source_exists
+{
+ my ($self, $rs) = @_;
+
+ return try {
+ $rs->search(\'1=0')->cursor->next;
+ 1;
+ } catch {
+ 0;
+ };
+}
+
+1;
+
+
+=head1 AUTHOR AND CONTRIBUTORS
-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.
+See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
-=head1 AUTHOR
+=head1 LICENSE
-Jess Robinson <castaway@desert-island.demon.co.uk>
+You may distribute this code under the same terms as Perl itself.
projects / dbsrgits/DBIx-Class.git / blobdiff