[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Schema / Versioned.pm

package DBIx::Class::Version::Table;
use base 'DBIx::Class';
use strict;
use warnings;

__PACKAGE__->load_components(qw/ Core/);
__PACKAGE__->table('dbix_class_schema_versions');

__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::TableCompat;
use base 'DBIx::Class::Version::Table';

__PACKAGE__->table('SchemaVersions');

package DBIx::Class::Version;
use base 'DBIx::Class::Schema';
use strict;
use warnings;

__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');

package 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 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<dbix_class_schema_versions> 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;
use warnings;
use base 'DBIx::Class';
use POSIX 'strftime';
use Data::Dumper;

__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) = @_;
  my $class = ref($self)||$self;
  my $version;
  {
    no strict 'refs';
    $version = ${"${class}::VERSION"};
  }
  return $version;
}

=head2 get_db_version

Returns the version that your database is currently at. This is determined by the values in the
dbix_class_schema_versions table that $self->upgrade writes to.

=cut

sub get_db_version
{
    my ($self, $rs) = @_;

    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;
}

sub _source_exists
{
    my ($self, $rs) = @_;

    my $c = eval {
        $rs->search({ 1, 0 })->count;
    };
    return 0 if $@ || !defined $c;

    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) = @_;
    ## Make each ::DBI::Foo do this
    $self->storage->backup($self->backup_directory());
}

# is this just a waste of time? if not then merge with DBI.pm
sub _create_db_to_schema_diff {
  my $self = shift;

  my %driver_to_db_map = (
                          'mysql' => 'MySQL'
                         );

  my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
  unless ($db) {
    print "Sorry, this is an unsupported DB\n";
    return;
  }

  eval 'require SQL::Translator "0.09"';
  if ($@) {
    $self->throw_exception("SQL::Translator 0.09 required");
  }

  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(
                                         $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";
}

=head2 upgrade

Call this to attempt to upgrade your database from the version it is at to the version
this DBIC schema is at. 

It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
have created this using $schema->create_ddl_dir.

=cut

sub upgrade
{
  my ($self) = @_;
  my $db_version = $self->get_db_version();

  # db unversioned
  unless ($db_version) {
    # set version in dbix_class_schema_versions 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);

    # create versions table and version row
    $self->{vschema}->deploy;
    $self->_set_db_version;
    return;
  }

  # db and schema at same version. do nothing
  if ($db_version eq $self->schema_version) {
    print "Upgrade not necessary\n";
    return;
  }

  # 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;
  
  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;
  }

  # 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;
}

sub _set_db_version {
  my $self = shift;

  my $vtable = $self->{vschema}->resultset('Table');
  $vtable->create({ Version => $self->schema_version,
                      Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
                      });

}

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>));
  @data = grep(!/^--/, @data);
  @data = split(/;/, join('', @data));
  close($fh);
  @data = grep { $_ && $_ !~ /^-- / } @data;
  @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
  return \@data;
}

=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) = @_;

    ## 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);

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. Probably won't work unless called from the overridable
do_upgrade method.

=cut

sub run_upgrade
{
    my ($self, $stm) = @_;

    return unless ($self->_filedata);
    my @statements = grep { $_ =~ $stm } @{$self->_filedata};
    $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->storage->debugobj->query_end($_) if $self->storage->debug;
    }

    return 1;
}

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 $vtable = $self->{vschema}->resultset('Table');

  # check for legacy versions table and move to new if exists
  my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
  unless ($self->_source_exists($vtable)) {
    my $vtable_compat = $vschema_compat->resultset('TableCompat');
    if ($self->_source_exists($vtable_compat)) {
      $self->{vschema}->deploy;
      map { $vtable->create({$_->get_columns}) } $vtable_compat->all;
      $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
    }
  }

  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;
    }

  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.
Commit	Line	Data
c9d2e0a2	1	package DBIx::Class::Version::Table;
	2	use base 'DBIx::Class';
	3	use strict;
	4	use warnings;
	5
	6	__PACKAGE__->load_components(qw/ Core/);
