lib/DBIx/Class/Schema/Versioned.pm

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