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     my $vtable = $self->{vschema}->resultset('Table');
  76     my $pversion;
  77
  78     if(!$self->_source_exists($vtable))
  79     {
  80 #        $self->{vschema}->storage->debug(1);
  81         $self->{vschema}->storage->ensure_connected();
  82         $self->{vschema}->deploy();
  83         $pversion = 0;
  84     }
  85     else
  86     {
  87       $pversion = $self->get_db_version();
  88     }
  89 #    warn("Previous version: $pversion\n");
  90     if($pversion eq $self->schema_version)
  91     {
  92         warn "This version is already installed\n";
  93         return 1;
  94     }
  95
  96 ## use IC::DT?
  97
  98     if(!$pversion)
  99     {
 100         $vtable->create({ Version => $self->schema_version,
 101                           Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
 102                           });
 103         ## If we let the user do this, where does the Version table get updated?
 104         warn "No previous version found, calling deploy to install this version.\n";
 105         $self->deploy();
 106         return 1;
 107     }
 108
 109     my $file = $self->ddl_filename(
 110                                    $self->storage->sqlt_type,
 111                                    $self->upgrade_directory,
 112                                    $self->schema_version
 113                                    );
 114     if(!$file)
 115     {
 116         # No upgrade path between these two versions
 117         return 1;
 118     }
 119
 120      $file = $self->ddl_filename(
 121                                  $self->storage->sqlt_type,
 122                                  $self->upgrade_directory,
 123                                  $self->schema_version,
 124                                  $pversion,
 125                                  );
 126 #    $file =~ s/@{[ $self->schema_version ]}/"${pversion}-" . $self->schema_version/e;
 127     if(!-f $file)
 128     {
 129         warn "Upgrade not possible, no upgrade file found ($file)\n";
 130         return;
 131     }
 132
 133     my $fh;
 134     open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
 135     my @data = split(/[;\n]/, join('', <$fh>));
 136     close($fh);
 137     @data = grep { $_ && $_ !~ /^-- / } @data;
 138     @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
 139
 140     $self->_filedata(\@data);
 141
 142     ## Don't do this yet, do only on command?
 143     ## If we do this later, where does the Version table get updated??
 144     warn "Versions out of sync. This is " . $self->schema_version .
 145         ", your database contains version $pversion, please call upgrade on your Schema.\n";
 146 #    $self->upgrade($pversion, $self->schema_version);
 147 }
 148
 149 sub get_db_version
 150 {
 151     my ($self, $rs) = @_;
 152
 153     my $vtable = $self->{vschema}->resultset('Table');
 154     my $psearch = $vtable->search(undef,
 155                                     { select => [
 156                                                  { 'max' => 'Installed' },
 157                                                  ],
 158                                           as => ['maxinstall'],
 159                                       })->first;
 160     my $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
 161                                 })->first;
 162     $pversion = $pversion->Version if($pversion);
 163     return $pversion;
 164 }
 165
 166 sub _source_exists
 167 {
 168     my ($self, $rs) = @_;
 169
 170     my $c = eval {
 171         $rs->search({ 1, 0 })->count;
 172     };
 173     return 0 if $@ || !defined $c;
 174
 175     return 1;
 176 }
 177
 178 sub backup
 179 {
 180     my ($self) = @_;
 181     ## Make each ::DBI::Foo do this
 182     $self->storage->backup($self->backup_directory());
 183 }
 184
 185 sub upgrade
 186 {
 187     my ($self) = @_;
 188
 189     $self->backup() if($self->do_backup);
 190
 191     $self->txn_do(sub {
 192       $self->do_upgrade();
 193     });
 194
 195     my $vtable = $self->{vschema}->resultset('Table');
 196     $vtable->create({ Version => $self->schema_version,
 197                       Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
 198                       });
 199
 200 }
 201
 202 sub do_upgrade
 203 {
 204     my ($self) = @_;
 205
 206     ## overridable sub, per default just run all the commands.
 207     $self->run_upgrade(qr/create/i);
 208     $self->run_upgrade(qr/alter table .*? add/i);
 209     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 210     $self->run_upgrade(qr/alter table .*? drop/i);
 211     $self->run_upgrade(qr/drop/i);
 212 }
 213
 214 sub run_upgrade
 215 {
 216     my ($self, $stm) = @_;
 217 #    print "Reg: $stm\n";
 218     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 219 #    print "Statements: ", join("\n", @statements), "\n";
 220     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 221
 222     for (@statements)
 223     {
 224         $self->storage->debugobj->query_start($_) if $self->storage->debug;
 225         $self->storage->dbh->do($_) or warn "SQL was:\n $_";
 226         $self->storage->debugobj->query_end($_) if $self->storage->debug;
 227     }
 228
 229     return 1;
 230 }
 231
 232 1;
 233
 234 =head1 NAME
 235
 236 DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades
 237
 238 =head1 SYNOPSIS
 239
 240   package Library::Schema;
 241   use base qw/DBIx::Class::Schema/;
 242   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
 243   __PACKAGE__->load_classes(qw/CD Book DVD/);
 244
 245   __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
 246   __PACKAGE__->upgrade_directory('/path/to/upgrades/');
 247   __PACKAGE__->backup_directory('/path/to/backups/');
 248
 249   sub backup
 250   {
 251     my ($self) = @_;
 252     # my special backup process
 253   }
 254
 255   sub upgrade
 256   {
 257     my ($self) = @_;
 258
 259     ## overridable sub, per default just runs all the commands.
 260
 261     $self->run_upgrade(qr/create/i);
 262     $self->run_upgrade(qr/alter table .*? add/i);
 263     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 264     $self->run_upgrade(qr/alter table .*? drop/i);
 265     $self->run_upgrade(qr/drop/i);
 266     $self->run_upgrade(qr//i);
 267   }
 268
 269 =head1 DESCRIPTION
 270
 271 This module is a component designed to extend L<DBIx::Class::Schema>
 272 classes, to enable them to upgrade to newer schema layouts. To use this
 273 module, you need to have called C<create_ddl_dir> on your Schema to
 274 create your upgrade files to include with your delivery.
 275
 276 A table called I<SchemaVersions> is created and maintained by the
 277 module. This contains two fields, 'Version' and 'Installed', which
 278 contain each VERSION of your Schema, and the date+time it was installed.
 279
 280 If you would like to influence which levels of version change need
 281 upgrades in your Schema, you can override the method C<ddl_filename>
 282 in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
 283 path between the two versions supplied. By default, every change in
 284 your VERSION is regarded as needing an upgrade.
 285
 286 The actual upgrade is called manually by calling C<upgrade> on your
 287 schema object. Code is run at connect time to determine whether an
 288 upgrade is needed, if so, a warning "Versions out of sync" is
 289 produced.
 290
 291 NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
 292 returns SQL statements that SQLite does not support.
 293
 294
 295 =head1 METHODS
 296
 297 =head2 backup
 298
 299 This is an overwritable method which is called just before the upgrade, to
 300 allow you to make a backup of the database. Per default this method attempts
 301 to call C<< $self->storage->backup >>, to run the standard backup on each
 302 database type.
 303
 304 This method should return the name of the backup file, if appropriate..
 305
 306 =head2 upgrade
 307
 308 This is the main upgrade method which calls the overridable do_upgrade and
 309 also handles the backups and updating of the SchemaVersion table.
 310
 311 =head2 do_upgrade
 312
 313 This is an overwritable method used to run your upgrade. The freeform method
 314 allows you to run your upgrade any way you please, you can call C<run_upgrade>
 315 any number of times to run the actual SQL commands, and in between you can
 316 sandwich your data upgrading. For example, first run all the B<CREATE>
 317 commands, then migrate your data from old to new tables/formats, then
 318 issue the DROP commands when you are finished.
 319
 320 =head2 run_upgrade
 321
 322  $self->run_upgrade(qr/create/i);
 323
 324 Runs a set of SQL statements matching a passed in regular expression. The
 325 idea is that this method can be called any number of times from your
 326 C<upgrade> method, running whichever commands you specify via the
 327 regex in the parameter.
 328
 329 =head2 upgrade_directory
 330
 331 Use this to set the directory your upgrade files are stored in.
 332
 333 =head2 backup_directory
 334
 335 Use this to set the directory you want your backups stored in.
 336
 337 =head2 schema_version
 338
 339 Returns the current schema class' $VERSION; does -not- use $schema->VERSION
 340 since that varies in results depending on if version.pm is installed, and if
 341 so the perl or XS versions. If you want this to change, bug the version.pm
 342 author to make vpp and vxs behave the same.
 343
 344 =head1 AUTHOR
 345
 346 Jess Robinson <castaway@desert-island.demon.co.uk>