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