[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('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');
__PACKAGE__->mk_classdata('backup_directory');
__PACKAGE__->mk_classdata('do_backup');

sub schema_version {
  my ($self) = @_;
  my $class = ref($self)||$self;
  my $version;
  {
    no strict 'refs';
    $version = ${"${class}::VERSION"};
  }
  return $version;
}

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');
    my $pversion;

    if(!$self->_source_exists($vtable))
    {
#        $self->{vschema}->storage->debug(1);
        $self->{vschema}->storage->ensure_connected();
        $self->{vschema}->deploy();
        $pversion = 0;
    }
    else
    {
      $pversion = $self->get_db_version();
    }
#    warn("Previous version: $pversion\n");
    if($pversion eq $self->schema_version)
    {
        warn "This version is already installed\n";
        return 1;
    }

## use IC::DT?    

    if(!$pversion)
    {
        $vtable->create({ Version => $self->schema_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->schema_version
                                   );
    if(!$file)
    {
        # No upgrade path between these two versions
        return 1;
    }

     $file = $self->ddl_filename(
                                 $self->storage->sqlt_type,
                                 $self->upgrade_directory,
                                 $self->schema_version,
                                 $pversion,
                                 );
#    $file =~ s/@{[ $self->schema_version ]}/"${pversion}-" . $self->schema_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->schema_version . 
        ", your database contains version $pversion, please call upgrade on your Schema.\n";
#    $self->upgrade($pversion, $self->schema_version);
}

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

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

sub backup
{
    my ($self) = @_;
    ## Make each ::DBI::Foo do this
    $self->storage->backup($self->backup_directory());
}

sub upgrade
{
    my ($self) = @_;

    $self->backup() if($self->do_backup);

    $self->txn_do(sub {
      $self->do_upgrade();
    });

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

}

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

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

1;

=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/');

  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.

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.

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..

=head2 upgrade

This is the main upgrade method which calls the overridable do_upgrade and
also handles the backups and updating of the SchemaVersion table.

=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.

=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.

=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.

=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.

=head1 AUTHOR

Jess Robinson <castaway@desert-island.demon.co.uk>
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/);
	7	__PACKAGE__->table('SchemaVersions');
	8
	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	},
	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'
	27	},
	28	);
	29	__PACKAGE__->set_primary_key('Version');
	30
	31	package DBIx::Class::Version;
	32	use base 'DBIx::Class::Schema';
	33	use strict;
	34	use warnings;
	35
	36	__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
	37
	38
	39	# ---------------------------------------------------------------------------
	40	package DBIx::Class::Schema::Versioned;
	41
	42	use strict;
	43	use warnings;
	44	use base 'DBIx::Class';
	45	use POSIX 'strftime';
	46	use Data::Dumper;
	47
	48	__PACKAGE__->mk_classdata('_filedata');
	49	__PACKAGE__->mk_classdata('upgrade_directory');
8795fefb	50	__PACKAGE__->mk_classdata('backup_directory');
f925f7cb	51	__PACKAGE__->mk_classdata('do_backup');
c9d2e0a2	52
42416a0b	53	sub schema_version {
	54	my ($self) = @_;
	55	my $class = ref($self)\|\|$self;
	56	my $version;
	57	{
	58	no strict 'refs';
	59	$version = ${"${class}::VERSION"};
	60	}
	61	return $version;
	62	}
	63
a2800991	64	sub connection {
	65	my $self = shift;
	66	$self->next::method(@_);
	67	$self->_on_connect;
	68	return $self;
	69	}
	70
