Fix complex limits with subqueries in selectors
[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::Core';
4 use strict;
5 use warnings;
6
7 __PACKAGE__->table('dbix_class_schema_versions');
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 # Hide from PAUSE
32   DBIx::Class::Version::TableCompat;
33 use base 'DBIx::Class::Core';
34 __PACKAGE__->table('SchemaVersions');
35
36 __PACKAGE__->add_columns
37     ( 'Version' => {
38         'data_type' => 'VARCHAR',
39         },
40       'Installed' => {
41           'data_type' => 'VARCHAR',
42           },
43       );
44 __PACKAGE__->set_primary_key('Version');
45
46 package # Hide from PAUSE
47   DBIx::Class::Version;
48 use base 'DBIx::Class::Schema';
49 use strict;
50 use warnings;
51
52 __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
53
54 package # Hide from PAUSE
55   DBIx::Class::VersionCompat;
56 use base 'DBIx::Class::Schema';
57 use strict;
58 use warnings;
59
60 __PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
61
62
63 # ---------------------------------------------------------------------------
64
65 =head1 NAME
66
67 DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
68
69 =head1 SYNOPSIS
70
71   package MyApp::Schema;
72   use base qw/DBIx::Class::Schema/;
73
74   our $VERSION = 0.001;
75
76   # load MyApp::Schema::CD, MyApp::Schema::Book, MyApp::Schema::DVD
77   __PACKAGE__->load_classes(qw/CD Book DVD/);
78
79   __PACKAGE__->load_components(qw/Schema::Versioned/);
80   __PACKAGE__->upgrade_directory('/path/to/upgrades/');
81
82
83 =head1 DESCRIPTION
84
85 This module provides methods to apply DDL changes to your database using SQL
86 diff files. Normally these diff files would be created using
87 L<DBIx::Class::Schema/create_ddl_dir>.
88
89 A table called I<dbix_class_schema_versions> is created and maintained by the
90 module. This is used to determine which version your database is currently at.
91 Similarly the $VERSION in your DBIC schema class is used to determine the
92 current DBIC schema version.
93
94 The upgrade is initiated manually by calling C<upgrade> on your schema object,
95 this will attempt to upgrade the database from its current version to the current
96 schema version using a diff from your I<upgrade_directory>. If a suitable diff is
97 not found then no upgrade is possible.
98
99 =head1 SEE ALSO
100
101 L<DBIx::Class::DeploymentHandler> is a much more powerful alternative to this
102 module.  Examples of things it can do that this module cannot do include
103
104 =over
105
106 =item *
107
108 Downgrades in addition to upgrades
109
110 =item *
111
112 Multiple sql files files per upgrade/downgrade/install
113
114 =item *
115
116 Perl scripts allowed for upgrade/downgrade/install
117
118 =item *
119
120 Just one set of files needed for upgrade, unlike this module where one might
121 need to generate C<factorial(scalar @versions)>
122
123 =back
124
125 =head1 GETTING STARTED
126
127 Firstly you need to setup your schema class as per the L</SYNOPSIS>, make sure
128 you have specified an upgrade_directory and an initial $VERSION.
129
130 Then you'll need two scripts, one to create DDL files and diffs and another to perform
131 upgrades. Your creation script might look like a bit like this:
132
133   use strict;
134   use Pod::Usage;
135   use Getopt::Long;
136   use MyApp::Schema;
137
138   my ( $preversion, $help );
139   GetOptions(
140     'p|preversion:s'  => \$preversion,
141   ) or die pod2usage;
142
143   my $schema = MyApp::Schema->connect(
144     $dsn,
145     $user,
146     $password,
147   );
148   my $sql_dir = './sql';
149   my $version = $schema->schema_version();
150   $schema->create_ddl_dir( 'MySQL', $version, $sql_dir, $preversion );
151
152 Then your upgrade script might look like so:
153
154   use strict;
155   use MyApp::Schema;
156
157   my $schema = MyApp::Schema->connect(
158     $dsn,
159     $user,
160     $password,
161   );
162
163   if (!$schema->get_db_version()) {
164     # schema is unversioned
165     $schema->deploy();
166   } else {
167     $schema->upgrade();
168   }
169
170 The script above assumes that if the database is unversioned then it is empty
171 and we can safely deploy the DDL to it. However things are not always so simple.
172
173 if you want to initialise a pre-existing database where the DDL is not the same
174 as the DDL for your current schema version then you will need a diff which
175 converts the database's DDL to the current DDL. The best way to do this is
176 to get a dump of the database schema (without data) and save that in your
177 SQL directory as version 0.000 (the filename must be as with
178 L<DBIx::Class::Schema/ddl_filename>) then create a diff using your create DDL
179 script given above from version 0.000 to the current version. Then hand check
180 and if necessary edit the resulting diff to ensure that it will apply. Once you have
181 done all that you can do this:
182
183   if (!$schema->get_db_version()) {
184     # schema is unversioned
185     $schema->install("0.000");
186   }
187
188   # this will now apply the 0.000 to current version diff
189   $schema->upgrade();
190
191 In the case of an unversioned database the above code will create the
192 dbix_class_schema_versions table and write version 0.000 to it, then
193 upgrade will then apply the diff we talked about creating in the previous paragraph
194 and then you're good to go.
195
196 =cut
197
198 package DBIx::Class::Schema::Versioned;
199
200 use strict;
201 use warnings;
202 use base 'DBIx::Class::Schema';
203
204 use DBIx::Class::Carp;
205 use Time::HiRes qw/gettimeofday/;
206 use Try::Tiny;
207 use namespace::clean;
208
209 __PACKAGE__->mk_classdata('_filedata');
210 __PACKAGE__->mk_classdata('upgrade_directory');
211 __PACKAGE__->mk_classdata('backup_directory');
212 __PACKAGE__->mk_classdata('do_backup');
213 __PACKAGE__->mk_classdata('do_diff_on_init');
214
215
216 =head1 METHODS
217
218 =head2 upgrade_directory
219
220 Use this to set the directory your upgrade files are stored in.
221
222 =head2 backup_directory
223
224 Use this to set the directory you want your backups stored in (note that backups
225 are disabled by default).
226
227 =cut
228
229 =head2 install
230
231 =over 4
232
233 =item Arguments: $db_version
234
235 =back
236
237 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.
238
239 Takes one argument which should be the version that the database is currently at. Defaults to the return value of L</schema_version>.
240
241 See L</getting_started> for more details.
242
243 =cut
244
245 sub install
246 {
247   my ($self, $new_version) = @_;
248
249   # must be called on a fresh database
250   if ($self->get_db_version()) {
251       $self->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
252   }
253
254   # default to current version if none passed
255   $new_version ||= $self->schema_version();
256
257   if ($new_version) {
258     # create versions table and version row
259     $self->{vschema}->deploy;
260     $self->_set_db_version({ version => $new_version });
261   }
262 }
263
264 =head2 deploy
265
266 Same as L<DBIx::Class::Schema/deploy> but also calls C<install>.
267
268 =cut
269
270 sub deploy {
271   my $self = shift;
272   $self->next::method(@_);
273   $self->install();
274 }
275
276 =head2 create_upgrade_path
277
278 =over 4
279
280 =item Arguments: { upgrade_file => $file }
281
282 =back
283
284 Virtual method that should be overridden to create an upgrade file.
285 This is useful in the case of upgrading across multiple versions
286 to concatenate several files to create one upgrade file.
287
288 You'll probably want the db_version retrieved via $self->get_db_version
289 and the schema_version which is retrieved via $self->schema_version
290
291 =cut
292
293 sub create_upgrade_path {
294   ## override this method
295 }
296
297 =head2 ordered_schema_versions
298
299 =over 4
300
301 =item Returns: a list of version numbers, ordered from lowest to highest
302
303 =back
304
305 Virtual method that should be overridden to return an ordered list
306 of schema versions. This is then used to produce a set of steps to
307 upgrade through to achieve the required schema version.
308
309 You may want the db_version retrieved via $self->get_db_version
310 and the schema_version which is retrieved via $self->schema_version
311
312 =cut
313
314 sub ordered_schema_versions {
315   ## override this method
316 }
317
318 =head2 upgrade
319
320 Call this to attempt to upgrade your database from the version it
321 is at to the version this DBIC schema is at. If they are the same
322 it does nothing.
323
324 It will call L</ordered_schema_versions> to retrieve an ordered
325 list of schema versions (if ordered_schema_versions returns nothing
326 then it is assumed you can do the upgrade as a single step). It
327 then iterates through the list of versions between the current db
328 version and the schema version applying one update at a time until
329 all relevant updates are applied.
330
331 The individual update steps are performed by using
332 L</upgrade_single_step>, which will apply the update and also
333 update the dbix_class_schema_versions table.
334
335 =cut
336
337 sub upgrade {
338     my ($self) = @_;
339     my $db_version = $self->get_db_version();
340
341     # db unversioned
342     unless ($db_version) {
343         carp 'Upgrade not possible as database is unversioned. Please call install first.';
344         return;
345     }
346
347     # db and schema at same version. do nothing
348     if ( $db_version eq $self->schema_version ) {
349         carp 'Upgrade not necessary';
350         return;
351     }
352
353     my @version_list = $self->ordered_schema_versions;
354
355     # if nothing returned then we preload with min/max
356     @version_list = ( $db_version, $self->schema_version )
357       unless ( scalar(@version_list) );
358
359     # catch the case of someone returning an arrayref
360     @version_list = @{ $version_list[0] }
361       if ( ref( $version_list[0] ) eq 'ARRAY' );
362
363     # remove all versions in list above the required version
364     while ( scalar(@version_list)
365         && ( $version_list[-1] ne $self->schema_version ) )
366     {
367         pop @version_list;
368     }
369
370     # remove all versions in list below the current version
371     while ( scalar(@version_list) && ( $version_list[0] ne $db_version ) ) {
372         shift @version_list;
373     }
374
375     # check we have an appropriate list of versions
376     if ( scalar(@version_list) < 2 ) {
377         die;
378     }
379
380     # do sets of upgrade
381     while ( scalar(@version_list) >= 2 ) {
382         $self->upgrade_single_step( $version_list[0], $version_list[1] );
383         shift @version_list;
384     }
385 }
386
387 =head2 upgrade_single_step
388
389 =over 4
390
391 =item Arguments: db_version - the version currently within the db
392
393 =item Arguments: target_version - the version to upgrade to
394
395 =back
396
397 Call this to attempt to upgrade your database from the
398 I<db_version> to the I<target_version>. If they are the same it
399 does nothing.
400
401 It requires an SQL diff file to exist in your I<upgrade_directory>,
402 normally you will have created this using L<DBIx::Class::Schema/create_ddl_dir>.
403
404 If successful the dbix_class_schema_versions table is updated with
405 the I<target_version>.
406
407 This method may be called repeatedly by the upgrade method to
408 upgrade through a series of updates.
409
410 =cut
411
412 sub upgrade_single_step
413 {
414   my ($self,
415       $db_version,
416       $target_version) = @_;
417
418   # db and schema at same version. do nothing
419   if ($db_version eq $target_version) {
420     carp 'Upgrade not necessary';
421     return;
422   }
423
424   # strangely the first time this is called can
425   # differ to subsequent times. so we call it
426   # here to be sure.
427   # XXX - just fix it
428   $self->storage->sqlt_type;
429
430   my $upgrade_file = $self->ddl_filename(
431                                          $self->storage->sqlt_type,
432                                          $target_version,
433                                          $self->upgrade_directory,
434                                          $db_version,
435                                         );
436
437   $self->create_upgrade_path({ upgrade_file => $upgrade_file });
438
439   unless (-f $upgrade_file) {
440     carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one";
441     return;
442   }
443
444   carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
445
446   # backup if necessary then apply upgrade
447   $self->_filedata($self->_read_sql_file($upgrade_file));
448   $self->backup() if($self->do_backup);
449   $self->txn_do(sub { $self->do_upgrade() });
450
451   # set row in dbix_class_schema_versions table
452   $self->_set_db_version({version => $target_version});
453 }
454
455 =head2 do_upgrade
456
457 This is an overwritable method used to run your upgrade. The freeform method
458 allows you to run your upgrade any way you please, you can call C<run_upgrade>
459 any number of times to run the actual SQL commands, and in between you can
460 sandwich your data upgrading. For example, first run all the B<CREATE>
461 commands, then migrate your data from old to new tables/formats, then
462 issue the DROP commands when you are finished. Will run the whole file as it is by default.
463
464 =cut
465
466 sub do_upgrade
467 {
468   my ($self) = @_;
469
470   # just run all the commands (including inserts) in order
471   $self->run_upgrade(qr/.*?/);
472 }
473
474 =head2 run_upgrade
475
476  $self->run_upgrade(qr/create/i);
477
478 Runs a set of SQL statements matching a passed in regular expression. The
479 idea is that this method can be called any number of times from your
480 C<do_upgrade> method, running whichever commands you specify via the
481 regex in the parameter. Probably won't work unless called from the overridable
482 do_upgrade method.
483
484 =cut
485
486 sub run_upgrade
487 {
488     my ($self, $stm) = @_;
489
490     return unless ($self->_filedata);
491     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
492     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
493
494     for (@statements)
495     {
496         $self->storage->debugobj->query_start($_) if $self->storage->debug;
497         $self->apply_statement($_);
498         $self->storage->debugobj->query_end($_) if $self->storage->debug;
499     }
500
501     return 1;
502 }
503
504 =head2 apply_statement
505
506 Takes an SQL statement and runs it. Override this if you want to handle errors
507 differently.
508
509 =cut
510
511 sub apply_statement {
512     my ($self, $statement) = @_;
513
514     $self->storage->dbh->do($_) or carp "SQL was: $_";
515 }
516
517 =head2 get_db_version
518
519 Returns the version that your database is currently at. This is determined by the values in the
520 dbix_class_schema_versions table that C<upgrade> and C<install> write to.
521
522 =cut
523
524 sub get_db_version
525 {
526     my ($self, $rs) = @_;
527
528     my $vtable = $self->{vschema}->resultset('Table');
529     my $version = try {
530       $vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
531               ->get_column ('version')
532                ->next;
533     };
534     return $version || 0;
535 }
536
537 =head2 schema_version
538
539 Returns the current schema class' $VERSION
540
541 =cut
542
543 =head2 backup
544
545 This is an overwritable method which is called just before the upgrade, to
546 allow you to make a backup of the database. Per default this method attempts
547 to call C<< $self->storage->backup >>, to run the standard backup on each
548 database type.
549
550 This method should return the name of the backup file, if appropriate..
551
552 This method is disabled by default. Set $schema->do_backup(1) to enable it.
553
554 =cut
555
556 sub backup
557 {
558     my ($self) = @_;
559     ## Make each ::DBI::Foo do this
560     $self->storage->backup($self->backup_directory());
561 }
562
563 =head2 connection
564
565 Overloaded method. This checks the DBIC schema version against the DB version and
566 warns if they are not the same or if the DB is unversioned. It also provides
567 compatibility between the old versions table (SchemaVersions) and the new one
568 (dbix_class_schema_versions).
569
570 To avoid the checks on connect, set the environment var DBIC_NO_VERSION_CHECK or alternatively you can set the ignore_version attr in the forth argument like so:
571
572   my $schema = MyApp::Schema->connect(
573     $dsn,
574     $user,
575     $password,
576     { ignore_version => 1 },
577   );
578
579 =cut
580
581 sub connection {
582   my $self = shift;
583   $self->next::method(@_);
584   $self->_on_connect();
585   return $self;
586 }
587
588 sub _on_connect
589 {
590   my ($self) = @_;
591
592   my $conn_info = $self->storage->connect_info;
593   $self->{vschema} = DBIx::Class::Version->connect(@$conn_info);
594   my $conn_attrs = $self->{vschema}->storage->_dbic_connect_attributes || {};
595
596   my $vtable = $self->{vschema}->resultset('Table');
597
598   # useful when connecting from scripts etc
599   return if ($conn_attrs->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $conn_attrs->{ignore_version}));
600
601   # check for legacy versions table and move to new if exists
602   unless ($self->_source_exists($vtable)) {
603     my $vtable_compat = DBIx::Class::VersionCompat->connect(@$conn_info)->resultset('TableCompat');
604     if ($self->_source_exists($vtable_compat)) {
605       $self->{vschema}->deploy;
606       map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
607       $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
608     }
609   }
610
611   my $pversion = $self->get_db_version();
612
613   if($pversion eq $self->schema_version)
614     {
615         #carp "This version is already installed";
616         return 1;
617     }
618
619   if(!$pversion)
620     {
621         carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.";
622         return 1;
623     }
624
625   carp "Versions out of sync. This is " . $self->schema_version .
626     ", your database contains version $pversion, please call upgrade on your Schema.";
627 }
628
629 # is this just a waste of time? if not then merge with DBI.pm
630 sub _create_db_to_schema_diff {
631   my $self = shift;
632
633   my %driver_to_db_map = (
634                           'mysql' => 'MySQL'
635                          );
636
637   my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
638   unless ($db) {
639     print "Sorry, this is an unsupported DB\n";
640     return;
641   }
642
643   unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) {
644     $self->throw_exception("Unable to proceed without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
645   }
646
647   my $db_tr = SQL::Translator->new({
648                                     add_drop_table => 1,
649                                     parser => 'DBI',
650                                     parser_args => { dbh => $self->storage->dbh }
651                                    });
652
653   $db_tr->producer($db);
654   my $dbic_tr = SQL::Translator->new;
655   $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
656   $dbic_tr->data($self);
657   $dbic_tr->producer($db);
658
659   $db_tr->schema->name('db_schema');
660   $dbic_tr->schema->name('dbic_schema');
661
662   # is this really necessary?
663   foreach my $tr ($db_tr, $dbic_tr) {
664     my $data = $tr->data;
665     $tr->parser->($tr, $$data);
666   }
667
668   my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
669                                                 $dbic_tr->schema, $db,
670                                                 { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
671
672   my $filename = $self->ddl_filename(
673                                          $db,
674                                          $self->schema_version,
675                                          $self->upgrade_directory,
676                                          'PRE',
677                                     );
678   my $file;
679   if(!open($file, ">$filename"))
680     {
681       $self->throw_exception("Can't open $filename for writing ($!)");
682       next;
683     }
684   print $file $diff;
685   close($file);
686
687   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.";
688 }
689
690
691 sub _set_db_version {
692   my $self = shift;
693   my ($params) = @_;
694   $params ||= {};
695
696   my $version = $params->{version} ? $params->{version} : $self->schema_version;
697   my $vtable = $self->{vschema}->resultset('Table');
698
699   ##############################################################################
700   #                             !!! NOTE !!!
701   ##############################################################################
702   #
703   # The travesty below replaces the old nice timestamp format of %Y-%m-%d %H:%M:%S
704   # This is necessary since there are legitimate cases when upgrades can happen
705   # back to back within the same second. This breaks things since we relay on the
706   # ability to sort by the 'installed' value. The logical choice of an autoinc
707   # is not possible, as it will break multiple legacy installations. Also it is
708   # not possible to format the string sanely, as the column is a varchar(20).
709   # The 'v' character is added to the front of the string, so that any version
710   # formatted by this new function will sort _after_ any existing 200... strings.
711   my @tm = gettimeofday();
712   my @dt = gmtime ($tm[0]);
713   my $o = $vtable->create({
714     version => $version,
715     installed => sprintf("v%04d%02d%02d_%02d%02d%02d.%03.0f",
716       $dt[5] + 1900,
717       $dt[4] + 1,
718       $dt[3],
719       $dt[2],
720       $dt[1],
721       $dt[0],
722       $tm[1] / 1000, # convert to millisecs, format as up/down rounded int above
723     ),
724   });
725 }
726
727 sub _read_sql_file {
728   my $self = shift;
729   my $file = shift || return;
730
731   open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
732   my @data = split /\n/, join '', <$fh>;
733   close $fh;
734
735   @data = split /;/,
736      join '',
737        grep { $_ &&
738               !/^--/  &&
739               !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/mi }
740          @data;
741
742   return \@data;
743 }
744
745 sub _source_exists
746 {
747     my ($self, $rs) = @_;
748
749     return try {
750       $rs->search(\'1=0')->cursor->next;
751       1;
752     } catch {
753       0;
754     };
755 }
756
757 1;
758
759
760 =head1 AUTHORS
761
762 Jess Robinson <castaway@desert-island.me.uk>
763 Luke Saunders <luke@shadowcatsystems.co.uk>
764
765 =head1 LICENSE
766
767 You may distribute this code under the same terms as Perl itself.