Add single() ro RSC
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Schema / Versioned.pm
CommitLineData
a89c6fc0 1package # Hide from PAUSE
2 DBIx::Class::Version::Table;
c9d2e0a2 3use base 'DBIx::Class';
4use strict;
5use 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 32package # Hide from PAUSE
33 DBIx::Class::Version::TableCompat;
732dc718 34use 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 48package # Hide from PAUSE
49 DBIx::Class::Version;
c9d2e0a2 50use base 'DBIx::Class::Schema';
51use strict;
52use warnings;
53
54__PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table');
55
a89c6fc0 56package # Hide from PAUSE
57 DBIx::Class::VersionCompat;
b4b1e91c 58use base 'DBIx::Class::Schema';
59use strict;
60use warnings;
61
62__PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat');
63
c9d2e0a2 64
65# ---------------------------------------------------------------------------
8424c090 66
67=head1 NAME
68
69DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
70
71=head1 SYNOPSIS
72
6c2b68ed 73 package MyApp::Schema;
e84a43c1 74 use base qw/DBIx::Class::Schema/;
75
76 our $VERSION = 0.001;
77
6c2b68ed 78 # load MyApp::Schema::CD, MyApp::Schema::Book, MyApp::Schema::DVD
8424c090 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 87This module provides methods to apply DDL changes to your database using SQL
88diff files. Normally these diff files would be created using
89L<DBIx::Class::Schema/create_ddl_dir>.
8424c090 90
b4b1e91c 91A table called I<dbix_class_schema_versions> is created and maintained by the
e84a43c1 92module. This is used to determine which version your database is currently at.
93Similarly the $VERSION in your DBIC schema class is used to determine the
94current DBIC schema version.
8424c090 95
e84a43c1 96The upgrade is initiated manually by calling C<upgrade> on your schema object,
97this will attempt to upgrade the database from its current version to the current
98schema version using a diff from your I<upgrade_directory>. If a suitable diff is
99not found then no upgrade is possible.
8424c090 100
101NB: At the moment, only SQLite and MySQL are supported. This is due to
102spotty behaviour in the SQL::Translator producers, please help us by
e63a82f7 103enhancing them. Ask on the mailing list or IRC channel for details (community details
e84a43c1 104in L<DBIx::Class>).
93e4d41a 105
106=head1 GETTING STARTED
107
e84a43c1 108Firstly you need to setup your schema class as per the L</SYNOPSIS>, make sure
109you have specified an upgrade_directory and an initial $VERSION.
93e4d41a 110
e84a43c1 111Then you'll need two scripts, one to create DDL files and diffs and another to perform
112upgrades. 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 133Then 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
151The script above assumes that if the database is unversioned then it is empty
152and we can safely deploy the DDL to it. However things are not always so simple.
153
154if you want to initialise a pre-existing database where the DDL is not the same
155as the DDL for your current schema version then you will need a diff which
156converts the database's DDL to the current DDL. The best way to do this is
157to get a dump of the database schema (without data) and save that in your
158SQL directory as version 0.000 (the filename must be as with
159L<DBIx::Class::Schema/ddl_filename>) then create a diff using your create DDL
160script given above from version 0.000 to the current version. Then hand check
161and if necessary edit the resulting diff to ensure that it will apply. Once you have
162done 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
172In the case of an unversioned database the above code will create the
173dbix_class_schema_versions table and write version 0.000 to it, then
174upgrade will then apply the diff we talked about creating in the previous paragraph
175and then you're good to go.
8424c090 176
177=cut
178
c9d2e0a2 179package DBIx::Class::Schema::Versioned;
180
181use strict;
182use warnings;
183use base 'DBIx::Class';
341d5ede 184
185use Carp::Clan qw/^DBIx::Class/;
c9d2e0a2 186use POSIX 'strftime';
c9d2e0a2 187
188__PACKAGE__->mk_classdata('_filedata');
189__PACKAGE__->mk_classdata('upgrade_directory');
8795fefb 190__PACKAGE__->mk_classdata('backup_directory');
f925f7cb 191__PACKAGE__->mk_classdata('do_backup');
8424c090 192__PACKAGE__->mk_classdata('do_diff_on_init');
193
e84a43c1 194
195=head1 METHODS
196
197=head2 upgrade_directory
198
199Use this to set the directory your upgrade files are stored in.
200
201=head2 backup_directory
202
203Use this to set the directory you want your backups stored in (note that backups
204are disabled by default).
205
206=cut
207
93e4d41a 208=head2 install
c9d2e0a2 209
93e4d41a 210=over 4
c9d2e0a2 211
93e4d41a 212=item Arguments: $db_version
e6129e56 213
93e4d41a 214=back
8424c090 215
93e4d41a 216Call 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 217
93e4d41a 218Takes one argument which should be the version that the database is currently at. Defaults to the return value of L</schema_version>.
8424c090 219
93e4d41a 220See L</getting_started> for more details.
f81b9157 221
8424c090 222=cut
223
93e4d41a 224sub install
c9d2e0a2 225{
93e4d41a 226 my ($self, $new_version) = @_;
c9d2e0a2 227
93e4d41a 228 # must be called on a fresh database
229 if ($self->get_db_version()) {
341d5ede 230 carp 'Install not possible as versions table already exists in database';
8424c090 231 }
c9d2e0a2 232
93e4d41a 233 # default to current version if none passed
234 $new_version ||= $self->schema_version();
8424c090 235
e84a43c1 236 if ($new_version) {
93e4d41a 237 # create versions table and version row
238 $self->{vschema}->deploy;
a354b842 239 $self->_set_db_version({ version => $new_version });
8424c090 240 }
c9d2e0a2 241}
242
e84a43c1 243=head2 deploy
244
245Same as L<DBIx::Class::Schema/deploy> but also calls C<install>.
246
247=cut
248
249sub deploy {
250 my $self = shift;
251 $self->next::method(@_);
252 $self->install();
253}
254
a354b842 255=head2 create_upgrade_path
256
257=over 4
258
259=item Arguments: { upgrade_file => $file }
260
261=back
262
263Virtual method that should be overriden to create an upgrade file.
264This is useful in the case of upgrading across multiple versions
265to concatenate several files to create one upgrade file.
266
4a743a00 267You'll probably want the db_version retrieved via $self->get_db_version
268and the schema_version which is retrieved via $self->schema_version
269
a354b842 270=cut
271
272sub create_upgrade_path {
273 ## override this method
274}
275
8424c090 276=head2 upgrade
e2c0df8e 277
8424c090 278Call this to attempt to upgrade your database from the version it is at to the version
e84a43c1 279this DBIC schema is at. If they are the same it does nothing.
280
281It requires an SQL diff file to exist in you I<upgrade_directory>, normally you will
282have created this using L<DBIx::Class::Schema/create_ddl_dir>.
c9d2e0a2 283
e84a43c1 284If successful the dbix_class_schema_versions table is updated with the current
285DBIC schema version.
c9d2e0a2 286
8424c090 287=cut
c9d2e0a2 288
8424c090 289sub upgrade
290{
291 my ($self) = @_;
292 my $db_version = $self->get_db_version();
c9d2e0a2 293
8424c090 294 # db unversioned
295 unless ($db_version) {
341d5ede 296 carp 'Upgrade not possible as database is unversioned. Please call install first.';
8424c090 297 return;
c9d2e0a2 298 }
299
8424c090 300 # db and schema at same version. do nothing
301 if ($db_version eq $self->schema_version) {
341d5ede 302 carp "Upgrade not necessary\n";
8424c090 303 return;
c9d2e0a2 304 }
305
37fcb5b5 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;
d4daee7b 311
8424c090 312 my $upgrade_file = $self->ddl_filename(
313 $self->storage->sqlt_type,
8424c090 314 $self->schema_version,
99a74c4a 315 $self->upgrade_directory,
8424c090 316 $db_version,
317 );
c9d2e0a2 318
a354b842 319 $self->create_upgrade_path({ upgrade_file => $upgrade_file });
320
8424c090 321 unless (-f $upgrade_file) {
341d5ede 322 carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
8424c090 323 return;
324 }
c9d2e0a2 325
341d5ede 326 carp "\nDB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n";
a354b842 327
8424c090 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() });
c9d2e0a2 332
b4b1e91c 333 # set row in dbix_class_schema_versions table
8424c090 334 $self->_set_db_version;
335}
c9d2e0a2 336
e6129e56 337=head2 do_upgrade
338
c9d2e0a2 339This is an overwritable method used to run your upgrade. The freeform method
340allows you to run your upgrade any way you please, you can call C<run_upgrade>
341any number of times to run the actual SQL commands, and in between you can
342sandwich your data upgrading. For example, first run all the B<CREATE>
343commands, then migrate your data from old to new tables/formats, then
e7b14c5b 344issue the DROP commands when you are finished. Will run the whole file as it is by default.
8424c090 345
346=cut
347
348sub do_upgrade
349{
e7b14c5b 350 my ($self) = @_;
8424c090 351
e7b14c5b 352 # just run all the commands (including inserts) in order
353 $self->run_upgrade(qr/.*?/);
8424c090 354}
355
c9d2e0a2 356=head2 run_upgrade
357
358 $self->run_upgrade(qr/create/i);
359
360Runs a set of SQL statements matching a passed in regular expression. The
361idea is that this method can be called any number of times from your
e84a43c1 362C<do_upgrade> method, running whichever commands you specify via the
8424c090 363regex in the parameter. Probably won't work unless called from the overridable
364do_upgrade method.
c9d2e0a2 365
8424c090 366=cut
8795fefb 367
8424c090 368sub run_upgrade
369{
370 my ($self, $stm) = @_;
8795fefb 371
8424c090 372 return unless ($self->_filedata);
373 my @statements = grep { $_ =~ $stm } @{$self->_filedata};
374 $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
8795fefb 375
8424c090 376 for (@statements)
377 {
378 $self->storage->debugobj->query_start($_) if $self->storage->debug;
abc8f12a 379 $self->apply_statement($_);
8424c090 380 $self->storage->debugobj->query_end($_) if $self->storage->debug;
381 }
8795fefb 382
8424c090 383 return 1;
384}
42416a0b 385
abc8f12a 386=head2 apply_statement
387
388Takes an SQL statement and runs it. Override this if you want to handle errors
389differently.
390
391=cut
392
393sub apply_statement {
394 my ($self, $statement) = @_;
395
341d5ede 396 $self->storage->dbh->do($_) or carp "SQL was:\n $_";
abc8f12a 397}
398
93e4d41a 399=head2 get_db_version
400
401Returns the version that your database is currently at. This is determined by the values in the
e84a43c1 402dbix_class_schema_versions table that C<upgrade> and C<install> write to.
93e4d41a 403
404=cut
405
406sub 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
421Returns the current schema class' $VERSION
422
423=cut
424
425=head2 backup
426
427This is an overwritable method which is called just before the upgrade, to
428allow you to make a backup of the database. Per default this method attempts
429to call C<< $self->storage->backup >>, to run the standard backup on each
430database type.
431
432This method should return the name of the backup file, if appropriate..
433
434This method is disabled by default. Set $schema->do_backup(1) to enable it.
435
436=cut
437
438sub backup
439{
440 my ($self) = @_;
441 ## Make each ::DBI::Foo do this
442 $self->storage->backup($self->backup_directory());
443}
444
ecea7937 445=head2 connection
446
447Overloaded method. This checks the DBIC schema version against the DB version and
448warns if they are not the same or if the DB is unversioned. It also provides
449compatibility between the old versions table (SchemaVersions) and the new one
450(dbix_class_schema_versions).
451
e84a43c1 452To 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 453
454 my $schema = MyApp::Schema->connect(
455 $dsn,
456 $user,
457 $password,
458 { ignore_version => 1 },
459 );
ecea7937 460
461=cut
462
8424c090 463sub connection {
464 my $self = shift;
465 $self->next::method(@_);
f81b9157 466 $self->_on_connect($_[3]);
8424c090 467 return $self;
468}
469
470sub _on_connect
471{
f81b9157 472 my ($self, $args) = @_;
473
474 $args = {} unless $args;
8424c090 475 $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
b4b1e91c 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;
732dc718 484 map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
b4b1e91c 485 $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
486 }
487 }
f81b9157 488
ecea7937 489 # useful when connecting from scripts etc
f81b9157 490 return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
8424c090 491 my $pversion = $self->get_db_version();
492
493 if($pversion eq $self->schema_version)
494 {
341d5ede 495# carp "This version is already installed\n";
8424c090 496 return 1;
497 }
42416a0b 498
8424c090 499 if(!$pversion)
500 {
341d5ede 501 carp "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
8424c090 502 return 1;
503 }
504
341d5ede 505 carp "Versions out of sync. This is " . $self->schema_version .
8424c090 506 ", your database contains version $pversion, please call upgrade on your Schema.\n";
507}
508
93e4d41a 509# is this just a waste of time? if not then merge with DBI.pm
510sub _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
7f6f5b69 523 $self->throw_exception($self->_sqlt_version_error)
524 if (not $self->_sqlt_version_ok);
93e4d41a 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');
93e4d41a 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
341d5ede 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";
93e4d41a 567}
568
569
570sub _set_db_version {
571 my $self = shift;
a354b842 572 my ($params) = @_;
573 $params ||= {};
93e4d41a 574
a354b842 575 my $version = $params->{version} ? $params->{version} : $self->schema_version;
93e4d41a 576 my $vtable = $self->{vschema}->resultset('Table');
a354b842 577 $vtable->create({ version => $version,
93e4d41a 578 installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
579 });
580
581}
582
583sub _read_sql_file {
584 my $self = shift;
585 my $file = shift || return;
586
587 my $fh;
341d5ede 588 open $fh, "<$file" or carp("Can't open upgrade file, $file ($!)");
93e4d41a 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
598sub _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
8424c090 6101;
611
612
613=head1 AUTHORS
c9d2e0a2 614
1a9251f7 615Jess Robinson <castaway@desert-island.me.uk>
8424c090 616Luke Saunders <luke@shadowcatsystems.co.uk>
617
618=head1 LICENSE
619
620You may distribute this code under the same terms as Perl itself.