737416a4	71	sub _on_connect
c9d2e0a2	72	{
c9d2e0a2	73	my ($self) = @_;
e6129e56	74	$self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
e6129e56	75	my $vtable = $self->{vschema}->resultset('Table');
c9d2e0a2	76	my $pversion;
e2c0df8e	77
a2800991	78	if(!$self->_source_exists($vtable))
c9d2e0a2	79	{
e6129e56	80	# $self->{vschema}->storage->debug(1);
	81	$self->{vschema}->storage->ensure_connected();
	82	$self->{vschema}->deploy();
c9d2e0a2	83	$pversion = 0;
	84	}
	85	else
	86	{
e6129e56	87	$pversion = $self->get_db_version();
c9d2e0a2	88	}
c9d2e0a2	89	# warn("Previous version: $pversion\n");
42416a0b	90	if($pversion eq $self->schema_version)
c9d2e0a2	91	{
	92	warn "This version is already installed\n";
	93	return 1;
	94	}
	95
	96	## use IC::DT?
	97
	98	if(!$pversion)
	99	{
42416a0b	100	$vtable->create({ Version => $self->schema_version,
c9d2e0a2	101	Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
	102	});
	103	## If we let the user do this, where does the Version table get updated?
	104	warn "No previous version found, calling deploy to install this version.\n";
	105	$self->deploy();
	106	return 1;
	107	}
	108
	109	my $file = $self->ddl_filename(
	110	$self->storage->sqlt_type,
	111	$self->upgrade_directory,
42416a0b	112	$self->schema_version
c9d2e0a2	113	);
	114	if(!$file)
	115	{
	116	# No upgrade path between these two versions
	117	return 1;
	118	}
	119
	120	$file = $self->ddl_filename(
	121	$self->storage->sqlt_type,
	122	$self->upgrade_directory,
42416a0b	123	$self->schema_version,
c9d2e0a2	124	$pversion,
c9d2e0a2	125	);
42416a0b	126	# $file =~ s/@{[ $self->schema_version ]}/"${pversion}-" . $self->schema_version/e;
c9d2e0a2	127	if(!-f $file)
	128	{
	129	warn "Upgrade not possible, no upgrade file found ($file)\n";
	130	return;
	131	}
	132
	133	my $fh;
	134	open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
f925f7cb	135	my @data = split(/[;\n]/, join('', <$fh>));
c9d2e0a2	136	close($fh);
	137	@data = grep { $_ && $_ !~ /^-- / } @data;
	138	@data = grep { $_ !~ /^(BEGIN TRANACTION\|COMMIT)/m } @data;
	139
	140	$self->_filedata(\@data);
	141
	142	## Don't do this yet, do only on command?
	143	## If we do this later, where does the Version table get updated??
42416a0b	144	warn "Versions out of sync. This is " . $self->schema_version .
c9d2e0a2	145	", your database contains version $pversion, please call upgrade on your Schema.\n";
42416a0b	146	# $self->upgrade($pversion, $self->schema_version);
c9d2e0a2	147	}
c9d2e0a2	148
e6129e56	149	sub get_db_version
	150	{
	151	my ($self, $rs) = @_;
	152
	153	my $vtable = $self->{vschema}->resultset('Table');
	154	my $psearch = $vtable->search(undef,
	155	{ select => [
	156	{ 'max' => 'Installed' },
	157	],
	158	as => ['maxinstall'],
	159	})->first;
f925f7cb	160	my $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
e6129e56	161	})->first;
	162	$pversion = $pversion->Version if($pversion);
	163	return $pversion;
	164	}
	165
a2800991	166	sub _source_exists
c9d2e0a2	167	{
	168	my ($self, $rs) = @_;
	169
	170	my $c = eval {
	171	$rs->search({ 1, 0 })->count;
	172	};
	173	return 0 if $@ \|\| !defined $c;
	174
	175	return 1;
	176	}
	177
	178	sub backup
	179	{
	180	my ($self) = @_;
	181	## Make each ::DBI::Foo do this
8795fefb	182	$self->storage->backup($self->backup_directory());
c9d2e0a2	183	}
	184
	185	sub upgrade
	186	{
	187	my ($self) = @_;
	188
f925f7cb	189	$self->backup() if($self->do_backup);
	190
	191	$self->txn_do(sub {
	192	$self->do_upgrade();
	193	});
e6129e56	194
	195	my $vtable = $self->{vschema}->resultset('Table');
	196	$vtable->create({ Version => $self->schema_version,
	197	Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
	198	});
f925f7cb	199
e6129e56	200	}
c9d2e0a2	201
e6129e56	202	sub do_upgrade
	203	{
	204	my ($self) = @_;
	205
	206	## overridable sub, per default just run all the commands.
c9d2e0a2	207	$self->run_upgrade(qr/create/i);
	208	$self->run_upgrade(qr/alter table .*? add/i);
	209	$self->run_upgrade(qr/alter table .*? (?!drop)/i);
	210	$self->run_upgrade(qr/alter table .*? drop/i);
	211	$self->run_upgrade(qr/drop/i);
c9d2e0a2	212	}
c9d2e0a2	213
c9d2e0a2	214	sub run_upgrade
	215	{
	216	my ($self, $stm) = @_;
	217	# print "Reg: $stm\n";
	218	my @statements = grep { $_ =~ $stm } @{$self->_filedata};
	219	# print "Statements: ", join("\n", @statements), "\n";
	220	$self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
	221
	222	for (@statements)
	223	{
70f39278	224	$self->storage->debugobj->query_start($_) if $self->storage->debug;
c9d2e0a2	225	$self->storage->dbh->do($_) or warn "SQL was:\n $_";
70f39278	226	$self->storage->debugobj->query_end($_) if $self->storage->debug;
c9d2e0a2	227	}
	228
	229	return 1;
	230	}
	231
