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