b4b1e91c	7	__PACKAGE__->table('dbix_class_schema_versions');
c9d2e0a2	8
ad1446da	9	__PACKAGE__->add_columns
	10	( 'Version' => {
	11	'data_type' => 'VARCHAR',
	12	'is_auto_increment' => 0,
	13	'default_value' => undef,
	14	'is_foreign_key' => 0,
	15	'name' => 'Version',
	16	'is_nullable' => 0,
	17	'size' => '10'
	18	},
c9d2e0a2	19	'Installed' => {
	20	'data_type' => 'VARCHAR',
	21	'is_auto_increment' => 0,
	22	'default_value' => undef,
	23	'is_foreign_key' => 0,
	24	'name' => 'Installed',
	25	'is_nullable' => 0,
	26	'size' => '20'
ad1446da	27	},
ad1446da	28	);
c9d2e0a2	29	__PACKAGE__->set_primary_key('Version');
c9d2e0a2	30
b4b1e91c	31	package DBIx::Class::Version::TableCompat;
	32	use base 'DBIx::Class::Version::Table';
	33
	34	__PACKAGE__->table('SchemaVersions');
	35
c9d2e0a2	36	package DBIx::Class::Version;
	37	use base 'DBIx::Class::Schema';
	38	use strict;
	39	use warnings;
	40
	41	__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
	42
b4b1e91c	43	package DBIx::Class::VersionCompat;
	44	use base 'DBIx::Class::Schema';
	45	use strict;
	46	use warnings;
	47
	48	__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
	49
c9d2e0a2	50
c9d2e0a2	51	# ---------------------------------------------------------------------------
8424c090	52
	53	=head1 NAME
	54
	55	DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
	56
	57	=head1 SYNOPSIS
	58
	59	package Library::Schema;
	60	use base qw/DBIx::Class::Schema/;
	61	# load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
	62	__PACKAGE__->load_classes(qw/CD Book DVD/);
	63
	64	__PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
	65	__PACKAGE__->upgrade_directory('/path/to/upgrades/');
	66	__PACKAGE__->backup_directory('/path/to/backups/');
	67
	68
	69	=head1 DESCRIPTION
	70
	71	This module is a component designed to extend L<DBIx::Class::Schema>
	72	classes, to enable them to upgrade to newer schema layouts. To use this
	73	module, you need to have called C<create_ddl_dir> on your Schema to
	74	create your upgrade files to include with your delivery.
	75
b4b1e91c	76	A table called I<dbix_class_schema_versions> is created and maintained by the
8424c090	77	module. This contains two fields, 'Version' and 'Installed', which
	78	contain each VERSION of your Schema, and the date+time it was installed.
	79
	80	The actual upgrade is called manually by calling C<upgrade> on your
	81	schema object. Code is run at connect time to determine whether an
	82	upgrade is needed, if so, a warning "Versions out of sync" is
	83	produced.
	84
	85	So you'll probably want to write a script which generates your DDLs and diffs
	86	and another which executes the upgrade.
	87
	88	NB: At the moment, only SQLite and MySQL are supported. This is due to
	89	spotty behaviour in the SQL::Translator producers, please help us by
	90	them.
	91
	92	=head1 METHODS
	93
	94	=head2 upgrade_directory
	95
	96	Use this to set the directory your upgrade files are stored in.
	97
	98	=head2 backup_directory
	99
	100	Use this to set the directory you want your backups stored in.
	101
	102	=cut
	103
c9d2e0a2	104	package DBIx::Class::Schema::Versioned;
	105
	106	use strict;
	107	use warnings;
	108	use base 'DBIx::Class';
	109	use POSIX 'strftime';
	110	use Data::Dumper;
	111
	112	__PACKAGE__->mk_classdata('_filedata');
	113	__PACKAGE__->mk_classdata('upgrade_directory');
