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

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

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

  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.

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.

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