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