Fix complex limits with subqueries in selectors
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Schema / Versioned.pm
CommitLineData
a89c6fc0 1package # Hide from PAUSE
2 DBIx::Class::Version::Table;
d88ecca6 3use base 'DBIx::Class::Core';
c9d2e0a2 4use strict;
5use warnings;
6
b4b1e91c 7__PACKAGE__->table('dbix_class_schema_versions');
c9d2e0a2 8
ad1446da 9__PACKAGE__->add_columns
732dc718 10 ( 'version' => {
ad1446da 11 'data_type' => 'VARCHAR',
12 'is_auto_increment' => 0,
13 'default_value' => undef,
14 'is_foreign_key' => 0,
732dc718 15 'name' => 'version',
ad1446da 16 'is_nullable' => 0,
17 'size' => '10'
18 },
732dc718 19 'installed' => {
c9d2e0a2 20 'data_type' => 'VARCHAR',
21 'is_auto_increment' => 0,
22 'default_value' => undef,
23 'is_foreign_key' => 0,
732dc718 24 'name' => 'installed',
c9d2e0a2 25 'is_nullable' => 0,
26 'size' => '20'
ad1446da 27 },
28 );
732dc718 29__PACKAGE__->set_primary_key('version');
c9d2e0a2 30
a89c6fc0 31package # Hide from PAUSE
32 DBIx::Class::Version::TableCompat;
d88ecca6 33use base 'DBIx::Class::Core';
b4b1e91c 34__PACKAGE__->table('SchemaVersions');
35
732dc718 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
a89c6fc0 46package # Hide from PAUSE
47 DBIx::Class::Version;
c9d2e0a2 48use base 'DBIx::Class::Schema';
49use strict;
50use warnings;
51
52__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
53
a89c6fc0 54package # Hide from PAUSE
55 DBIx::Class::VersionCompat;
b4b1e91c 56use base 'DBIx::Class::Schema';
57use strict;
58use warnings;
59
60__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
61
c9d2e0a2 62
63# ---------------------------------------------------------------------------
8424c090 64
65=head1 NAME
66
67DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
68
69=head1 SYNOPSIS
70
6c2b68ed 71 package MyApp::Schema;
e84a43c1 72 use base qw/DBIx::Class::Schema/;
73
74 our $VERSION = 0.001;
75
6c2b68ed 76 # load MyApp::Schema::CD, MyApp::Schema::Book, MyApp::Schema::DVD
8424c090 77 __PACKAGE__->load_classes(qw/CD Book DVD/);
78
e84a43c1 79 __PACKAGE__->load_components(qw/Schema::Versioned/);
8424c090 80 __PACKAGE__->upgrade_directory('/path/to/upgrades/');
8424c090 81
82
83=head1 DESCRIPTION
84
e84a43c1 85This module provides methods to apply DDL changes to your database using SQL
86diff files. Normally these diff files would be created using
87L<DBIx::Class::Schema/create_ddl_dir>.
8424c090 88
b4b1e91c 89A table called I<dbix_class_schema_versions> is created and maintained by the
e84a43c1 90module. This is used to determine which version your database is currently at.
91Similarly the $VERSION in your DBIC schema class is used to determine the
92current DBIC schema version.
8424c090 93
e84a43c1 94The upgrade is initiated manually by calling C<upgrade> on your schema object,
95this will attempt to upgrade the database from its current version to the current
96schema version using a diff from your I<upgrade_directory>. If a suitable diff is
97not found then no upgrade is possible.
8424c090 98
da0dd7dc 99=head1 SEE ALSO
100
101L<DBIx::Class::DeploymentHandler> is a much more powerful alternative to this
102module. Examples of things it can do that this module cannot do include
103
104=over
105
106=item *
107
108Downgrades in addition to upgrades
109
110=item *
111
112Multiple sql files files per upgrade/downgrade/install
113
114=item *
115
116Perl scripts allowed for upgrade/downgrade/install
117
118=item *
119
120Just one set of files needed for upgrade, unlike this module where one might
121need to generate C<factorial(scalar @versions)>
122
123=back
124
93e4d41a 125=head1 GETTING STARTED
126
e84a43c1 127Firstly you need to setup your schema class as per the L</SYNOPSIS>, make sure
128you have specified an upgrade_directory and an initial $VERSION.
93e4d41a 129
e84a43c1 130Then you'll need two scripts, one to create DDL files and diffs and another to perform
131upgrades. Your creation script might look like a bit like this:
93e4d41a 132
e84a43c1 133 use strict;
134 use Pod::Usage;
135 use Getopt::Long;
136 use MyApp::Schema;
8424c090 137
56988b6c 138 my ( $preversion, $help );
e84a43c1 139 GetOptions(
140 'p|preversion:s' => \$preversion,
141 ) or die pod2usage;
8424c090 142
e84a43c1 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 );
8424c090 151
e84a43c1 152Then 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 );
8424c090 162
e84a43c1 163 if (!$schema->get_db_version()) {
164 # schema is unversioned
165 $schema->deploy();
166 } else {
167 $schema->upgrade();
168 }
169
170The script above assumes that if the database is unversioned then it is empty
171and we can safely deploy the DDL to it. However things are not always so simple.
172
173if you want to initialise a pre-existing database where the DDL is not the same
82625f90 174as the DDL for your current schema version then you will need a diff which
e84a43c1 175converts the database's DDL to the current DDL. The best way to do this is
176to get a dump of the database schema (without data) and save that in your
177SQL directory as version 0.000 (the filename must be as with
82625f90 178L<DBIx::Class::Schema/ddl_filename>) then create a diff using your create DDL
e84a43c1 179script given above from version 0.000 to the current version. Then hand check
82625f90 180and if necessary edit the resulting diff to ensure that it will apply. Once you have
e84a43c1 181done 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
191In the case of an unversioned database the above code will create the
82625f90 192dbix_class_schema_versions table and write version 0.000 to it, then
e84a43c1 193upgrade will then apply the diff we talked about creating in the previous paragraph
194and then you're good to go.
8424c090 195
196=cut
197
c9d2e0a2 198package DBIx::Class::Schema::Versioned;
199
200use strict;
201use warnings;
d88ecca6 202use base 'DBIx::Class::Schema';
341d5ede 203
70c28808 204use DBIx::Class::Carp;
d2bc7045 205use Time::HiRes qw/gettimeofday/;
9780718f 206use Try::Tiny;
fd323bf1 207use namespace::clean;
c9d2e0a2 208
209__PACKAGE__->mk_classdata('_filedata');
210__PACKAGE__->mk_classdata('upgrade_directory');
8795fefb 211__PACKAGE__->mk_classdata('backup_directory');
f925f7cb 212__PACKAGE__->mk_classdata('do_backup');
8424c090 213__PACKAGE__->mk_classdata('do_diff_on_init');
214
e84a43c1 215
216=head1 METHODS
217
218=head2 upgrade_directory
219
220Use this to set the directory your upgrade files are stored in.
221
222=head2 backup_directory
223
224Use this to set the directory you want your backups stored in (note that backups
225are disabled by default).
226
227=cut
228
93e4d41a 229=head2 install
c9d2e0a2 230
93e4d41a 231=over 4
c9d2e0a2 232
93e4d41a 233=item Arguments: $db_version
e6129e56 234
93e4d41a 235=back
8424c090 236
93e4d41a 237Call 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.
8424c090 238
93e4d41a 239Takes one argument which should be the version that the database is currently at. Defaults to the return value of L</schema_version>.
8424c090 240
93e4d41a 241See L</getting_started> for more details.
f81b9157 242
8424c090 243=cut
244
93e4d41a 245sub install
c9d2e0a2 246{
93e4d41a 247 my ($self, $new_version) = @_;
c9d2e0a2 248
93e4d41a 249 # must be called on a fresh database
250 if ($self->get_db_version()) {
a03b396b 251 $self->throw_exception("A versioned schema has already been deployed, try upgrade instead.\n");
8424c090 252 }
c9d2e0a2 253
93e4d41a 254 # default to current version if none passed
255 $new_version ||= $self->schema_version();
8424c090 256
e84a43c1 257 if ($new_version) {
93e4d41a 258 # create versions table and version row
259 $self->{vschema}->deploy;
a354b842 260 $self->_set_db_version({ version => $new_version });
8424c090 261 }
c9d2e0a2 262}
263
e84a43c1 264=head2 deploy
265
266Same as L<DBIx::Class::Schema/deploy> but also calls C<install>.
267
268=cut
269
270sub deploy {
271 my $self = shift;
272 $self->next::method(@_);
273 $self->install();
274}
275
a354b842 276=head2 create_upgrade_path
277
278=over 4
279
280=item Arguments: { upgrade_file => $file }
281
282=back
283
c1300297 284Virtual method that should be overridden to create an upgrade file.
56988b6c 285This is useful in the case of upgrading across multiple versions
a354b842 286to concatenate several files to create one upgrade file.
287
4a743a00 288You'll probably want the db_version retrieved via $self->get_db_version
56988b6c 289and the schema_version which is retrieved via $self->schema_version
4a743a00 290
a354b842 291=cut
292
293sub create_upgrade_path {
d7a58a29 294 ## override this method
a354b842 295}
296
d2bc7045 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
c1300297 305Virtual method that should be overridden to return an ordered list
d2bc7045 306of schema versions. This is then used to produce a set of steps to
307upgrade through to achieve the required schema version.
308
309You may want the db_version retrieved via $self->get_db_version
56988b6c 310and the schema_version which is retrieved via $self->schema_version
d2bc7045 311
312=cut
313
314sub ordered_schema_versions {
56988b6c 315 ## override this method
d2bc7045 316}
317
8424c090 318=head2 upgrade
e2c0df8e 319
d2bc7045 320Call this to attempt to upgrade your database from the version it
321is at to the version this DBIC schema is at. If they are the same
322it does nothing.
e84a43c1 323
d2bc7045 324It will call L</ordered_schema_versions> to retrieve an ordered
325list of schema versions (if ordered_schema_versions returns nothing
326then it is assumed you can do the upgrade as a single step). It
327then iterates through the list of versions between the current db
328version and the schema version applying one update at a time until
48580715 329all relevant updates are applied.
c9d2e0a2 330
d2bc7045 331The individual update steps are performed by using
332L</upgrade_single_step>, which will apply the update and also
333update the dbix_class_schema_versions table.
c9d2e0a2 334
8424c090 335=cut
c9d2e0a2 336
d2bc7045 337sub upgrade {
338 my ($self) = @_;
339 my $db_version = $self->get_db_version();
c9d2e0a2 340
d2bc7045 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 ) {
70c28808 349 carp 'Upgrade not necessary';
d2bc7045 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
397Call this to attempt to upgrade your database from the
398I<db_version> to the I<target_version>. If they are the same it
399does nothing.
400
401It requires an SQL diff file to exist in your I<upgrade_directory>,
402normally you will have created this using L<DBIx::Class::Schema/create_ddl_dir>.
403
404If successful the dbix_class_schema_versions table is updated with
405the I<target_version>.
406
407This method may be called repeatedly by the upgrade method to
408upgrade through a series of updates.
409
410=cut
411
412sub upgrade_single_step
413{
414 my ($self,
415 $db_version,
416 $target_version) = @_;
c9d2e0a2 417
8424c090 418 # db and schema at same version. do nothing
d2bc7045 419 if ($db_version eq $target_version) {
70c28808 420 carp 'Upgrade not necessary';
8424c090 421 return;
c9d2e0a2 422 }
423
37fcb5b5 424 # strangely the first time this is called can
82625f90 425 # differ to subsequent times. so we call it
37fcb5b5 426 # here to be sure.
427 # XXX - just fix it
428 $self->storage->sqlt_type;
d4daee7b 429
8424c090 430 my $upgrade_file = $self->ddl_filename(
431 $self->storage->sqlt_type,
d2bc7045 432 $target_version,
99a74c4a 433 $self->upgrade_directory,
8424c090 434 $db_version,
435 );
c9d2e0a2 436
a354b842 437 $self->create_upgrade_path({ upgrade_file => $upgrade_file });
438
8424c090 439 unless (-f $upgrade_file) {
70c28808 440 carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one";
8424c090 441 return;
442 }
c9d2e0a2 443
d7a58a29 444 carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
a354b842 445
8424c090 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() });
c9d2e0a2 450
b4b1e91c 451 # set row in dbix_class_schema_versions table
d2bc7045 452 $self->_set_db_version({version => $target_version});
8424c090 453}
c9d2e0a2 454
e6129e56 455=head2 do_upgrade
456
c9d2e0a2 457This is an overwritable method used to run your upgrade. The freeform method
458allows you to run your upgrade any way you please, you can call C<run_upgrade>
459any number of times to run the actual SQL commands, and in between you can
460sandwich your data upgrading. For example, first run all the B<CREATE>
82625f90 461commands, then migrate your data from old to new tables/formats, then
e7b14c5b 462issue the DROP commands when you are finished. Will run the whole file as it is by default.
8424c090 463
464=cut
465
466sub do_upgrade
467{
e7b14c5b 468 my ($self) = @_;
8424c090 469
56988b6c 470 # just run all the commands (including inserts) in order
e7b14c5b 471 $self->run_upgrade(qr/.*?/);
8424c090 472}
473
c9d2e0a2 474=head2 run_upgrade
475
476 $self->run_upgrade(qr/create/i);
477
478Runs a set of SQL statements matching a passed in regular expression. The
479idea is that this method can be called any number of times from your
e84a43c1 480C<do_upgrade> method, running whichever commands you specify via the
8424c090 481regex in the parameter. Probably won't work unless called from the overridable
482do_upgrade method.
c9d2e0a2 483
8424c090 484=cut
8795fefb 485
8424c090 486sub run_upgrade
487{
488 my ($self, $stm) = @_;
8795fefb 489
8424c090 490 return unless ($self->_filedata);
491 my @statements = grep { $_ =~ $stm } @{$self->_filedata};
492 $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
8795fefb 493
8424c090 494 for (@statements)
82625f90 495 {
8424c090 496 $self->storage->debugobj->query_start($_) if $self->storage->debug;
abc8f12a 497 $self->apply_statement($_);
8424c090 498 $self->storage->debugobj->query_end($_) if $self->storage->debug;
499 }
8795fefb 500
8424c090 501 return 1;
502}
42416a0b 503
abc8f12a 504=head2 apply_statement
505
506Takes an SQL statement and runs it. Override this if you want to handle errors
507differently.
508
509=cut
510
511sub apply_statement {
512 my ($self, $statement) = @_;
513
d7a58a29 514 $self->storage->dbh->do($_) or carp "SQL was: $_";
abc8f12a 515}
516
93e4d41a 517=head2 get_db_version
518
519Returns the version that your database is currently at. This is determined by the values in the
e84a43c1 520dbix_class_schema_versions table that C<upgrade> and C<install> write to.
93e4d41a 521
522=cut
523
524sub get_db_version
525{
526 my ($self, $rs) = @_;
527
528 my $vtable = $self->{vschema}->resultset('Table');
9780718f 529 my $version = try {
56988b6c 530 $vtable->search({}, { order_by => { -desc => 'installed' }, rows => 1 } )
531 ->get_column ('version')
532 ->next;
93e4d41a 533 };
56988b6c 534 return $version || 0;
93e4d41a 535}
536
537=head2 schema_version
538
539Returns the current schema class' $VERSION
540
541=cut
542
543=head2 backup
544
545This is an overwritable method which is called just before the upgrade, to
546allow you to make a backup of the database. Per default this method attempts
547to call C<< $self->storage->backup >>, to run the standard backup on each
56988b6c 548database type.
93e4d41a 549
550This method should return the name of the backup file, if appropriate..
551
552This method is disabled by default. Set $schema->do_backup(1) to enable it.
553
554=cut
555
556sub backup
557{
558 my ($self) = @_;
559 ## Make each ::DBI::Foo do this
560 $self->storage->backup($self->backup_directory());
561}
562
ecea7937 563=head2 connection
564
565Overloaded method. This checks the DBIC schema version against the DB version and
566warns if they are not the same or if the DB is unversioned. It also provides
567compatibility between the old versions table (SchemaVersions) and the new one
568(dbix_class_schema_versions).
569
48580715 570To 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:
f81b9157 571
572 my $schema = MyApp::Schema->connect(
573 $dsn,
574 $user,
575 $password,
576 { ignore_version => 1 },
577 );
ecea7937 578
579=cut
580
8424c090 581sub connection {
582 my $self = shift;
583 $self->next::method(@_);
8012b15c 584 $self->_on_connect();
8424c090 585 return $self;
586}
587
588sub _on_connect
589{
8012b15c 590 my ($self) = @_;
f81b9157 591
f76f761c 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 || {};
06f10f6f 595
b4b1e91c 596 my $vtable = $self->{vschema}->resultset('Table');
597
c99c4801 598 # useful when connecting from scripts etc
f76f761c 599 return if ($conn_attrs->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $conn_attrs->{ignore_version}));
c99c4801 600
b4b1e91c 601 # check for legacy versions table and move to new if exists
b4b1e91c 602 unless ($self->_source_exists($vtable)) {
a5722c72 603 my $vtable_compat = DBIx::Class::VersionCompat->connect(@$conn_info)->resultset('TableCompat');
b4b1e91c 604 if ($self->_source_exists($vtable_compat)) {
605 $self->{vschema}->deploy;
732dc718 606 map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
f76f761c 607 $self->storage->_get_dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
b4b1e91c 608 }
609 }
f81b9157 610
8424c090 611 my $pversion = $self->get_db_version();
612
613 if($pversion eq $self->schema_version)
614 {
70c28808 615 #carp "This version is already installed";
8424c090 616 return 1;
617 }
42416a0b 618
8424c090 619 if(!$pversion)
620 {
70c28808 621 carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.";
8424c090 622 return 1;
623 }
624
d7a58a29 625 carp "Versions out of sync. This is " . $self->schema_version .
70c28808 626 ", your database contains version $pversion, please call upgrade on your Schema.";
8424c090 627}
628
93e4d41a 629# is this just a waste of time? if not then merge with DBI.pm
630sub _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
2527233b 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 }
93e4d41a 646
b2b2e7fd 647 my $db_tr = SQL::Translator->new({
648 add_drop_table => 1,
93e4d41a 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');
93e4d41a 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
82625f90 668 my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
93e4d41a 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
70c28808 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.";
93e4d41a 688}
689
690
691sub _set_db_version {
692 my $self = shift;
a354b842 693 my ($params) = @_;
694 $params ||= {};
93e4d41a 695
a354b842 696 my $version = $params->{version} ? $params->{version} : $self->schema_version;
93e4d41a 697 my $vtable = $self->{vschema}->resultset('Table');
93e4d41a 698
d2bc7045 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
a03b396b 707 # is not possible, as it will break multiple legacy installations. Also it is
d2bc7045 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]);
a03b396b 713 my $o = $vtable->create({
d2bc7045 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 });
93e4d41a 725}
726
727sub _read_sql_file {
728 my $self = shift;
729 my $file = shift || return;
730
82625f90 731 open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)");
732 my @data = split /\n/, join '', <$fh>;
733 close $fh;
734
b703fec7 735 @data = split /;/,
736 join '',
737 grep { $_ &&
738 !/^--/ &&
739 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/mi }
740 @data;
82625f90 741
93e4d41a 742 return \@data;
743}
744
745sub _source_exists
746{
747 my ($self, $rs) = @_;
748
c271eec3 749 return try {
750 $rs->search(\'1=0')->cursor->next;
751 1;
752 } catch {
753 0;
754 };
93e4d41a 755}
756
8424c090 7571;
758
759
760=head1 AUTHORS
c9d2e0a2 761
1a9251f7 762Jess Robinson <castaway@desert-island.me.uk>
8424c090 763Luke Saunders <luke@shadowcatsystems.co.uk>
764
765=head1 LICENSE
766
767You may distribute this code under the same terms as Perl itself.