e2c0df8e	232	1;
e2c0df8e	233
c9d2e0a2	234	=head1 NAME
c9d2e0a2	235
7d9fbacf	236	DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
c9d2e0a2	237
	238	=head1 SYNOPSIS
	239
	240	package Library::Schema;
	241	use base qw/DBIx::Class::Schema/;
	242	# load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
	243	__PACKAGE__->load_classes(qw/CD Book DVD/);
	244
	245	__PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
	246	__PACKAGE__->upgrade_directory('/path/to/upgrades/');
8795fefb	247	__PACKAGE__->backup_directory('/path/to/backups/');
c9d2e0a2	248
	249	sub backup
	250	{
	251	my ($self) = @_;
	252	# my special backup process
	253	}
	254
	255	sub upgrade
	256	{
	257	my ($self) = @_;
	258
	259	## overridable sub, per default just runs all the commands.
	260
	261	$self->run_upgrade(qr/create/i);
	262	$self->run_upgrade(qr/alter table .*? add/i);
	263	$self->run_upgrade(qr/alter table .*? (?!drop)/i);
	264	$self->run_upgrade(qr/alter table .*? drop/i);
	265	$self->run_upgrade(qr/drop/i);
	266	$self->run_upgrade(qr//i);
	267	}
	268
	269	=head1 DESCRIPTION
	270
	271	This module is a component designed to extend L<DBIx::Class::Schema>
	272	classes, to enable them to upgrade to newer schema layouts. To use this
	273	module, you need to have called C<create_ddl_dir> on your Schema to
	274	create your upgrade files to include with your delivery.
	275
	276	A table called I<SchemaVersions> is created and maintained by the
	277	module. This contains two fields, 'Version' and 'Installed', which
	278	contain each VERSION of your Schema, and the date+time it was installed.
	279
	280	If you would like to influence which levels of version change need
	281	upgrades in your Schema, you can override the method C<ddl_filename>
	282	in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
	283	path between the two versions supplied. By default, every change in
	284	your VERSION is regarded as needing an upgrade.
	285
8795fefb	286	The actual upgrade is called manually by calling C<upgrade> on your
	287	schema object. Code is run at connect time to determine whether an
	288	upgrade is needed, if so, a warning "Versions out of sync" is
	289	produced.
	290
c9d2e0a2	291	NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
	292	returns SQL statements that SQLite does not support.
	293
	294
	295	=head1 METHODS
	296
	297	=head2 backup
	298
	299	This is an overwritable method which is called just before the upgrade, to
	300	allow you to make a backup of the database. Per default this method attempts
	301	to call C<< $self->storage->backup >>, to run the standard backup on each
	302	database type.
	303
e6129e56	304	This method should return the name of the backup file, if appropriate..
c9d2e0a2	305
	306	=head2 upgrade
	307
e6129e56	308	This is the main upgrade method which calls the overridable do_upgrade and
	309	also handles the backups and updating of the SchemaVersion table.
	310
	311	=head2 do_upgrade
	312
c9d2e0a2	313	This is an overwritable method used to run your upgrade. The freeform method
	314	allows you to run your upgrade any way you please, you can call C<run_upgrade>
	315	any number of times to run the actual SQL commands, and in between you can
	316	sandwich your data upgrading. For example, first run all the B<CREATE>
	317	commands, then migrate your data from old to new tables/formats, then
	318	issue the DROP commands when you are finished.
	319
	320	=head2 run_upgrade
	321
	322	$self->run_upgrade(qr/create/i);
	323
	324	Runs a set of SQL statements matching a passed in regular expression. The
	325	idea is that this method can be called any number of times from your
	326	C<upgrade> method, running whichever commands you specify via the
	327	regex in the parameter.
	328
8795fefb	329	=head2 upgrade_directory
	330
	331	Use this to set the directory your upgrade files are stored in.
	332
	333	=head2 backup_directory
	334
	335	Use this to set the directory you want your backups stored in.
	336
42416a0b	337	=head2 schema_version
	338
	339	Returns the current schema class' $VERSION; does -not- use $schema->VERSION
	340	since that varies in results depending on if version.pm is installed, and if
	341	so the perl or XS versions. If you want this to change, bug the version.pm
	342	author to make vpp and vxs behave the same.
	343
c9d2e0a2	344	=head1 AUTHOR
	345
	346	Jess Robinson <castaway@desert-island.demon.co.uk>