8795fefb	114	__PACKAGE__->mk_classdata('backup_directory');
f925f7cb	115	__PACKAGE__->mk_classdata('do_backup');
8424c090	116	__PACKAGE__->mk_classdata('do_diff_on_init');
	117
	118	=head2 schema_version
	119
	120	Returns the current schema class' $VERSION; does -not- use $schema->VERSION
	121	since that varies in results depending on if version.pm is installed, and if
	122	so the perl or XS versions. If you want this to change, bug the version.pm
	123	author to make vpp and vxs behave the same.
	124
	125	=cut
c9d2e0a2	126
42416a0b	127	sub schema_version {
	128	my ($self) = @_;
	129	my $class = ref($self)\|\|$self;
	130	my $version;
	131	{
	132	no strict 'refs';
	133	$version = ${"${class}::VERSION"};
	134	}
	135	return $version;
	136	}
	137
8424c090	138	=head2 get_db_version
c9d2e0a2	139
8424c090	140	Returns the version that your database is currently at. This is determined by the values in the
b4b1e91c	141	dbix_class_schema_versions table that $self->upgrade writes to.
c9d2e0a2	142
8424c090	143	=cut
c9d2e0a2	144
e6129e56	145	sub get_db_version
	146	{
	147	my ($self, $rs) = @_;
	148
	149	my $vtable = $self->{vschema}->resultset('Table');
0d865134	150	return 0 unless ($self->_source_exists($vtable));
0d865134	151
e6129e56	152	my $psearch = $vtable->search(undef,
	153	{ select => [
	154	{ 'max' => 'Installed' },
	155	],
	156	as => ['maxinstall'],
	157	})->first;
f925f7cb	158	my $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
e6129e56	159	})->first;
	160	$pversion = $pversion->Version if($pversion);
	161	return $pversion;
	162	}
	163
a2800991	164	sub _source_exists
c9d2e0a2	165	{
	166	my ($self, $rs) = @_;
	167
	168	my $c = eval {
	169	$rs->search({ 1, 0 })->count;
	170	};
	171	return 0 if $@ \|\| !defined $c;
	172
	173	return 1;
	174	}
	175
8424c090	176	=head2 backup
	177
	178	This is an overwritable method which is called just before the upgrade, to
	179	allow you to make a backup of the database. Per default this method attempts
	180	to call C<< $self->storage->backup >>, to run the standard backup on each
	181	database type.
	182
	183	This method should return the name of the backup file, if appropriate..
	184
	185	=cut
	186
