[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 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->VERSION)
    {
        warn "This version is already installed\n";
        return 1;
    }

## use IC::DT?    

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

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

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