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

  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
8424c090	289	my $upgrade_file = $self->ddl_filename(
	290	$self->storage->sqlt_type,
	291	$self->upgrade_directory,
	292	$self->schema_version,
	293	$db_version,
	294	);
c9d2e0a2	295
8424c090	296	unless (-f $upgrade_file) {
	297	warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
	298	return;
	299	}
c9d2e0a2	300
8424c090	301	# backup if necessary then apply upgrade
	302	$self->_filedata($self->_read_sql_file($upgrade_file));
	303	$self->backup() if($self->do_backup);
	304	$self->txn_do(sub { $self->do_upgrade() });
c9d2e0a2	305
b4b1e91c	306	# set row in dbix_class_schema_versions table
8424c090	307	$self->_set_db_version;
8424c090	308	}
c9d2e0a2	309
8424c090	310	sub _set_db_version {
8424c090	311	my $self = shift;
c9d2e0a2	312
8424c090	313	my $vtable = $self->{vschema}->resultset('Table');
	314	$vtable->create({ Version => $self->schema_version,
	315	Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
	316	});
c9d2e0a2	317
8424c090	318	}
c9d2e0a2	319
8424c090	320	sub _read_sql_file {
	321	my $self = shift;
	322	my $file = shift \|\| return;
	323
	324	my $fh;
	325	open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
d89d8604	326	my @data = split(/\n/, join('', <$fh>));
	327	@data = grep(!/^--/, @data);
	328	@data = split(/;/, join('', @data));
8424c090	329	close($fh);
	330	@data = grep { $_ && $_ !~ /^-- / } @data;
	331	@data = grep { $_ !~ /^(BEGIN TRANACTION\|COMMIT)/m } @data;
	332	return \@data;
	333	}
e6129e56	334
	335	=head2 do_upgrade
	336
c9d2e0a2	337	This is an overwritable method used to run your upgrade. The freeform method
	338	allows you to run your upgrade any way you please, you can call C<run_upgrade>
	339	any number of times to run the actual SQL commands, and in between you can
	340	sandwich your data upgrading. For example, first run all the B<CREATE>
	341	commands, then migrate your data from old to new tables/formats, then
	342	issue the DROP commands when you are finished.
	343
8424c090	344	Will run the whole file as it is by default.
	345
	346	=cut
	347
	348	sub do_upgrade
	349	{
	350	my ($self) = @_;
	351
	352	## overridable sub, per default just run all the commands.
	353	$self->run_upgrade(qr/create/i);
	354	$self->run_upgrade(qr/alter table .*? add/i);
	355	$self->run_upgrade(qr/alter table .*? (?!drop)/i);
	356	$self->run_upgrade(qr/alter table .*? drop/i);
	357	$self->run_upgrade(qr/drop/i);
	358	}
	359
c9d2e0a2	360	=head2 run_upgrade
	361
	362	$self->run_upgrade(qr/create/i);
	363
	364	Runs a set of SQL statements matching a passed in regular expression. The
	365	idea is that this method can be called any number of times from your
	366	C<upgrade> method, running whichever commands you specify via the
8424c090	367	regex in the parameter. Probably won't work unless called from the overridable
8424c090	368	do_upgrade method.
c9d2e0a2	369
8424c090	370	=cut
8795fefb	371
8424c090	372	sub run_upgrade
	373	{
	374	my ($self, $stm) = @_;
8795fefb	375
8424c090	376	return unless ($self->_filedata);
	377	my @statements = grep { $_ =~ $stm } @{$self->_filedata};
	378	$self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
8795fefb	379
8424c090	380	for (@statements)
	381	{
	382	$self->storage->debugobj->query_start($_) if $self->storage->debug;
	383	$self->storage->dbh->do($_) or warn "SQL was:\n $_";
	384	$self->storage->debugobj->query_end($_) if $self->storage->debug;
	385	}
8795fefb	386
8424c090	387	return 1;
8424c090	388	}
42416a0b	389
8424c090	390	sub connection {
	391	my $self = shift;
	392	$self->next::method(@_);
	393	$self->_on_connect;
	394	return $self;
	395	}
	396
	397	sub _on_connect
	398	{
	399	my ($self) = @_;
	400	$self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
b4b1e91c	401	my $vtable = $self->{vschema}->resultset('Table');
	402
	403	# check for legacy versions table and move to new if exists
	404	my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
	405	unless ($self->_source_exists($vtable)) {
	406	my $vtable_compat = $vschema_compat->resultset('TableCompat');
	407	if ($self->_source_exists($vtable_compat)) {
	408	$self->{vschema}->deploy;
	409	map { $vtable->create({$_->get_columns}) } $vtable_compat->all;
	410	$self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
	411	}
	412	}
8424c090	413
	414	my $pversion = $self->get_db_version();
	415
	416	if($pversion eq $self->schema_version)
	417	{
	418	warn "This version is already installed\n";
	419	return 1;
	420	}
42416a0b	421
8424c090	422	if(!$pversion)
	423	{
	424	warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
	425	return 1;
	426	}
	427
	428	warn "Versions out of sync. This is " . $self->schema_version .
	429	", your database contains version $pversion, please call upgrade on your Schema.\n";
	430	}
	431
	432	1;
	433
	434
	435	=head1 AUTHORS
c9d2e0a2	436
c9d2e0a2	437	Jess Robinson <castaway@desert-island.demon.co.uk>
8424c090	438	Luke Saunders <luke@shadowcatsystems.co.uk>
	439
	440	=head1 LICENSE
	441
	442	You may distribute this code under the same terms as Perl itself.