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