Part one of the sybase work by Caelum (mostly reviewed)
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Schema / Versioned.pm
1 package # Hide from PAUSE
2   DBIx::Class::Version::Table;
3 use base 'DBIx::Class';
4 use strict;
5 use warnings;
6
7 __PACKAGE__->load_components(qw/ Core/);
8 __PACKAGE__->table('dbix_class_schema_versions');
9
10 __PACKAGE__->add_columns
11     ( 'version' => {
12         'data_type' => 'VARCHAR',
13         'is_auto_increment' => 0,
14         'default_value' => undef,
15         'is_foreign_key' => 0,
16         'name' => 'version',
17         'is_nullable' => 0,
18         'size' => '10'
19         },
20       'installed' => {
21           'data_type' => 'VARCHAR',
22           'is_auto_increment' => 0,
23           'default_value' => undef,
24           'is_foreign_key' => 0,
25           'name' => 'installed',
26           'is_nullable' => 0,
27           'size' => '20'
28           },
29       );
30 __PACKAGE__->set_primary_key('version');
31
32 package # Hide from PAUSE
33   DBIx::Class::Version::TableCompat;
34 use base 'DBIx::Class';
35 __PACKAGE__->load_components(qw/ Core/);
36 __PACKAGE__->table('SchemaVersions');
37
38 __PACKAGE__->add_columns
39     ( 'Version' => {
40         'data_type' => 'VARCHAR',
41         },
42       'Installed' => {
43           'data_type' => 'VARCHAR',
44           },
45       );
46 __PACKAGE__->set_primary_key('Version');
47
48 package # Hide from PAUSE
49   DBIx::Class::Version;
50 use base 'DBIx::Class::Schema';
51 use strict;
52 use warnings;
53
54 __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
55
56 package # Hide from PAUSE
57   DBIx::Class::VersionCompat;
58 use base 'DBIx::Class::Schema';
59 use strict;
60 use warnings;
61
62 __PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
63
64
65 # ---------------------------------------------------------------------------
66
67 =head1 NAME
68
69 DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
70
71 =head1 SYNOPSIS
72
73   package MyApp::Schema;
74   use base qw/DBIx::Class::Schema/;
75
76   our $VERSION = 0.001;
77
78   # load MyApp::Schema::CD, MyApp::Schema::Book, MyApp::Schema::DVD
79   __PACKAGE__->load_classes(qw/CD Book DVD/);
80
81   __PACKAGE__->load_components(qw/Schema::Versioned/);
82   __PACKAGE__->upgrade_directory('/path/to/upgrades/');
83
84
85 =head1 DESCRIPTION
86
87 This module provides methods to apply DDL changes to your database using SQL
88 diff files. Normally these diff files would be created using
89 L<DBIx::Class::Schema/create_ddl_dir>.
90
91 A table called I<dbix_class_schema_versions> is created and maintained by the
92 module. This is used to determine which version your database is currently at.
93 Similarly the $VERSION in your DBIC schema class is used to determine the
94 current DBIC schema version.
95
96 The upgrade is initiated manually by calling C<upgrade> on your schema object,
97 this will attempt to upgrade the database from its current version to the current
98 schema version using a diff from your I<upgrade_directory>. If a suitable diff is
99 not found then no upgrade is possible.
100
101 NB: At the moment, only SQLite and MySQL are supported. This is due to
102 spotty behaviour in the SQL::Translator producers, please help us by
103 enhancing them. Ask on the mailing list or IRC channel for details (community details
104 in L<DBIx::Class>).
105
106 =head1 GETTING STARTED
107
108 Firstly you need to setup your schema class as per the L</SYNOPSIS>, make sure
109 you have specified an upgrade_directory and an initial $VERSION.
110
111 Then you'll need two scripts, one to create DDL files and diffs and another to perform
112 upgrades. Your creation script might look like a bit like this:
113
114   use strict;
115   use Pod::Usage;
116   use Getopt::Long;
117   use MyApp::Schema;
118
119   my ( $preversion, $help ); 
120   GetOptions(
121     'p|preversion:s'  => \$preversion,
122   ) or die pod2usage;
123
124   my $schema = MyApp::Schema->connect(
125     $dsn,
126     $user,
127     $password,
128   );
129   my $sql_dir = './sql';
130   my $version = $schema->schema_version();
131   $schema->create_ddl_dir( 'MySQL', $version, $sql_dir, $preversion );
132
133 Then your upgrade script might look like so:
134
135   use strict;
136   use MyApp::Schema;
137
138   my $schema = MyApp::Schema->connect(
139     $dsn,
140     $user,
141     $password,
142   );
143
144   if (!$schema->get_db_version()) {
145     # schema is unversioned
146     $schema->deploy();
147   } else {
148     $schema->upgrade();
149   }
150
151 The script above assumes that if the database is unversioned then it is empty
152 and we can safely deploy the DDL to it. However things are not always so simple.
153
154 if you want to initialise a pre-existing database where the DDL is not the same
155 as the DDL for your current schema version then you will need a diff which 
156 converts the database's DDL to the current DDL. The best way to do this is
157 to get a dump of the database schema (without data) and save that in your
158 SQL directory as version 0.000 (the filename must be as with
159 L<DBIx::Class::Schema/ddl_filename>) then create a diff using your create DDL 
160 script given above from version 0.000 to the current version. Then hand check
161 and if necessary edit the resulting diff to ensure that it will apply. Once you have 
162 done all that you can do this:
163
164   if (!$schema->get_db_version()) {
165     # schema is unversioned
166     $schema->install("0.000");
167   }
168
169   # this will now apply the 0.000 to current version diff
170   $schema->upgrade();
171
172 In the case of an unversioned database the above code will create the
173 dbix_class_schema_versions table and write version 0.000 to it, then 
174 upgrade will then apply the diff we talked about creating in the previous paragraph
175 and then you're good to go.
176
177 =cut
178
179 package DBIx::Class::Schema::Versioned;
180
181 use strict;
182 use warnings;
183 use base 'DBIx::Class';
184
185 use Carp::Clan qw/^DBIx::Class/;
186 use POSIX 'strftime';
187
188 __PACKAGE__->mk_classdata('_filedata');
189 __PACKAGE__->mk_classdata('upgrade_directory');
190 __PACKAGE__->mk_classdata('backup_directory');
191 __PACKAGE__->mk_classdata('do_backup');
192 __PACKAGE__->mk_classdata('do_diff_on_init');
193
194
195 =head1 METHODS
196
197 =head2 upgrade_directory
198
199 Use this to set the directory your upgrade files are stored in.
200
201 =head2 backup_directory
202
203 Use this to set the directory you want your backups stored in (note that backups
204 are disabled by default).
205
206 =cut
207
208 =head2 install
209
210 =over 4
211
212 =item Arguments: $db_version
213
214 =back
215
216 Call this to initialise a previously unversioned database. The table 'dbix_class_schema_versions' will be created which will be used to store the database version.
217
218 Takes one argument which should be the version that the database is currently at. Defaults to the return value of L</schema_version>.
219
220 See L</getting_started> for more details.
221
222 =cut
223
224 sub install
225 {
226   my ($self, $new_version) = @_;
227
228   # must be called on a fresh database
229   if ($self->get_db_version()) {
230     carp 'Install not possible as versions table already exists in database';
231   }
232
233   # default to current version if none passed
234   $new_version ||= $self->schema_version();
235
236   if ($new_version) {
237     # create versions table and version row
238     $self->{vschema}->deploy;
239     $self->_set_db_version({ version => $new_version });
240   }
241 }
242
243 =head2 deploy
244
245 Same as L<DBIx::Class::Schema/deploy> but also calls C<install>.
246
247 =cut
248
249 sub deploy {
250   my $self = shift;
251   $self->next::method(@_);
252   $self->install();
253 }
254
255 =head2 create_upgrade_path
256
257 =over 4
258
259 =item Arguments: { upgrade_file => $file }
260
261 =back
262
263 Virtual method that should be overriden to create an upgrade file. 
264 This is useful in the case of upgrading across multiple versions 
265 to concatenate several files to create one upgrade file.
266
267 You'll probably want the db_version retrieved via $self->get_db_version
268 and the schema_version which is retrieved via $self->schema_version 
269
270 =cut
271
272 sub create_upgrade_path {
273         ## override this method
274 }
275
276 =head2 upgrade
277
278 Call this to attempt to upgrade your database from the version it is at to the version
279 this DBIC schema is at. If they are the same it does nothing.
280
281 It requires an SQL diff file to exist in you I<upgrade_directory>, normally you will
282 have created this using L<DBIx::Class::Schema/create_ddl_dir>.
283
284 If successful the dbix_class_schema_versions table is updated with the current
285 DBIC schema version.
286
287 =cut
288
289 sub upgrade
290 {
291   my ($self) = @_;
292   my $db_version = $self->get_db_version();
293
294   # db unversioned
295   unless ($db_version) {
296     carp 'Upgrade not possible as database is unversioned. Please call install first.';
297     return;
298   }
299
300   # db and schema at same version. do nothing
301   if ($db_version eq $self->schema_version) {
302     carp "Upgrade not necessary\n";
303     return;
304   }
305
306   # strangely the first time this is called can
307   # differ to subsequent times. so we call it 
308   # here to be sure.
309   # XXX - just fix it
310   $self->storage->sqlt_type;
311
312   my $upgrade_file = $self->ddl_filename(
313                                          $self->storage->sqlt_type,
314                                          $self->schema_version,
315                                          $self->upgrade_directory,
316                                          $db_version,
317                                         );
318
319   $self->create_upgrade_path({ upgrade_file => $upgrade_file });
320
321   unless (-f $upgrade_file) {
322     carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
323     return;
324   }
325
326   carp "\nDB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
327
328   # backup if necessary then apply upgrade
329   $self->_filedata($self->_read_sql_file($upgrade_file));
330   $self->backup() if($self->do_backup);
331   $self->txn_do(sub { $self->do_upgrade() });
332
333   # set row in dbix_class_schema_versions table
334   $self->_set_db_version;
335 }
336
337 =head2 do_upgrade
338
339 This is an overwritable method used to run your upgrade. The freeform method
340 allows you to run your upgrade any way you please, you can call C<run_upgrade>
341 any number of times to run the actual SQL commands, and in between you can
342 sandwich your data upgrading. For example, first run all the B<CREATE>
343 commands, then migrate your data from old to new tables/formats, then 
344 issue the DROP commands when you are finished. Will run the whole file as it is by default.
345
346 =cut
347
348 sub do_upgrade
349 {
350   my ($self) = @_;
351
352   # just run all the commands (including inserts) in order                                                        
353   $self->run_upgrade(qr/.*?/);
354 }
355
356 =head2 run_upgrade
357
358  $self->run_upgrade(qr/create/i);
359
360 Runs a set of SQL statements matching a passed in regular expression. The
361 idea is that this method can be called any number of times from your
362 C<do_upgrade> method, running whichever commands you specify via the
363 regex in the parameter. Probably won't work unless called from the overridable
364 do_upgrade method.
365
366 =cut
367
368 sub run_upgrade
369 {
370     my ($self, $stm) = @_;
371
372     return unless ($self->_filedata);
373     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
374     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
375
376     for (@statements)
377     {      
378         $self->storage->debugobj->query_start($_) if $self->storage->debug;
379         $self->apply_statement($_);
380         $self->storage->debugobj->query_end($_) if $self->storage->debug;
381     }
382
383     return 1;
384 }
385
386 =head2 apply_statement
387
388 Takes an SQL statement and runs it. Override this if you want to handle errors
389 differently.
390
391 =cut
392
393 sub apply_statement {
394     my ($self, $statement) = @_;
395
396     $self->storage->dbh->do($_) or carp "SQL was:\n $_";
397 }
398
399 =head2 get_db_version
400
401 Returns the version that your database is currently at. This is determined by the values in the
402 dbix_class_schema_versions table that C<upgrade> and C<install> write to.
403
404 =cut
405
406 sub get_db_version
407 {
408     my ($self, $rs) = @_;
409
410     my $vtable = $self->{vschema}->resultset('Table');
411     my $version = 0;
412     eval {
413       my $stamp = $vtable->get_column('installed')->max;
414       $version = $vtable->search({ installed => $stamp })->first->version;
415     };
416     return $version;
417 }
418
419 =head2 schema_version
420
421 Returns the current schema class' $VERSION
422
423 =cut
424
425 =head2 backup
426
427 This is an overwritable method which is called just before the upgrade, to
428 allow you to make a backup of the database. Per default this method attempts
429 to call C<< $self->storage->backup >>, to run the standard backup on each
430 database type. 
431
432 This method should return the name of the backup file, if appropriate..
433
434 This method is disabled by default. Set $schema->do_backup(1) to enable it.
435
436 =cut
437
438 sub backup
439 {
440     my ($self) = @_;
441     ## Make each ::DBI::Foo do this
442     $self->storage->backup($self->backup_directory());
443 }
444
445 =head2 connection
446
447 Overloaded method. This checks the DBIC schema version against the DB version and
448 warns if they are not the same or if the DB is unversioned. It also provides
449 compatibility between the old versions table (SchemaVersions) and the new one
450 (dbix_class_schema_versions).
451
452 To avoid the checks on connect, set the env var DBIC_NO_VERSION_CHECK or alternatively you can set the ignore_version attr in the forth argument like so:
453
454   my $schema = MyApp::Schema->connect(
455     $dsn,
456     $user,
457     $password,
458     { ignore_version => 1 },
459   );
460
461 =cut
462
463 sub connection {
464   my $self = shift;
465   $self->next::method(@_);
466   $self->_on_connect($_[3]);
467   return $self;
468 }
469
470 sub _on_connect
471 {
472   my ($self, $args) = @_;
473
474   $args = {} unless $args;
475   $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
476   my $vtable = $self->{vschema}->resultset('Table');
477
478   # check for legacy versions table and move to new if exists
479   my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
480   unless ($self->_source_exists($vtable)) {
481     my $vtable_compat = $vschema_compat->resultset('TableCompat');
482     if ($self->_source_exists($vtable_compat)) {
483       $self->{vschema}->deploy;
484       map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
485       $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
486     }
487   }
488
489   # useful when connecting from scripts etc
490   return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
491   my $pversion = $self->get_db_version();
492
493   if($pversion eq $self->schema_version)
494     {
495 #         carp "This version is already installed\n";
496         return 1;
497     }
498
499   if(!$pversion)
500     {
501         carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
502         return 1;
503     }
504
505   carp "Versions out of sync. This is " . $self->schema_version . 
506     ", your database contains version $pversion, please call upgrade on your Schema.\n";
507 }
508
509 # is this just a waste of time? if not then merge with DBI.pm
510 sub _create_db_to_schema_diff {
511   my $self = shift;
512
513   my %driver_to_db_map = (
514                           'mysql' => 'MySQL'
515                          );
516
517   my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
518   unless ($db) {
519     print "Sorry, this is an unsupported DB\n";
520     return;
521   }
522
523   $self->throw_exception($self->storage->_sqlt_version_error)
524     if (not $self->storage->_sqlt_version_ok);
525
526   my $db_tr = SQL::Translator->new({
527                                     add_drop_table => 1,
528                                     parser => 'DBI',
529                                     parser_args => { dbh => $self->storage->dbh }
530                                    });
531
532   $db_tr->producer($db);
533   my $dbic_tr = SQL::Translator->new;
534   $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
535   $dbic_tr->data($self);
536   $dbic_tr->producer($db);
537
538   $db_tr->schema->name('db_schema');
539   $dbic_tr->schema->name('dbic_schema');
540
541   # is this really necessary?
542   foreach my $tr ($db_tr, $dbic_tr) {
543     my $data = $tr->data;
544     $tr->parser->($tr, $$data);
545   }
546
547   my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db, 
548                                                 $dbic_tr->schema, $db,
549                                                 { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
550
551   my $filename = $self->ddl_filename(
552                                          $db,
553                                          $self->schema_version,
554                                          $self->upgrade_directory,
555                                          'PRE',
556                                     );
557   my $file;
558   if(!open($file, ">$filename"))
559     {
560       $self->throw_exception("Can't open $filename for writing ($!)");
561       next;
562     }
563   print $file $diff;
564   close($file);
565
566   carp "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n";
567 }
568
569
570 sub _set_db_version {
571   my $self = shift;
572   my ($params) = @_;
573   $params ||= {};
574
575   my $version = $params->{version} ? $params->{version} : $self->schema_version;
576   my $vtable = $self->{vschema}->resultset('Table');
577   $vtable->create({ version => $version,
578                       installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
579                       });
580
581 }
582
583 sub _read_sql_file {
584   my $self = shift;
585   my $file = shift || return;
586
587   my $fh;
588   open $fh, "<$file" or carp("Can't open upgrade file, $file ($!)");
589   my @data = split(/\n/, join('', <$fh>));
590   @data = grep(!/^--/, @data);
591   @data = split(/;/, join('', @data));
592   close($fh);
593   @data = grep { $_ && $_ !~ /^-- / } @data;
594   @data = grep { $_ !~ /^(BEGIN|BEGIN TRANSACTION|COMMIT)/m } @data;
595   return \@data;
596 }
597
598 sub _source_exists
599 {
600     my ($self, $rs) = @_;
601
602     my $c = eval {
603         $rs->search({ 1, 0 })->count;
604     };
605     return 0 if $@ || !defined $c;
606
607     return 1;
608 }
609
610 1;
611
612
613 =head1 AUTHORS
614
615 Jess Robinson <castaway@desert-island.me.uk>
616 Luke Saunders <luke@shadowcatsystems.co.uk>
617
618 =head1 LICENSE
619
620 You may distribute this code under the same terms as Perl itself.