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