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