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