[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');

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

sub _on_connect
{
    my ($self) = @_;
    my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
    my $vtable = $vschema->resultset('Table');
    my $pversion;

    if(!$self->exists($vtable))
    {
#        $vschema->storage->debug(1);
        $vschema->storage->ensure_connected();
        $vschema->deploy();
        $pversion = 0;
    }
    else
    {
        my $psearch = $vtable->search(undef, 
                                      { select => [
                                                   { 'max' => 'Installed' },
                                                   ],
                                            as => ['maxinstall'],
                                        })->first;
        $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
                                  })->first;
        $pversion = $pversion->Version if($pversion);
    }
#    warn("Previous version: $pversion\n");
    if($pversion eq $self->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 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) = @_;

    ## overridable sub, per default just run all the commands.

    $self->backup();

    $self->run_upgrade(qr/create/i);
    $self->run_upgrade(qr/alter table .*? add/i);
    $self->run_upgrade(qr/alter table .*? (?!drop)/i);
    $self->run_upgrade(qr/alter table .*? drop/i);
    $self->run_upgrade(qr/drop/i);
#    $self->run_upgrade(qr//i);

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


sub run_upgrade
{
    my ($self, $stm) = @_;
#    print "Reg: $stm\n";
    my @statements = grep { $_ =~ $stm } @{$self->_filedata};
#    print "Statements: ", join("\n", @statements), "\n";
    $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);

    for (@statements)
    {
        $self->storage->debugfh->print("$_\n") if $self->storage->debug;
#        print "Running \n>>$_<<\n";
        $self->storage->dbh->do($_) or warn "SQL was:\n $_";
    }

    return 1;
}

1;

=head1 NAME

DBIx::Class::Versioning - DBIx::Class::Schema plugin for Schema upgrades

=head1 SYNOPSIS

  package Library::Schema;
  use base qw/DBIx::Class::Schema/;   
  # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
  __PACKAGE__->load_classes(qw/CD Book DVD/);

  __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
  __PACKAGE__->upgrade_directory('/path/to/upgrades/');
  __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.

C<backup> is called from C<upgrade>, make sure you call it, if you write your
own <upgrade> method.

=head2 upgrade

This is an overwritable method used to run your upgrade. The freeform method
allows you to run your upgrade any way you please, you can call C<run_upgrade>
any number of times to run the actual SQL commands, and in between you can
sandwich your data upgrading. For example, first run all the B<CREATE>
commands, then migrate your data from old to new tables/formats, then 
issue the DROP commands when you are finished.

=head2 run_upgrade

 $self->run_upgrade(qr/create/i);

Runs a set of SQL statements matching a passed in regular expression. The
idea is that this method can be called any number of times from your
C<upgrade> method, running whichever commands you specify via the
regex in the parameter.

=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');
c9d2e0a2	51
42416a0b	52	sub schema_version {
	53	my ($self) = @_;
	54	my $class = ref($self)\|\|$self;
	55	my $version;
	56	{
	57	no strict 'refs';
	58	$version = ${"${class}::VERSION"};
	59	}
	60	return $version;
	61	}
	62
737416a4	63	sub _on_connect
c9d2e0a2	64	{
	65	my ($self) = @_;
	66	my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
	67	my $vtable = $vschema->resultset('Table');
	68	my $pversion;
e2c0df8e	69
c9d2e0a2	70	if(!$self->exists($vtable))
	71	{
	72	# $vschema->storage->debug(1);
	73	$vschema->storage->ensure_connected();
	74	$vschema->deploy();
	75	$pversion = 0;
	76	}
	77	else
	78	{
	79	my $psearch = $vtable->search(undef,
	80	{ select => [
	81	{ 'max' => 'Installed' },
	82	],
	83	as => ['maxinstall'],
	84	})->first;
	85	$pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
	86	})->first;
	87	$pversion = $pversion->Version if($pversion);
	88	}
	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 ($!)");
	135	my @data = split(/;\n/, join('', <$fh>));
	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	}
	148
	149	sub exists
	150	{
	151	my ($self, $rs) = @_;
	152
	153	my $c = eval {
	154	$rs->search({ 1, 0 })->count;
	155	};
	156	return 0 if $@ \|\| !defined $c;
	157
	158	return 1;
	159	}
	160
	161	sub backup
	162	{
	163	my ($self) = @_;
	164	## Make each ::DBI::Foo do this
8795fefb	165	$self->storage->backup($self->backup_directory());
c9d2e0a2	166	}
	167
	168	sub upgrade
	169	{
	170	my ($self) = @_;
	171
	172	## overridable sub, per default just run all the commands.
	173
	174	$self->backup();
	175
	176	$self->run_upgrade(qr/create/i);
	177	$self->run_upgrade(qr/alter table .*? add/i);
	178	$self->run_upgrade(qr/alter table .*? (?!drop)/i);
	179	$self->run_upgrade(qr/alter table .*? drop/i);
	180	$self->run_upgrade(qr/drop/i);
	181	# $self->run_upgrade(qr//i);
	182
	183	my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
	184	my $vtable = $vschema->resultset('Table');
42416a0b	185	$vtable->create({ Version => $self->schema_version,
c9d2e0a2	186	Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
	187	});
	188	}
	189
	190
	191	sub run_upgrade
	192	{
	193	my ($self, $stm) = @_;
	194	# print "Reg: $stm\n";
	195	my @statements = grep { $_ =~ $stm } @{$self->_filedata};
	196	# print "Statements: ", join("\n", @statements), "\n";
	197	$self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
	198
	199	for (@statements)
	200	{
	201	$self->storage->debugfh->print("$_\n") if $self->storage->debug;
	202	# print "Running \n>>$_<<\n";
	203	$self->storage->dbh->do($_) or warn "SQL was:\n $_";
	204	}
	205
	206	return 1;
	207	}
	208
