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 Library::Schema;
  74   use base qw/DBIx::Class::Schema/;
  75   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
  76   __PACKAGE__->load_classes(qw/CD Book DVD/);
  77
  78   __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
  79   __PACKAGE__->upgrade_directory('/path/to/upgrades/');
  80   __PACKAGE__->backup_directory('/path/to/backups/');
  81
  82
  83 =head1 DESCRIPTION
  84
  85 This module is a component designed to extend L<DBIx::Class::Schema>
  86 classes, to enable them to upgrade to newer schema layouts. To use this
  87 module, you need to have called C<create_ddl_dir> on your Schema to
  88 create your upgrade files to include with your delivery.
  89
  90 A table called I<dbix_class_schema_versions> is created and maintained by the
  91 module. This contains two fields, 'Version' and 'Installed', which
  92 contain each VERSION of your Schema, and the date+time it was installed.
  93
  94 The actual upgrade is called manually by calling C<upgrade> on your
  95 schema object. Code is run at connect time to determine whether an
  96 upgrade is needed, if so, a warning "Versions out of sync" is
  97 produced.
  98
  99 So you'll probably want to write a script which generates your DDLs and diffs
 100 and another which executes the upgrade.
 101
 102 NB: At the moment, only SQLite and MySQL are supported. This is due to
 103 spotty behaviour in the SQL::Translator producers, please help us by
 104 them.
 105
 106 =head1 METHODS
 107
 108 =head2 upgrade_directory
 109
 110 Use this to set the directory your upgrade files are stored in.
 111
 112 =head2 backup_directory
 113
 114 Use this to set the directory you want your backups stored in.
 115
 116 =cut
 117
 118 package DBIx::Class::Schema::Versioned;
 119
 120 use strict;
 121 use warnings;
 122 use base 'DBIx::Class';
 123 use POSIX 'strftime';
 124 use Data::Dumper;
 125
 126 __PACKAGE__->mk_classdata('_filedata');
 127 __PACKAGE__->mk_classdata('upgrade_directory');
 128 __PACKAGE__->mk_classdata('backup_directory');
 129 __PACKAGE__->mk_classdata('do_backup');
 130 __PACKAGE__->mk_classdata('do_diff_on_init');
 131
 132 =head2 schema_version
 133
 134 Returns the current schema class' $VERSION; does -not- use $schema->VERSION
 135 since that varies in results depending on if version.pm is installed, and if
 136 so the perl or XS versions. If you want this to change, bug the version.pm
 137 author to make vpp and vxs behave the same.
 138
 139 =cut
 140
 141 sub schema_version {
 142   my ($self) = @_;
 143   my $class = ref($self)||$self;
 144   my $version;
 145   {
 146     no strict 'refs';
 147     $version = ${"${class}::VERSION"};
 148   }
 149   return $version;
 150 }
 151
 152 =head2 get_db_version
 153
 154 Returns the version that your database is currently at. This is determined by the values in the
 155 dbix_class_schema_versions table that $self->upgrade writes to.
 156
 157 =cut
 158
 159 sub get_db_version
 160 {
 161     my ($self, $rs) = @_;
 162
 163     my $vtable = $self->{vschema}->resultset('Table');
 164     my $version = 0;
 165     eval {
 166       my $stamp = $vtable->get_column('installed')->max;
 167       $version = $vtable->search({ installed => $stamp })->first->version;
 168     };
 169     return $version;
 170 }
 171
 172 sub _source_exists
 173 {
 174     my ($self, $rs) = @_;
 175
 176     my $c = eval {
 177         $rs->search({ 1, 0 })->count;
 178     };
 179     return 0 if $@ || !defined $c;
 180
 181     return 1;
 182 }
 183
 184 =head2 backup
 185
 186 This is an overwritable method which is called just before the upgrade, to
 187 allow you to make a backup of the database. Per default this method attempts
 188 to call C<< $self->storage->backup >>, to run the standard backup on each
 189 database type.
 190
 191 This method should return the name of the backup file, if appropriate..
 192
 193 =cut
 194
 195 sub backup
 196 {
 197     my ($self) = @_;
 198     ## Make each ::DBI::Foo do this
 199     $self->storage->backup($self->backup_directory());
 200 }
 201
 202 # is this just a waste of time? if not then merge with DBI.pm
 203 sub _create_db_to_schema_diff {
 204   my $self = shift;
 205
 206   my %driver_to_db_map = (
 207                           'mysql' => 'MySQL'
 208                          );
 209
 210   my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
 211   unless ($db) {
 212     print "Sorry, this is an unsupported DB\n";
 213     return;
 214   }
 215
 216   eval 'require SQL::Translator "0.09"';
 217   if ($@) {
 218     $self->throw_exception("SQL::Translator 0.09 required");
 219   }
 220
 221   my $db_tr = SQL::Translator->new({
 222                                     add_drop_table => 1,
 223                                     parser => 'DBI',
 224                                     parser_args => { dbh => $self->storage->dbh }
 225                                    });
 226
 227   $db_tr->producer($db);
 228   my $dbic_tr = SQL::Translator->new;
 229   $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
 230   $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
 231   $dbic_tr->data($self);
 232   $dbic_tr->producer($db);
 233
 234   $db_tr->schema->name('db_schema');
 235   $dbic_tr->schema->name('dbic_schema');
 236
 237   # is this really necessary?
 238   foreach my $tr ($db_tr, $dbic_tr) {
 239     my $data = $tr->data;
 240     $tr->parser->($tr, $$data);
 241   }
 242
 243   my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
 244                                                 $dbic_tr->schema, $db,
 245                                                 { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
 246
 247   my $filename = $self->ddl_filename(
 248                                          $db,
 249                                          $self->upgrade_directory,
 250                                          $self->schema_version,
 251                                          'PRE',
 252                                     );
 253   my $file;
 254   if(!open($file, ">$filename"))
 255     {
 256       $self->throw_exception("Can't open $filename for writing ($!)");
 257       next;
 258     }
 259   print $file $diff;
 260   close($file);
 261
 262   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";
 263 }
 264
 265 =head2 upgrade
 266
 267 Call this to attempt to upgrade your database from the version it is at to the version
 268 this DBIC schema is at.
 269
 270 It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
 271 have created this using $schema->create_ddl_dir.
 272
 273 =cut
 274
 275 sub upgrade
 276 {
 277   my ($self) = @_;
 278   my $db_version = $self->get_db_version();
 279
 280   # db unversioned
 281   unless ($db_version) {
 282     # set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at
 283     $self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
 284
 285     # create versions table and version row
 286     $self->{vschema}->deploy;
 287     $self->_set_db_version;
 288     return;
 289   }
 290
 291   # db and schema at same version. do nothing
 292   if ($db_version eq $self->schema_version) {
 293     print "Upgrade not necessary\n";
 294     return;
 295   }
 296
 297   # strangely the first time this is called can
 298   # differ to subsequent times. so we call it
 299   # here to be sure.
 300   # XXX - just fix it
 301   $self->storage->sqlt_type;
 302
 303   my $upgrade_file = $self->ddl_filename(
 304                                          $self->storage->sqlt_type,
 305                                          $self->upgrade_directory,
 306                                          $self->schema_version,
 307                                          $db_version,
 308                                         );
 309
 310   unless (-f $upgrade_file) {
 311     warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 312     return;
 313   }
 314
 315   # backup if necessary then apply upgrade
 316   $self->_filedata($self->_read_sql_file($upgrade_file));
 317   $self->backup() if($self->do_backup);
 318   $self->txn_do(sub { $self->do_upgrade() });
 319
 320   # set row in dbix_class_schema_versions table
 321   $self->_set_db_version;
 322 }
 323
 324 sub _set_db_version {
 325   my $self = shift;
 326
 327   my $vtable = $self->{vschema}->resultset('Table');
 328   $vtable->create({ version => $self->schema_version,
 329                       installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
 330                       });
 331
 332 }
 333
 334 sub _read_sql_file {
 335   my $self = shift;
 336   my $file = shift || return;
 337
 338   my $fh;
 339   open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
 340   my @data = split(/\n/, join('', <$fh>));
 341   @data = grep(!/^--/, @data);
 342   @data = split(/;/, join('', @data));
 343   close($fh);
 344   @data = grep { $_ && $_ !~ /^-- / } @data;
 345   @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
 346   return \@data;
 347 }
 348
 349 =head2 do_upgrade
 350
 351 This is an overwritable method used to run your upgrade. The freeform method
 352 allows you to run your upgrade any way you please, you can call C<run_upgrade>
 353 any number of times to run the actual SQL commands, and in between you can
 354 sandwich your data upgrading. For example, first run all the B<CREATE>
 355 commands, then migrate your data from old to new tables/formats, then
 356 issue the DROP commands when you are finished.
 357
 358 Will run the whole file as it is by default.
 359
 360 =cut
 361
 362 sub do_upgrade
 363 {
 364     my ($self) = @_;
 365
 366     ## overridable sub, per default just run all the commands.
 367     $self->run_upgrade(qr/create/i);
 368     $self->run_upgrade(qr/alter table .*? add/i);
 369     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 370     $self->run_upgrade(qr/alter table .*? drop/i);
 371     $self->run_upgrade(qr/drop/i);
 372 }
 373
 374 =head2 run_upgrade
 375
 376  $self->run_upgrade(qr/create/i);
 377
 378 Runs a set of SQL statements matching a passed in regular expression. The
 379 idea is that this method can be called any number of times from your
 380 C<upgrade> method, running whichever commands you specify via the
 381 regex in the parameter. Probably won't work unless called from the overridable
 382 do_upgrade method.
 383
 384 =cut
 385
 386 sub run_upgrade
 387 {
 388     my ($self, $stm) = @_;
 389
 390     return unless ($self->_filedata);
 391     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 392     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 393
 394     for (@statements)
 395     {
 396         $self->storage->debugobj->query_start($_) if $self->storage->debug;
 397         $self->storage->dbh->do($_) or warn "SQL was:\n $_";
 398         $self->storage->debugobj->query_end($_) if $self->storage->debug;
 399     }
 400
 401     return 1;
 402 }
 403
 404 =head2 connection
 405
 406 Overloaded method. This checks the DBIC schema version against the DB version and
 407 warns if they are not the same or if the DB is unversioned. It also provides
 408 compatibility between the old versions table (SchemaVersions) and the new one
 409 (dbix_class_schema_versions).
 410
 411 To avoid the checks on connect, set the env var DBIC_NO_VERSION_CHECK. This can be
 412 useful for scripts.
 413
 414 =cut
 415
 416 sub connection {
 417   my $self = shift;
 418   $self->next::method(@_);
 419   $self->_on_connect;
 420   return $self;
 421 }
 422
 423 sub _on_connect
 424 {
 425   my ($self) = @_;
 426   $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
 427   my $vtable = $self->{vschema}->resultset('Table');
 428
 429   # check for legacy versions table and move to new if exists
 430   my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
 431   unless ($self->_source_exists($vtable)) {
 432     my $vtable_compat = $vschema_compat->resultset('TableCompat');
 433     if ($self->_source_exists($vtable_compat)) {
 434       $self->{vschema}->deploy;
 435       map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
 436       $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
 437     }
 438   }
 439
 440   # useful when connecting from scripts etc
 441   return if ($ENV{DBIC_NO_VERSION_CHECK});
 442
 443   my $pversion = $self->get_db_version();
 444
 445   if($pversion eq $self->schema_version)
 446     {
 447 #         warn "This version is already installed\n";
 448         return 1;
 449     }
 450
 451   if(!$pversion)
 452     {
 453         warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
 454         return 1;
 455     }
 456
 457   warn "Versions out of sync. This is " . $self->schema_version .
 458     ", your database contains version $pversion, please call upgrade on your Schema.\n";
 459 }
 460
 461 1;
 462
 463
 464 =head1 AUTHORS
 465
 466 Jess Robinson <castaway@desert-island.demon.co.uk>
 467 Luke Saunders <luke@shadowcatsystems.co.uk>
 468
 469 =head1 LICENSE
 470
 471 You may distribute this code under the same terms as Perl itself.