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 # use DBIx::Class::Version;
  48
  49 __PACKAGE__->mk_classdata('_filedata');
  50 __PACKAGE__->mk_classdata('upgrade_directory');
  51
  52 sub on_connect
  53 {
  54     my ($self) = @_;
  55 #    print "on_connect\n";
  56     my $vschema = DBIx::Class::Version->connect(@{$self->storage->connect_info()});
  57     my $vtable = $vschema->resultset('Table');
  58     my $pversion;
  59     if(!$self->exists($vtable))
  60     {
  61 #        print "deploying.. \n";
  62         $vschema->storage->debug(1);
  63 #        print "Debugging is: ", $vschema->storage->debug, "\n";
  64         $vschema->deploy();
  65         $pversion = 0;
  66     }
  67     else
  68     {
  69         my $psearch = $vtable->search(undef,
  70                                       { select => [
  71                                                    { 'max' => 'Installed' },
  72                                                    ],
  73                                             as => ['maxinstall'],
  74                                         })->first;
  75         $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'),
  76                                   })->first;
  77         $pversion = $pversion->Version if($pversion);
  78     }
  79 #    warn("Previous version: $pversion\n");
  80     if($pversion eq $self->VERSION)
  81     {
  82         warn "This version is already installed\n";
  83         return 1;
  84     }
  85
  86
  87     $vtable->create({ Version => $self->VERSION,
  88                       Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime())
  89                       });
  90
  91     if(!$pversion)
  92     {
  93         warn "No previous version found, skipping upgrade\n";
  94         return 1;
  95     }
  96
  97 #    $self->create_upgrades($self->upgrade_directoy, $pversion, $self->VERSION);
  98
  99     my $file = $self->ddl_filename($self->upgrade_directory,
 100                                    $self->storage->sqlt_type,
 101                                    $self->VERSION
 102                                    );
 103     if(!$file)
 104     {
 105         # No upgrade path between these two versions
 106         return 1;
 107     }
 108
 109     $file =~ s/@{[ $self->VERSION ]}/"${pversion}-" . $self->VERSION/e;
 110     if(!-f $file)
 111     {
 112         warn "Upgrade not possible, no upgrade file found ($file)\n";
 113         return;
 114     }
 115 #    print "Found Upgrade file: $file\n";
 116     my $fh;
 117     open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)");
 118     my @data = split(/;\n/, join('', <$fh>));
 119     close($fh);
 120     @data = grep { $_ && $_ !~ /^-- / } @data;
 121     @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data;
 122 #    print "Commands: ", join("\n", @data), "\n";
 123     $self->_filedata(\@data);
 124
 125     $self->backup();
 126     $self->upgrade($pversion, $self->VERSION);
 127
 128 }
 129
 130 sub exists
 131 {
 132     my ($self, $rs) = @_;
 133
 134     eval {
 135         $rs->search({ 1, 0 })->count;
 136     };
 137     return 0 if $@;
 138
 139     return 1;
 140 }
 141
 142 sub backup
 143 {
 144     my ($self) = @_;
 145     ## Make each ::DBI::Foo do this
 146     $self->storage->backup();
 147 }
 148
 149 sub upgrade
 150 {
 151     my ($self) = @_;
 152
 153     ## overridable sub, per default just run all the commands.
 154
 155     $self->run_upgrade(qr/create/i);
 156     $self->run_upgrade(qr/alter table .*? add/i);
 157     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 158     $self->run_upgrade(qr/alter table .*? drop/i);
 159     $self->run_upgrade(qr/drop/i);
 160     $self->run_upgrade(qr//i);
 161 }
 162
 163
 164 sub run_upgrade
 165 {
 166     my ($self, $stm) = @_;
 167 #    print "Reg: $stm\n";
 168     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 169 #    print "Statements: ", join("\n", @statements), "\n";
 170     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 171
 172     for (@statements)
 173     {
 174         $self->storage->debugfh->print("$_\n") if $self->storage->debug;
 175 #        print "Running \n>>$_<<\n";
 176         $self->storage->dbh->do($_) or warn "SQL was:\n $_";
 177     }
 178
 179     return 1;
 180 }
 181
 182 =head1 NAME
 183
 184 DBIx::Class::Versioning - DBIx::Class::Schema plugin for Schema upgrades
 185
 186 =head1 SYNOPSIS
 187
 188   package Library::Schema;
 189   use base qw/DBIx::Class::Schema/;
 190   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
 191   __PACKAGE__->load_classes(qw/CD Book DVD/);
 192
 193   __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/);
 194   __PACKAGE__->upgrade_directory('/path/to/upgrades/');
 195
 196   sub backup
 197   {
 198     my ($self) = @_;
 199     # my special backup process
 200   }
 201
 202   sub upgrade
 203   {
 204     my ($self) = @_;
 205
 206     ## overridable sub, per default just runs all the commands.
 207
 208     $self->run_upgrade(qr/create/i);
 209     $self->run_upgrade(qr/alter table .*? add/i);
 210     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 211     $self->run_upgrade(qr/alter table .*? drop/i);
 212     $self->run_upgrade(qr/drop/i);
 213     $self->run_upgrade(qr//i);
 214   }
 215
 216 =head1 DESCRIPTION
 217
 218 This module is a component designed to extend L<DBIx::Class::Schema>
 219 classes, to enable them to upgrade to newer schema layouts. To use this
 220 module, you need to have called C<create_ddl_dir> on your Schema to
 221 create your upgrade files to include with your delivery.
 222
 223 A table called I<SchemaVersions> is created and maintained by the
 224 module. This contains two fields, 'Version' and 'Installed', which
 225 contain each VERSION of your Schema, and the date+time it was installed.
 226
 227 If you would like to influence which levels of version change need
 228 upgrades in your Schema, you can override the method C<ddl_filename>
 229 in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
 230 path between the two versions supplied. By default, every change in
 231 your VERSION is regarded as needing an upgrade.
 232
 233 NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff
 234 returns SQL statements that SQLite does not support.
 235
 236
 237 =head1 METHODS
 238
 239 =head2 backup
 240
 241 This is an overwritable method which is called just before the upgrade, to
 242 allow you to make a backup of the database. Per default this method attempts
 243 to call C<< $self->storage->backup >>, to run the standard backup on each
 244 database type.
 245
 246 This method should return the name of the backup file, if appropriate.
 247
 248 =head2 upgrade
 249
 250 This is an overwritable method used to run your upgrade. The freeform method
 251 allows you to run your upgrade any way you please, you can call C<run_upgrade>
 252 any number of times to run the actual SQL commands, and in between you can
 253 sandwich your data upgrading. For example, first run all the B<CREATE>
 254 commands, then migrate your data from old to new tables/formats, then
 255 issue the DROP commands when you are finished.
 256
 257 =head2 run_upgrade
 258
 259  $self->run_upgrade(qr/create/i);
 260
 261 Runs a set of SQL statements matching a passed in regular expression. The
 262 idea is that this method can be called any number of times from your
 263 C<upgrade> method, running whichever commands you specify via the
 264 regex in the parameter.
 265
 266 =head1 AUTHOR
 267
 268 Jess Robinson <castaway@desert-island.demon.co.uk>