[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;
}

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