Commit | Line | Data |
c9d2e0a2 |
1 | package DBIx::Class::Version::Table; |
2 | use base 'DBIx::Class'; |
3 | use strict; |
4 | use warnings; |
5 | |
6 | __PACKAGE__->load_components(qw/ Core/); |
b4b1e91c |
7 | __PACKAGE__->table('dbix_class_schema_versions'); |
c9d2e0a2 |
8 | |
ad1446da |
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 | }, |
c9d2e0a2 |
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' |
ad1446da |
27 | }, |
28 | ); |
c9d2e0a2 |
29 | __PACKAGE__->set_primary_key('Version'); |
30 | |
b4b1e91c |
31 | package DBIx::Class::Version::TableCompat; |
32 | use base 'DBIx::Class::Version::Table'; |
33 | |
34 | __PACKAGE__->table('SchemaVersions'); |
35 | |
c9d2e0a2 |
36 | package DBIx::Class::Version; |
37 | use base 'DBIx::Class::Schema'; |
38 | use strict; |
39 | use warnings; |
40 | |
41 | __PACKAGE__->register_class('Table', 'DBIx::Class::Version::Table'); |
42 | |
b4b1e91c |
43 | package DBIx::Class::VersionCompat; |
44 | use base 'DBIx::Class::Schema'; |
45 | use strict; |
46 | use warnings; |
47 | |
48 | __PACKAGE__->register_class('TableCompat', 'DBIx::Class::Version::TableCompat'); |
49 | |
c9d2e0a2 |
50 | |
51 | # --------------------------------------------------------------------------- |
8424c090 |
52 | |
53 | =head1 NAME |
54 | |
55 | DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades |
56 | |
57 | =head1 SYNOPSIS |
58 | |
59 | package Library::Schema; |
60 | use base qw/DBIx::Class::Schema/; |
61 | # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD |
62 | __PACKAGE__->load_classes(qw/CD Book DVD/); |
63 | |
64 | __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/); |
65 | __PACKAGE__->upgrade_directory('/path/to/upgrades/'); |
66 | __PACKAGE__->backup_directory('/path/to/backups/'); |
67 | |
68 | |
69 | =head1 DESCRIPTION |
70 | |
71 | This module is a component designed to extend L<DBIx::Class::Schema> |
72 | classes, to enable them to upgrade to newer schema layouts. To use this |
73 | module, you need to have called C<create_ddl_dir> on your Schema to |
74 | create your upgrade files to include with your delivery. |
75 | |
b4b1e91c |
76 | A table called I<dbix_class_schema_versions> is created and maintained by the |
8424c090 |
77 | module. This contains two fields, 'Version' and 'Installed', which |
78 | contain each VERSION of your Schema, and the date+time it was installed. |
79 | |
80 | The actual upgrade is called manually by calling C<upgrade> on your |
81 | schema object. Code is run at connect time to determine whether an |
82 | upgrade is needed, if so, a warning "Versions out of sync" is |
83 | produced. |
84 | |
85 | So you'll probably want to write a script which generates your DDLs and diffs |
86 | and another which executes the upgrade. |
87 | |
88 | NB: At the moment, only SQLite and MySQL are supported. This is due to |
89 | spotty behaviour in the SQL::Translator producers, please help us by |
90 | them. |
91 | |
92 | =head1 METHODS |
93 | |
94 | =head2 upgrade_directory |
95 | |
96 | Use this to set the directory your upgrade files are stored in. |
97 | |
98 | =head2 backup_directory |
99 | |
100 | Use this to set the directory you want your backups stored in. |
101 | |
102 | =cut |
103 | |
c9d2e0a2 |
104 | package DBIx::Class::Schema::Versioned; |
105 | |
106 | use strict; |
107 | use warnings; |
108 | use base 'DBIx::Class'; |
109 | use POSIX 'strftime'; |
110 | use Data::Dumper; |
111 | |
112 | __PACKAGE__->mk_classdata('_filedata'); |
113 | __PACKAGE__->mk_classdata('upgrade_directory'); |
8795fefb |
114 | __PACKAGE__->mk_classdata('backup_directory'); |
f925f7cb |
115 | __PACKAGE__->mk_classdata('do_backup'); |
8424c090 |
116 | __PACKAGE__->mk_classdata('do_diff_on_init'); |
117 | |
118 | =head2 schema_version |
119 | |
120 | Returns the current schema class' $VERSION; does -not- use $schema->VERSION |
121 | since that varies in results depending on if version.pm is installed, and if |
122 | so the perl or XS versions. If you want this to change, bug the version.pm |
123 | author to make vpp and vxs behave the same. |
124 | |
125 | =cut |
c9d2e0a2 |
126 | |
42416a0b |
127 | sub schema_version { |
128 | my ($self) = @_; |
129 | my $class = ref($self)||$self; |
130 | my $version; |
131 | { |
132 | no strict 'refs'; |
133 | $version = ${"${class}::VERSION"}; |
134 | } |
135 | return $version; |
136 | } |
137 | |
8424c090 |
138 | =head2 get_db_version |
c9d2e0a2 |
139 | |
8424c090 |
140 | Returns the version that your database is currently at. This is determined by the values in the |
b4b1e91c |
141 | dbix_class_schema_versions table that $self->upgrade writes to. |
c9d2e0a2 |
142 | |
8424c090 |
143 | =cut |
c9d2e0a2 |
144 | |
e6129e56 |
145 | sub get_db_version |
146 | { |
147 | my ($self, $rs) = @_; |
148 | |
149 | my $vtable = $self->{vschema}->resultset('Table'); |
0d865134 |
150 | return 0 unless ($self->_source_exists($vtable)); |
151 | |
e6129e56 |
152 | my $psearch = $vtable->search(undef, |
153 | { select => [ |
154 | { 'max' => 'Installed' }, |
155 | ], |
156 | as => ['maxinstall'], |
157 | })->first; |
f925f7cb |
158 | my $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'), |
e6129e56 |
159 | })->first; |
160 | $pversion = $pversion->Version if($pversion); |
161 | return $pversion; |
162 | } |
163 | |
a2800991 |
164 | sub _source_exists |
c9d2e0a2 |
165 | { |
166 | my ($self, $rs) = @_; |
167 | |
168 | my $c = eval { |
169 | $rs->search({ 1, 0 })->count; |
170 | }; |
171 | return 0 if $@ || !defined $c; |
172 | |
173 | return 1; |
174 | } |
175 | |
8424c090 |
176 | =head2 backup |
177 | |
178 | This is an overwritable method which is called just before the upgrade, to |
179 | allow you to make a backup of the database. Per default this method attempts |
180 | to call C<< $self->storage->backup >>, to run the standard backup on each |
181 | database type. |
182 | |
183 | This method should return the name of the backup file, if appropriate.. |
184 | |
185 | =cut |
186 | |
c9d2e0a2 |
187 | sub backup |
188 | { |
189 | my ($self) = @_; |
190 | ## Make each ::DBI::Foo do this |
8795fefb |
191 | $self->storage->backup($self->backup_directory()); |
c9d2e0a2 |
192 | } |
193 | |
b6d9f089 |
194 | # is this just a waste of time? if not then merge with DBI.pm |
8424c090 |
195 | sub _create_db_to_schema_diff { |
196 | my $self = shift; |
c9d2e0a2 |
197 | |
8424c090 |
198 | my %driver_to_db_map = ( |
199 | 'mysql' => 'MySQL' |
200 | ); |
e6129e56 |
201 | |
8424c090 |
202 | my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}}; |
203 | unless ($db) { |
204 | print "Sorry, this is an unsupported DB\n"; |
205 | return; |
206 | } |
c9d2e0a2 |
207 | |
b6d9f089 |
208 | eval 'require SQL::Translator "0.09"'; |
209 | if ($@) { |
210 | $self->throw_exception("SQL::Translator 0.09 required"); |
211 | } |
8424c090 |
212 | |
213 | my $db_tr = SQL::Translator->new({ |
214 | add_drop_table => 1, |
215 | parser => 'DBI', |
216 | parser_args => { dbh => $self->storage->dbh } |
217 | }); |
218 | |
219 | $db_tr->producer($db); |
220 | my $dbic_tr = SQL::Translator->new; |
221 | $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class'); |
222 | $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db); |
223 | $dbic_tr->data($self); |
224 | $dbic_tr->producer($db); |
225 | |
226 | $db_tr->schema->name('db_schema'); |
227 | $dbic_tr->schema->name('dbic_schema'); |
228 | |
229 | # is this really necessary? |
230 | foreach my $tr ($db_tr, $dbic_tr) { |
231 | my $data = $tr->data; |
232 | $tr->parser->($tr, $$data); |
233 | } |
c9d2e0a2 |
234 | |
8424c090 |
235 | my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db, |
236 | $dbic_tr->schema, $db, |
237 | { ignore_constraint_names => 1, ignore_index_names => 1, caseopt => 1 }); |
238 | |
239 | my $filename = $self->ddl_filename( |
240 | $db, |
241 | $self->upgrade_directory, |
242 | $self->schema_version, |
243 | 'PRE', |
244 | ); |
245 | my $file; |
246 | if(!open($file, ">$filename")) |
247 | { |
248 | $self->throw_exception("Can't open $filename for writing ($!)"); |
249 | next; |
c9d2e0a2 |
250 | } |
8424c090 |
251 | print $file $diff; |
252 | close($file); |
c9d2e0a2 |
253 | |
8424c090 |
254 | print "WARNING: There may be differences between your DB and your DBIC schema. Please review and if necessary run the SQL in $filename to sync your DB.\n"; |
c9d2e0a2 |
255 | } |
256 | |
8424c090 |
257 | =head2 upgrade |
e2c0df8e |
258 | |
8424c090 |
259 | Call this to attempt to upgrade your database from the version it is at to the version |
260 | this DBIC schema is at. |
c9d2e0a2 |
261 | |
8424c090 |
262 | It requires an SQL diff file to exist in $schema->upgrade_directory, normally you will |
263 | have created this using $schema->create_ddl_dir. |
c9d2e0a2 |
264 | |
8424c090 |
265 | =cut |
c9d2e0a2 |
266 | |
8424c090 |
267 | sub upgrade |
268 | { |
269 | my ($self) = @_; |
270 | my $db_version = $self->get_db_version(); |
c9d2e0a2 |
271 | |
8424c090 |
272 | # db unversioned |
273 | unless ($db_version) { |
b4b1e91c |
274 | # set version in dbix_class_schema_versions table, can't actually upgrade as we don 't know what version the DB is at |
8424c090 |
275 | $self->_create_db_to_schema_diff() if ($self->do_diff_on_init); |
c9d2e0a2 |
276 | |
8424c090 |
277 | # create versions table and version row |
278 | $self->{vschema}->deploy; |
279 | $self->_set_db_version; |
280 | return; |
c9d2e0a2 |
281 | } |
282 | |
8424c090 |
283 | # db and schema at same version. do nothing |
284 | if ($db_version eq $self->schema_version) { |
285 | print "Upgrade not necessary\n"; |
286 | return; |
c9d2e0a2 |
287 | } |
288 | |
37fcb5b5 |
289 | # strangely the first time this is called can |
290 | # differ to subsequent times. so we call it |
291 | # here to be sure. |
292 | # XXX - just fix it |
293 | $self->storage->sqlt_type; |
294 | |
8424c090 |
295 | my $upgrade_file = $self->ddl_filename( |
296 | $self->storage->sqlt_type, |
297 | $self->upgrade_directory, |
298 | $self->schema_version, |
299 | $db_version, |
300 | ); |
c9d2e0a2 |
301 | |
8424c090 |
302 | unless (-f $upgrade_file) { |
303 | warn "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n"; |
304 | return; |
305 | } |
c9d2e0a2 |
306 | |
8424c090 |
307 | # backup if necessary then apply upgrade |
308 | $self->_filedata($self->_read_sql_file($upgrade_file)); |
309 | $self->backup() if($self->do_backup); |
310 | $self->txn_do(sub { $self->do_upgrade() }); |
c9d2e0a2 |
311 | |
b4b1e91c |
312 | # set row in dbix_class_schema_versions table |
8424c090 |
313 | $self->_set_db_version; |
314 | } |
c9d2e0a2 |
315 | |
8424c090 |
316 | sub _set_db_version { |
317 | my $self = shift; |
c9d2e0a2 |
318 | |
8424c090 |
319 | my $vtable = $self->{vschema}->resultset('Table'); |
320 | $vtable->create({ Version => $self->schema_version, |
321 | Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime()) |
322 | }); |
c9d2e0a2 |
323 | |
8424c090 |
324 | } |
c9d2e0a2 |
325 | |
8424c090 |
326 | sub _read_sql_file { |
327 | my $self = shift; |
328 | my $file = shift || return; |
329 | |
330 | my $fh; |
331 | open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)"); |
d89d8604 |
332 | my @data = split(/\n/, join('', <$fh>)); |
333 | @data = grep(!/^--/, @data); |
334 | @data = split(/;/, join('', @data)); |
8424c090 |
335 | close($fh); |
336 | @data = grep { $_ && $_ !~ /^-- / } @data; |
337 | @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data; |
338 | return \@data; |
339 | } |
e6129e56 |
340 | |
341 | =head2 do_upgrade |
342 | |
c9d2e0a2 |
343 | This is an overwritable method used to run your upgrade. The freeform method |
344 | allows you to run your upgrade any way you please, you can call C<run_upgrade> |
345 | any number of times to run the actual SQL commands, and in between you can |
346 | sandwich your data upgrading. For example, first run all the B<CREATE> |
347 | commands, then migrate your data from old to new tables/formats, then |
348 | issue the DROP commands when you are finished. |
349 | |
8424c090 |
350 | Will run the whole file as it is by default. |
351 | |
352 | =cut |
353 | |
354 | sub do_upgrade |
355 | { |
356 | my ($self) = @_; |
357 | |
358 | ## overridable sub, per default just run all the commands. |
359 | $self->run_upgrade(qr/create/i); |
360 | $self->run_upgrade(qr/alter table .*? add/i); |
361 | $self->run_upgrade(qr/alter table .*? (?!drop)/i); |
362 | $self->run_upgrade(qr/alter table .*? drop/i); |
363 | $self->run_upgrade(qr/drop/i); |
364 | } |
365 | |
c9d2e0a2 |
366 | =head2 run_upgrade |
367 | |
368 | $self->run_upgrade(qr/create/i); |
369 | |
370 | Runs a set of SQL statements matching a passed in regular expression. The |
371 | idea is that this method can be called any number of times from your |
372 | C<upgrade> method, running whichever commands you specify via the |
8424c090 |
373 | regex in the parameter. Probably won't work unless called from the overridable |
374 | do_upgrade method. |
c9d2e0a2 |
375 | |
8424c090 |
376 | =cut |
8795fefb |
377 | |
8424c090 |
378 | sub run_upgrade |
379 | { |
380 | my ($self, $stm) = @_; |
8795fefb |
381 | |
8424c090 |
382 | return unless ($self->_filedata); |
383 | my @statements = grep { $_ =~ $stm } @{$self->_filedata}; |
384 | $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]); |
8795fefb |
385 | |
8424c090 |
386 | for (@statements) |
387 | { |
388 | $self->storage->debugobj->query_start($_) if $self->storage->debug; |
389 | $self->storage->dbh->do($_) or warn "SQL was:\n $_"; |
390 | $self->storage->debugobj->query_end($_) if $self->storage->debug; |
391 | } |
8795fefb |
392 | |
8424c090 |
393 | return 1; |
394 | } |
42416a0b |
395 | |
8424c090 |
396 | sub connection { |
397 | my $self = shift; |
398 | $self->next::method(@_); |
399 | $self->_on_connect; |
400 | return $self; |
401 | } |
402 | |
403 | sub _on_connect |
404 | { |
405 | my ($self) = @_; |
406 | $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()}); |
b4b1e91c |
407 | my $vtable = $self->{vschema}->resultset('Table'); |
408 | |
409 | # check for legacy versions table and move to new if exists |
410 | my $vschema_compat = DBIx::Class::VersionCompat->connect(@{$self->storage->connect_info()}); |
411 | unless ($self->_source_exists($vtable)) { |
412 | my $vtable_compat = $vschema_compat->resultset('TableCompat'); |
413 | if ($self->_source_exists($vtable_compat)) { |
414 | $self->{vschema}->deploy; |
415 | map { $vtable->create({$_->get_columns}) } $vtable_compat->all; |
416 | $self->storage->dbh->do("DROP TABLE " . $vtable_compat->result_source->from); |
417 | } |
418 | } |
8424c090 |
419 | |
420 | my $pversion = $self->get_db_version(); |
421 | |
422 | if($pversion eq $self->schema_version) |
423 | { |
424 | warn "This version is already installed\n"; |
425 | return 1; |
426 | } |
42416a0b |
427 | |
8424c090 |
428 | if(!$pversion) |
429 | { |
430 | warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n"; |
431 | return 1; |
432 | } |
433 | |
434 | warn "Versions out of sync. This is " . $self->schema_version . |
435 | ", your database contains version $pversion, please call upgrade on your Schema.\n"; |
436 | } |
437 | |
438 | 1; |
439 | |
440 | |
441 | =head1 AUTHORS |
c9d2e0a2 |
442 | |
443 | Jess Robinson <castaway@desert-island.demon.co.uk> |
8424c090 |
444 | Luke Saunders <luke@shadowcatsystems.co.uk> |
445 | |
446 | =head1 LICENSE |
447 | |
448 | You may distribute this code under the same terms as Perl itself. |