c9d2e0a2	187	sub backup
	188	{
	189	my ($self) = @_;
	190	## Make each ::DBI::Foo do this
8795fefb	191	$self->storage->backup($self->backup_directory());
c9d2e0a2	192	}
c9d2e0a2	193
b6d9f089	194	# is this just a waste of time? if not then merge with DBI.pm
8424c090	195	sub _create_db_to_schema_diff {
8424c090	196	my $self = shift;
c9d2e0a2	197
8424c090	198	my %driver_to_db_map = (
	199	'mysql' => 'MySQL'
	200	);
e6129e56	201
8424c090	202	my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
	203	unless ($db) {
	204	print "Sorry, this is an unsupported DB\n";
	205	return;
	206	}
c9d2e0a2	207
b6d9f089	208	eval 'require SQL::Translator "0.09"';
	209	if ($@) {
	210	$self->throw_exception("SQL::Translator 0.09 required");
	211	}
8424c090	212
	213	my $db_tr = SQL::Translator->new({
	214	add_drop_table => 1,
	215	parser => 'DBI',
	216	parser_args => { dbh => $self->storage->dbh }
	217	});
	218
	219	$db_tr->producer($db);
	220	my $dbic_tr = SQL::Translator->new;
	221	$dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
	222	$dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
	223	$dbic_tr->data($self);
	224	$dbic_tr->producer($db);
	225
	226	$db_tr->schema->name('db_schema');
	227	$dbic_tr->schema->name('dbic_schema');
	228
	229	# is this really necessary?
	230	foreach my $tr ($db_tr, $dbic_tr) {
	231	my $data = $tr->data;
	232	$tr->parser->($tr, $$data);
	233	}
c9d2e0a2	234
8424c090	235	my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
	236	$dbic_tr->schema, $db,
	237	{ ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
	238
	239	my $filename = $self->ddl_filename(
	240	$db,
	241	$self->upgrade_directory,
	242	$self->schema_version,
	243	'PRE',
	244	);
	245	my $file;
	246	if(!open($file, ">$filename"))
	247	{
	248	$self->throw_exception("Can't open $filename for writing ($!)");
	249	next;
c9d2e0a2	250	}
8424c090	251	print $file $diff;
8424c090	252	close($file);
c9d2e0a2	253
8424c090	254	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";
c9d2e0a2	255	}
c9d2e0a2	256
8424c090	257	=head2 upgrade
e2c0df8e	258
8424c090	259	Call this to attempt to upgrade your database from the version it is at to the version
8424c090	260	this DBIC schema is at.
c9d2e0a2	261
8424c090	262	It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
8424c090	263	have created this using $schema->create_ddl_dir.
c9d2e0a2	264
8424c090	265	=cut
c9d2e0a2	266
8424c090	267	sub upgrade
	268	{
	269	my ($self) = @_;
	270	my $db_version = $self->get_db_version();
c9d2e0a2	271
8424c090	272	# db unversioned
8424c090	273	unless ($db_version) {
b4b1e91c	274	# set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at
8424c090	275	$self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
c9d2e0a2	276
8424c090	277	# create versions table and version row
	278	$self->{vschema}->deploy;
	279	$self->_set_db_version;
	280	return;
c9d2e0a2	281	}
c9d2e0a2	282
8424c090	283	# db and schema at same version. do nothing
	284	if ($db_version eq $self->schema_version) {
	285	print "Upgrade not necessary\n";
	286	return;
c9d2e0a2	287	}
c9d2e0a2	288
37fcb5b5	289	# strangely the first time this is called can
	290	# differ to subsequent times. so we call it
	291	# here to be sure.
	292	# XXX - just fix it
	293	$self->storage->sqlt_type;
	294
8424c090	295	my $upgrade_file = $self->ddl_filename(
	296	$self->storage->sqlt_type,
	297	$self->upgrade_directory,
	298	$self->schema_version,
	299	$db_version,
	300	);
c9d2e0a2	301
8424c090	302	unless (-f $upgrade_file) {
	303	warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
	304	return;
	305	}
c9d2e0a2	306
8424c090	307	# backup if necessary then apply upgrade
	308	$self->_filedata($self->_read_sql_file($upgrade_file));
	309	$self->backup() if($self->do_backup);
	310	$self->txn_do(sub { $self->do_upgrade() });
c9d2e0a2	311
b4b1e91c	312	# set row in dbix_class_schema_versions table
8424c090	313	$self->_set_db_version;
8424c090	314	}
c9d2e0a2	315
8424c090	316	sub _set_db_version {
8424c090	317	my $self = shift;
c9d2e0a2	318
8424c090	319	my $vtable = $self->{vschema}->resultset('Table');
	320	$vtable->create({ Version => $self->schema_version,
	321	Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
	322	});
c9d2e0a2	323
8424c090	324	}
c9d2e0a2	325
8424c090	326	sub _read_sql_file {
	327	my $self = shift;
	328	my $file = shift \|\| return;
	329
	330	my $fh;
	331	open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
d89d8604	332	my @data = split(/\n/, join('', <$fh>));
	333	@data = grep(!/^--/, @data);
	334	@data = split(/;/, join('', @data));
8424c090	335	close($fh);
	336	@data = grep { $_ && $_ !~ /^-- / } @data;
	337	@data = grep { $_ !~ /^(BEGIN TRANACTION\|COMMIT)/m } @data;
	338	return \@data;
	339	}
e6129e56	340
	341	=head2 do_upgrade
	342
c9d2e0a2	343	This is an overwritable method used to run your upgrade. The freeform method
	344	allows you to run your upgrade any way you please, you can call C<run_upgrade>
	345	any number of times to run the actual SQL commands, and in between you can
	346	sandwich your data upgrading. For example, first run all the B<CREATE>
	347	commands, then migrate your data from old to new tables/formats, then
	348	issue the DROP commands when you are finished.
	349
8424c090	350	Will run the whole file as it is by default.
	351
	352	=cut
	353
	354	sub do_upgrade
	355	{
	356	my ($self) = @_;
	357
	358	## overridable sub, per default just run all the commands.
	359	$self->run_upgrade(qr/create/i);
	360	$self->run_upgrade(qr/alter table .*? add/i);
	361	$self->run_upgrade(qr/alter table .*? (?!drop)/i);
	362	$self->run_upgrade(qr/alter table .*? drop/i);
	363	$self->run_upgrade(qr/drop/i);
	364	}
	365
c9d2e0a2	366	=head2 run_upgrade
	367
	368	$self->run_upgrade(qr/create/i);
	369
	370	Runs a set of SQL statements matching a passed in regular expression. The
	371	idea is that this method can be called any number of times from your
	372	C<upgrade> method, running whichever commands you specify via the
8424c090	373	regex in the parameter. Probably won't work unless called from the overridable
8424c090	374	do_upgrade method.
c9d2e0a2	375
8424c090	376	=cut
8795fefb	377
8424c090	378	sub run_upgrade
	379	{
	380	my ($self, $stm) = @_;
8795fefb	381
8424c090	382	return unless ($self->_filedata);
	383	my @statements = grep { $_ =~ $stm } @{$self->_filedata};
	384	$self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
8795fefb	385
8424c090	386	for (@statements)
	387	{
	388	$self->storage->debugobj->query_start($_) if $self->storage->debug;
	389	$self->storage->dbh->do($_) or warn "SQL was:\n $_";
	390	$self->storage->debugobj->query_end($_) if $self->storage->debug;
	391	}
8795fefb	392
8424c090	393	return 1;
8424c090	394	}
42416a0b	395
8424c090	396	sub connection {
	397	my $self = shift;
	398	$self->next::method(@_);
	399	$self->_on_connect;
	400	return $self;
	401	}
	402
	403	sub _on_connect
	404	{
	405	my ($self) = @_;
	406	$self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
b4b1e91c	407	my $vtable = $self->{vschema}->resultset('Table');
	408
	409	# check for legacy versions table and move to new if exists
	410	my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
	411	unless ($self->_source_exists($vtable)) {
	412	my $vtable_compat = $vschema_compat->resultset('TableCompat');
	413	if ($self->_source_exists($vtable_compat)) {
	414	$self->{vschema}->deploy;
	415	map { $vtable->create({$_->get_columns}) } $vtable_compat->all;
	416	$self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
	417	}
	418	}
8424c090	419
	420	my $pversion = $self->get_db_version();
	421
	422	if($pversion eq $self->schema_version)
	423	{
	424	warn "This version is already installed\n";
	425	return 1;
	426	}
42416a0b	427
8424c090	428	if(!$pversion)
	429	{
	430	warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
	431	return 1;
	432	}
	433
	434	warn "Versions out of sync. This is " . $self->schema_version .
	435	", your database contains version $pversion, please call upgrade on your Schema.\n";
	436	}
	437
	438	1;
	439
	440
	441	=head1 AUTHORS
c9d2e0a2	442
c9d2e0a2	443	Jess Robinson <castaway@desert-island.demon.co.uk>
8424c090	444	Luke Saunders <luke@shadowcatsystems.co.uk>
	445
	446	=head1 LICENSE
	447
	448	You may distribute this code under the same terms as Perl itself.