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