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