e2c0df8e	209	1;
e2c0df8e	210
c9d2e0a2	211	=head1 NAME
	212
	213	DBIx::Class::Versioning - DBIx::Class::Schema plugin for Schema upgrades
	214
	215	=head1 SYNOPSIS
	216
	217	package Library::Schema;
	218	use base qw/DBIx::Class::Schema/;
	219	# load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
	220	__PACKAGE__->load_classes(qw/CD Book DVD/);
	221
	222	__PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
	223	__PACKAGE__->upgrade_directory('/path/to/upgrades/');
8795fefb	224	__PACKAGE__->backup_directory('/path/to/backups/');
c9d2e0a2	225
	226	sub backup
	227	{
	228	my ($self) = @_;
	229	# my special backup process
	230	}
	231
	232	sub upgrade
	233	{
	234	my ($self) = @_;
	235
	236	## overridable sub, per default just runs all the commands.
	237
	238	$self->run_upgrade(qr/create/i);
	239	$self->run_upgrade(qr/alter table .*? add/i);
	240	$self->run_upgrade(qr/alter table .*? (?!drop)/i);
	241	$self->run_upgrade(qr/alter table .*? drop/i);
	242	$self->run_upgrade(qr/drop/i);
	243	$self->run_upgrade(qr//i);
	244	}
	245
	246	=head1 DESCRIPTION
	247
	248	This module is a component designed to extend L<DBIx::Class::Schema>
	249	classes, to enable them to upgrade to newer schema layouts. To use this
	250	module, you need to have called C<create_ddl_dir> on your Schema to
	251	create your upgrade files to include with your delivery.
	252
	253	A table called I<SchemaVersions> is created and maintained by the
	254	module. This contains two fields, 'Version' and 'Installed', which
	255	contain each VERSION of your Schema, and the date+time it was installed.
	256
	257	If you would like to influence which levels of version change need
	258	upgrades in your Schema, you can override the method C<ddl_filename>
	259	in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
	260	path between the two versions supplied. By default, every change in
	261	your VERSION is regarded as needing an upgrade.
	262
8795fefb	263	The actual upgrade is called manually by calling C<upgrade> on your
	264	schema object. Code is run at connect time to determine whether an
	265	upgrade is needed, if so, a warning "Versions out of sync" is
	266	produced.
	267
c9d2e0a2	268	NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
	269	returns SQL statements that SQLite does not support.
	270
	271
	272	=head1 METHODS
	273
	274	=head2 backup
	275
	276	This is an overwritable method which is called just before the upgrade, to
	277	allow you to make a backup of the database. Per default this method attempts
	278	to call C<< $self->storage->backup >>, to run the standard backup on each
	279	database type.
	280
	281	This method should return the name of the backup file, if appropriate.
	282
	283	C<backup> is called from C<upgrade>, make sure you call it, if you write your
	284	own <upgrade> method.
	285
	286	=head2 upgrade
	287
	288	This is an overwritable method used to run your upgrade. The freeform method
	289	allows you to run your upgrade any way you please, you can call C<run_upgrade>
	290	any number of times to run the actual SQL commands, and in between you can
	291	sandwich your data upgrading. For example, first run all the B<CREATE>
	292	commands, then migrate your data from old to new tables/formats, then
	293	issue the DROP commands when you are finished.
	294
	295	=head2 run_upgrade
	296
	297	$self->run_upgrade(qr/create/i);
	298
	299	Runs a set of SQL statements matching a passed in regular expression. The
	300	idea is that this method can be called any number of times from your
	301	C<upgrade> method, running whichever commands you specify via the
	302	regex in the parameter.
	303
8795fefb	304	=head2 upgrade_directory
	305
	306	Use this to set the directory your upgrade files are stored in.
	307
	308	=head2 backup_directory
	309
	310	Use this to set the directory you want your backups stored in.
	311
42416a0b	312	=head2 schema_version
	313
	314	Returns the current schema class' $VERSION; does -not- use $schema->VERSION
	315	since that varies in results depending on if version.pm is installed, and if
	316	so the perl or XS versions. If you want this to change, bug the version.pm
	317	author to make vpp and vxs behave the same.
	318
c9d2e0a2	319	=head1 AUTHOR
	320
	321	Jess Robinson <castaway@desert-island.demon.co.uk>