[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 connection {
  my $self = shift;
  $self->next::method(@_);
  $self->_on_connect;
  return $self;
}

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

    if(!$self->_source_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 _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) = @_;

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

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