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