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