[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;
# use DBIx::Class::Version;

__PACKAGE__->mk_classdata('_filedata');
__PACKAGE__->mk_classdata('upgrade_directory');

sub on_connect
{
    my ($self) = @_;
#    print "on_connect\n";
    my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
    my $vtable = $vschema->resultset('Table');
    my $pversion;
    if(!$self->exists($vtable))
    {
#        print "deploying.. \n";
        $vschema->storage->debug(1);
#        print "Debugging is: ", $vschema->storage->debug, "\n";
        $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;
    }

    
    $vtable->create({ Version => $self->VERSION,
                      Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
                      });

    if(!$pversion)
    {
        warn "No previous version found, skipping upgrade\n";
        return 1;
    }

#    $self->create_upgrades($self->upgrade_directoy, $pversion, $self->VERSION);

    my $file = $self->ddl_filename($self->upgrade_directory,
                                   $self->storage->sqlt_type,
                                   $self->VERSION
                                   );
    if(!$file)
    {
        # No upgrade path between these two versions
        return 1;
    }

    $file =~ s/@{[ $self->VERSION ]}/"${pversion}-" . $self->VERSION/e;
    if(!-f $file)
    {
        warn "Upgrade not possible, no upgrade file found ($file)\n";
        return;
    }
#    print "Found Upgrade file: $file\n";
    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;
#    print "Commands: ", join("\n", @data), "\n";
    $self->_filedata(\@data);

    $self->backup();
    $self->upgrade($pversion, $self->VERSION);

}

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

    eval {
        $rs->search({ 1, 0 })->count;
    };
    return 0 if $@;

    return 1;
}

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

sub 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);
    $self->run_upgrade(qr//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->debugfh->print("$_\n") if $self->storage->debug;
#        print "Running \n>>$_<<\n";
        $self->storage->dbh->do($_) or warn "SQL was:\n $_";
    }

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

  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.

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

=head1 AUTHOR

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