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