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