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::Versioning;
  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();
 127
 128 # X Create version table if not exists?
 129 # Make backup
 130 # Run create statements
 131 # Run post-create callback
 132 # Run alter/drop statement
 133 # Run post-alter callback
 134 }
 135
 136 sub exists
 137 {
 138     my ($self, $rs) = @_;
 139
 140     eval {
 141         $rs->search({ 1, 0 })->count;
 142     };
 143
 144     return 0 if $@;
 145
 146     return 1;
 147 }
 148
 149 sub backup
 150 {
 151     my ($self) = @_;
 152     ## Make each ::DBI::Foo do this
 153 #    $self->storage->backup();
 154 }
 155
 156 sub upgrade
 157 {
 158     my ($self) = @_;
 159
 160     ## overridable sub, per default just run all the commands.
 161
 162     $self->run_upgrade(qr/create/i);
 163     $self->run_upgrade(qr/alter table .*? add/i);
 164     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 165     $self->run_upgrade(qr/alter table .*? drop/i);
 166     $self->run_upgrade(qr/drop/i);
 167     $self->run_upgrade(qr//i);
 168 }
 169
 170
 171 sub run_upgrade
 172 {
 173     my ($self, $stm) = @_;
 174 #    print "Reg: $stm\n";
 175     my @statements = grep { $_ =~ $stm } @{$self->_filedata};
 176 #    print "Statements: ", join("\n", @statements), "\n";
 177     $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]);
 178
 179     for (@statements)
 180     {
 181         $self->storage->debugfh->print("$_\n") if $self->storage->debug;
 182 #        print "Running \n>>$_<<\n";
 183         $self->storage->dbh->do($_) or warn "SQL was:\n $_";
 184     }
 185
 186     return 1;
 187 }
 188
 189 =head1 NAME
 190
 191 DBIx::Class::Versioning - DBIx::Class::Schema plugin for Schema upgrades
 192
 193 =head1 SYNOPSIS
 194
 195   package Library::Schema;
 196   use base qw/DBIx::Class::Schema/;
 197   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
 198   __PACKAGE__->load_classes(qw/CD Book DVD/);
 199
 200   __PACKAGE__->load_components(qw/Versioning/);
 201   __PACKAGE__->upgrade_directory('/path/to/upgrades/');
 202
 203   sub backup
 204   {
 205     my ($self) = @_;
 206     # my special backup process
 207   }
 208
 209   sub upgrade
 210   {
 211     my ($self) = @_;
 212
 213     ## overridable sub, per default just runs all the commands.
 214
 215     $self->run_upgrade(qr/create/i);
 216     $self->run_upgrade(qr/alter table .*? add/i);
 217     $self->run_upgrade(qr/alter table .*? (?!drop)/i);
 218     $self->run_upgrade(qr/alter table .*? drop/i);
 219     $self->run_upgrade(qr/drop/i);
 220     $self->run_upgrade(qr//i);
 221   }
 222
 223 =head1 DESCRIPTION
 224
 225 This module is a component designed to extend L<DBIx::Class::Schema>
 226 classes, to enable them to upgrade to newer schema layouts. To use this
 227 module, you need to have called C<create_ddl_dir> on your Schema to
 228 create your upgrade files to include with your delivery.
 229
 230 A table called I<SchemaVersions> is created and maintained by the
 231 module. This contains two fields, 'Version' and 'Installed', which
 232 contain each VERSION of your Schema, and the date+time it was installed.
 233
 234 If you would like to influence which levels of version change need
 235 upgrades in your Schema, you can override the method C<ddl_filename>
 236 in L<DBIx::Class::Schema>. Return a false value if there is no upgrade
 237 path between the two versions supplied. By default, every change in
 238 your VERSION is regarded as needing an upgrade.
 239
 240
 241 =head1 METHODS
 242
 243 =head2 backup
 244
 245 This is an overwritable method which is called just before the upgrade, to
 246 allow you to make a backup of the database. Per default this method attempts
 247 to call C<< $self->storage->backup >>, to run the standard backup on each
 248 database type.
 249
 250 =head2 upgrade
 251
 252 This is an overwritable method used to run your upgrade. The freeform method
 253 allows you to run your upgrade any way you please, you can call C<run_upgrade>
 254 any number of times to run the actual SQL commands, and in between you can
 255 sandwich your data upgrading. For example, first run all the B<CREATE>
 256 commands, then migrate your data from old to new tables/formats, then
 257 issue the DROP commands when you are finished.
 258
 259 =head2 run_upgrade
 260
 261  $self->run_upgrade(qr/create/i);
 262
 263 Runs a set of SQL statements matching a passed in regular expression. The
 264 idea is that this method can be called any number of times from your
 265 C<upgrade> method, running whichever commands you specify via the
 266 regex in the parameter.
 267
 268 =head1 AUTHOR
 269
 270 Jess Robinson <castaway@desert-island.demon.co.uk>