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 sub upgrade
 147 {
 148     my ($self, $params) = @_;
 149     $params ||= {};
 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       if ($params->{create_diff}) {
 163         require SQL::Translator;
 164         require SQL::Translator::Diff;
 165         my $db_tr = SQL::Translator->new({
 166           add_drop_table => 1,
 167           parser => 'DBI',
 168           parser_args => { dbh => $self->storage->dbh }
 169         });
 170
 171         $db_tr->producer($db);
 172         my $dbic_tr = SQL::Translator->new;
 173         $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class');
 174         $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db);
 175         $dbic_tr->data($self);
 176         $dbic_tr->producer($db);
 177
 178         $db_tr->schema->name('db_schema');
 179         $dbic_tr->schema->name('dbic_schema');
 180
 181         # is this really necessary?
 182         foreach my $tr ($db_tr, $dbic_tr) {
 183           my $data = $tr->data;
 184           $tr->parser->($tr, $$data);
 185         }
 186
 187         my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db,
 188                                                       $dbic_tr->schema, $db,
 189                                                       { caseopt => 1 });
 190
 191         my $filename = $self->ddl_filename(
 192                                            $db,
 193                                            $self->upgrade_directory,
 194                                            $self->schema_version,
 195                                            'PRE',
 196                                            );
 197         my $file;
 198         if(!open($file, ">$filename")) {
 199           $self->throw_exception("Can't open $filename for writing ($!)");
 200           next;
 201         }
 202         print $file $diff;
 203         close($file);
 204
 205         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";
 206       }
 207
 208       # create versions table
 209       $self->{vschema}->deploy;
 210     } else {
 211       if ($db_version eq $self->schema_version) {
 212         print "Upgrade not necessary\n";
 213         return;
 214       }
 215
 216       my $file = $self->ddl_filename(
 217                                  $self->storage->sqlt_type,
 218                                  $self->upgrade_directory,
 219                                  $self->schema_version,
 220                                  $db_version,
 221                                  );
 222
 223       if(!-f $file)
 224       {
 225          warn "Upgrade not possible, no upgrade file found ($file)\n";
 226          return;
 227       }
 228
 229       my $fh;
 230       open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
 231       my @data = split(/\n/, join('', <$fh>));
 232       @data = grep(!/^--/, @data);
 233       @data = split(/;/, join('', @data));
 234       close($fh);
 235       @data = grep { $_ && $_ !~ /^-- / } @data;
 236       @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
 237
 238       $self->_filedata(\@data);
 239       $self->backup() if($self->do_backup);
 240
 241       $self->txn_do(sub {
 242         $self->do_upgrade();
 243       });
 244     }
 245
 246     my $vtable = $self->{vschema}->resultset('Table');
 247     $vtable->create({ Version => $self->schema_version,
 248                       Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
 249                       });
 250
 251 }
 252
 253 sub do_upgrade
 254 {
 255     my ($self) = @_;
 256
 257     ## overridable sub, per default just run all the commands.
 258     $self->run_upgrade(qr/create/i);
 259     $self->run_upgrade(qr/alter table .*? add/i);
 260     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 261     $self->run_upgrade(qr/alter table .*? drop/i);
 262     $self->run_upgrade(qr/drop/i);
 263 }
 264
 265 sub run_upgrade
 266 {
 267     my ($self, $stm) = @_;
 268 #    print "Reg: $stm\n";
 269     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 270 #    print "Statements: ", join("\n", @statements), "\n";
 271     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 272
 273     for (@statements)
 274     {
 275         $self->storage->debugobj->query_start($_) if $self->storage->debug;
 276         $self->storage->dbh->do($_) or warn "SQL was:\n $_";
 277         $self->storage->debugobj->query_end($_) if $self->storage->debug;
 278     }
 279
 280     return 1;
 281 }
 282
 283 1;
 284
 285 =head1 NAME
 286
 287 DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
 288
 289 =head1 SYNOPSIS
 290
 291   package Library::Schema;
 292   use base qw/DBIx::Class::Schema/;
 293   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
 294   __PACKAGE__->load_classes(qw/CD Book DVD/);
 295
 296   __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
 297   __PACKAGE__->upgrade_directory('/path/to/upgrades/');
 298   __PACKAGE__->backup_directory('/path/to/backups/');
 299
 300   sub backup
 301   {
 302     my ($self) = @_;
 303     # my special backup process
 304   }
 305
 306   sub upgrade
 307   {
 308     my ($self) = @_;
 309
 310     ## overridable sub, per default just runs all the commands.
 311
 312     $self->run_upgrade(qr/create/i);
 313     $self->run_upgrade(qr/alter table .*? add/i);
 314     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 315     $self->run_upgrade(qr/alter table .*? drop/i);
 316     $self->run_upgrade(qr/drop/i);
 317     $self->run_upgrade(qr//i);
 318   }
 319
 320 =head1 DESCRIPTION
 321
 322 This module is a component designed to extend L<DBIx::Class::Schema>
 323 classes, to enable them to upgrade to newer schema layouts. To use this
 324 module, you need to have called C<create_ddl_dir> on your Schema to
 325 create your upgrade files to include with your delivery.
 326
 327 A table called I<SchemaVersions> is created and maintained by the
 328 module. This contains two fields, 'Version' and 'Installed', which
 329 contain each VERSION of your Schema, and the date+time it was installed.
 330
 331 If you would like to influence which levels of version change need
 332 upgrades in your Schema, you can override the method C<ddl_filename>
 333 in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
 334 path between the two versions supplied. By default, every change in
 335 your VERSION is regarded as needing an upgrade.
 336
 337 The actual upgrade is called manually by calling C<upgrade> on your
 338 schema object. Code is run at connect time to determine whether an
 339 upgrade is needed, if so, a warning "Versions out of sync" is
 340 produced.
 341
 342 NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
 343 returns SQL statements that SQLite does not support.
 344
 345
 346 =head1 METHODS
 347
 348 =head2 backup
 349
 350 This is an overwritable method which is called just before the upgrade, to
 351 allow you to make a backup of the database. Per default this method attempts
 352 to call C<< $self->storage->backup >>, to run the standard backup on each
 353 database type.
 354
 355 This method should return the name of the backup file, if appropriate..
 356
 357 =head2 upgrade
 358
 359 This is the main upgrade method which calls the overridable do_upgrade and
 360 also handles the backups and updating of the SchemaVersion table.
 361
 362 =head2 do_upgrade
 363
 364 This is an overwritable method used to run your upgrade. The freeform method
 365 allows you to run your upgrade any way you please, you can call C<run_upgrade>
 366 any number of times to run the actual SQL commands, and in between you can
 367 sandwich your data upgrading. For example, first run all the B<CREATE>
 368 commands, then migrate your data from old to new tables/formats, then
 369 issue the DROP commands when you are finished.
 370
 371 =head2 run_upgrade
 372
 373  $self->run_upgrade(qr/create/i);
 374
 375 Runs a set of SQL statements matching a passed in regular expression. The
 376 idea is that this method can be called any number of times from your
 377 C<upgrade> method, running whichever commands you specify via the
 378 regex in the parameter.
 379
 380 =head2 upgrade_directory
 381
 382 Use this to set the directory your upgrade files are stored in.
 383
 384 =head2 backup_directory
 385
 386 Use this to set the directory you want your backups stored in.
 387
 388 =head2 schema_version
 389
 390 Returns the current schema class' $VERSION; does -not- use $schema->VERSION
 391 since that varies in results depending on if version.pm is installed, and if
 392 so the perl or XS versions. If you want this to change, bug the version.pm
 393 author to make vpp and vxs behave the same.
 394
 395 =head1 AUTHOR
 396
 397 Jess Robinson <castaway@desert-island.demon.co.uk>