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 This method is disabled by default. Set $schema->do_backup(1) to enable it.
 194
 195 =cut
 196
 197 sub backup
 198 {
 199     my ($self) = @_;
 200     ## Make each ::DBI::Foo do this
 201     $self->storage->backup($self->backup_directory());
 202 }
 203
 204 # is this just a waste of time? if not then merge with DBI.pm
 205 sub _create_db_to_schema_diff {
 206   my $self = shift;
 207
 208   my %driver_to_db_map = (
 209                           'mysql' => 'MySQL'
 210                          );
 211
 212   my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}};
 213   unless ($db) {
 214     print "Sorry, this is an unsupported DB\n";
 215     return;
 216   }
 217
 218   eval 'require SQL::Translator "0.09"';
 219   if ($@) {
 220     $self->throw_exception("SQL::Translator 0.09 required");
 221   }
 222
 223   my $db_tr = SQL::Translator->new({
 224                                     add_drop_table => 1,
 225                                     parser => 'DBI',
 226                                     parser_args => { dbh => $self->storage->dbh }
 227                                    });
 228
 229   $db_tr->producer($db);
 230   my $dbic_tr = SQL::Translator->new;
 231   $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
 232   $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
 233   $dbic_tr->data($self);
 234   $dbic_tr->producer($db);
 235
 236   $db_tr->schema->name('db_schema');
 237   $dbic_tr->schema->name('dbic_schema');
 238
 239   # is this really necessary?
 240   foreach my $tr ($db_tr, $dbic_tr) {
 241     my $data = $tr->data;
 242     $tr->parser->($tr, $$data);
 243   }
 244
 245   my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
 246                                                 $dbic_tr->schema, $db,
 247                                                 { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 });
 248
 249   my $filename = $self->ddl_filename(
 250                                          $db,
 251                                          $self->schema_version,
 252                                          $self->upgrade_directory,
 253                                          'PRE',
 254                                     );
 255   my $file;
 256   if(!open($file, ">$filename"))
 257     {
 258       $self->throw_exception("Can't open $filename for writing ($!)");
 259       next;
 260     }
 261   print $file $diff;
 262   close($file);
 263
 264   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";
 265 }
 266
 267 =head2 upgrade
 268
 269 Call this to attempt to upgrade your database from the version it is at to the version
 270 this DBIC schema is at.
 271
 272 It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will
 273 have created this using $schema->create_ddl_dir.
 274
 275 =cut
 276
 277 sub upgrade
 278 {
 279   my ($self) = @_;
 280   my $db_version = $self->get_db_version();
 281
 282   # db unversioned
 283   unless ($db_version) {
 284     # set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at
 285     $self->_create_db_to_schema_diff() if ($self->do_diff_on_init);
 286
 287     # create versions table and version row
 288     $self->{vschema}->deploy;
 289     $self->_set_db_version;
 290     return;
 291   }
 292
 293   # db and schema at same version. do nothing
 294   if ($db_version eq $self->schema_version) {
 295     print "Upgrade not necessary\n";
 296     return;
 297   }
 298
 299   # strangely the first time this is called can
 300   # differ to subsequent times. so we call it
 301   # here to be sure.
 302   # XXX - just fix it
 303   $self->storage->sqlt_type;
 304
 305   my $upgrade_file = $self->ddl_filename(
 306                                          $self->storage->sqlt_type,
 307                                          $self->schema_version,
 308                                          $self->upgrade_directory,
 309                                          $db_version,
 310                                         );
 311
 312   unless (-f $upgrade_file) {
 313     warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n";
 314     return;
 315   }
 316
 317   # backup if necessary then apply upgrade
 318   $self->_filedata($self->_read_sql_file($upgrade_file));
 319   $self->backup() if($self->do_backup);
 320   $self->txn_do(sub { $self->do_upgrade() });
 321
 322   # set row in dbix_class_schema_versions table
 323   $self->_set_db_version;
 324 }
 325
 326 sub _set_db_version {
 327   my $self = shift;
 328
 329   my $vtable = $self->{vschema}->resultset('Table');
 330   $vtable->create({ version => $self->schema_version,
 331                       installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
 332                       });
 333
 334 }
 335
 336 sub _read_sql_file {
 337   my $self = shift;
 338   my $file = shift || return;
 339
 340   my $fh;
 341   open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
 342   my @data = split(/\n/, join('', <$fh>));
 343   @data = grep(!/^--/, @data);
 344   @data = split(/;/, join('', @data));
 345   close($fh);
 346   @data = grep { $_ && $_ !~ /^-- / } @data;
 347   @data = grep { $_ !~ /^(BEGIN TRANSACTION|COMMIT)/m } @data;
 348   return \@data;
 349 }
 350
 351 =head2 do_upgrade
 352
 353 This is an overwritable method used to run your upgrade. The freeform method
 354 allows you to run your upgrade any way you please, you can call C<run_upgrade>
 355 any number of times to run the actual SQL commands, and in between you can
 356 sandwich your data upgrading. For example, first run all the B<CREATE>
 357 commands, then migrate your data from old to new tables/formats, then
 358 issue the DROP commands when you are finished. Will run the whole file as it is by default.
 359
 360 =cut
 361
 362 sub do_upgrade
 363 {
 364   my ($self) = @_;
 365
 366   # just run all the commands (including inserts) in order
 367   $self->run_upgrade(qr/.*?/);
 368 }
 369
 370 =head2 run_upgrade
 371
 372  $self->run_upgrade(qr/create/i);
 373
 374 Runs a set of SQL statements matching a passed in regular expression. The
 375 idea is that this method can be called any number of times from your
 376 C<upgrade> method, running whichever commands you specify via the
 377 regex in the parameter. Probably won't work unless called from the overridable
 378 do_upgrade method.
 379
 380 =cut
 381
 382 sub run_upgrade
 383 {
 384     my ($self, $stm) = @_;
 385
 386     return unless ($self->_filedata);
 387     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 388     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 389
 390     for (@statements)
 391     {
 392         $self->storage->debugobj->query_start($_) if $self->storage->debug;
 393         $self->storage->dbh->do($_) or warn "SQL was:\n $_";
 394         $self->storage->debugobj->query_end($_) if $self->storage->debug;
 395     }
 396
 397     return 1;
 398 }
 399
 400 =head2 connection
 401
 402 Overloaded method. This checks the DBIC schema version against the DB version and
 403 warns if they are not the same or if the DB is unversioned. It also provides
 404 compatibility between the old versions table (SchemaVersions) and the new one
 405 (dbix_class_schema_versions).
 406
 407 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 arg like so:
 408
 409   my $schema = MyApp::Schema->connect(
 410     $dsn,
 411     $user,
 412     $password,
 413     { ignore_version => 1 },
 414   );
 415
 416 =cut
 417
 418 sub connection {
 419   my $self = shift;
 420   $self->next::method(@_);
 421   $self->_on_connect($_[3]);
 422   return $self;
 423 }
 424
 425 sub _on_connect
 426 {
 427   my ($self, $args) = @_;
 428
 429   $args = {} unless $args;
 430   $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
 431   my $vtable = $self->{vschema}->resultset('Table');
 432
 433   # check for legacy versions table and move to new if exists
 434   my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()});
 435   unless ($self->_source_exists($vtable)) {
 436     my $vtable_compat = $vschema_compat->resultset('TableCompat');
 437     if ($self->_source_exists($vtable_compat)) {
 438       $self->{vschema}->deploy;
 439       map { $vtable->create({ installed => $_->Installed, version => $_->Version }) } $vtable_compat->all;
 440       $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from);
 441     }
 442   }
 443
 444   # useful when connecting from scripts etc
 445   return if ($args->{ignore_version} || ($ENV{DBIC_NO_VERSION_CHECK} && !exists $args->{ignore_version}));
 446   my $pversion = $self->get_db_version();
 447
 448   if($pversion eq $self->schema_version)
 449     {
 450 #         warn "This version is already installed\n";
 451         return 1;
 452     }
 453
 454   if(!$pversion)
 455     {
 456         warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n";
 457         return 1;
 458     }
 459
 460   warn "Versions out of sync. This is " . $self->schema_version .
 461     ", your database contains version $pversion, please call upgrade on your Schema.\n";
 462 }
 463
 464 1;
 465
 466
 467 =head1 AUTHORS
 468
 469 Jess Robinson <castaway@desert-island.demon.co.uk>
 470 Luke Saunders <luke@shadowcatsystems.co.uk>
 471
 472 =head1 LICENSE
 473
 474 You may distribute this code under the same terms as Perl itself.