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