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/); |
7 | __PACKAGE__->table('SchemaVersions'); |
8 | |
b7e303a8 |
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' |
b7e303a8 |
27 | }, |
28 | ); |
c9d2e0a2 |
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'); |
8795fefb |
50 | __PACKAGE__->mk_classdata('backup_directory'); |
f925f7cb |
51 | __PACKAGE__->mk_classdata('do_backup'); |
c9d2e0a2 |
52 | |
42416a0b |
53 | sub schema_version { |
54 | my ($self) = @_; |
55 | my $class = ref($self)||$self; |
56 | my $version; |
57 | { |
58 | no strict 'refs'; |
59 | $version = ${"${class}::VERSION"}; |
60 | } |
61 | return $version; |
62 | } |
63 | |
a2800991 |
64 | sub connection { |
65 | my $self = shift; |
66 | $self->next::method(@_); |
67 | $self->_on_connect; |
68 | return $self; |
69 | } |
70 | |
737416a4 |
71 | sub _on_connect |
c9d2e0a2 |
72 | { |
73 | my ($self) = @_; |
e6129e56 |
74 | $self->{vschema} = DBIx::Class::Version->connect(@{$self->storage->connect_info()}); |
e2c0df8e |
75 | |
0d865134 |
76 | my $pversion = $self->get_db_version(); |
77 | |
42416a0b |
78 | if($pversion eq $self->schema_version) |
c9d2e0a2 |
79 | { |
80 | warn "This version is already installed\n"; |
81 | return 1; |
82 | } |
83 | |
c9d2e0a2 |
84 | if(!$pversion) |
85 | { |
0d865134 |
86 | warn "Your DB is currently unversioned. Please call upgrade on your schema to sync the DB.\n"; |
c9d2e0a2 |
87 | return 1; |
88 | } |
89 | |
90 | my $file = $self->ddl_filename( |
91 | $self->storage->sqlt_type, |
92 | $self->upgrade_directory, |
42416a0b |
93 | $self->schema_version |
c9d2e0a2 |
94 | ); |
95 | if(!$file) |
96 | { |
97 | # No upgrade path between these two versions |
98 | return 1; |
99 | } |
100 | |
c9d2e0a2 |
101 | |
102 | ## Don't do this yet, do only on command? |
103 | ## If we do this later, where does the Version table get updated?? |
42416a0b |
104 | warn "Versions out of sync. This is " . $self->schema_version . |
c9d2e0a2 |
105 | ", your database contains version $pversion, please call upgrade on your Schema.\n"; |
c9d2e0a2 |
106 | } |
107 | |
e6129e56 |
108 | sub get_db_version |
109 | { |
110 | my ($self, $rs) = @_; |
111 | |
112 | my $vtable = $self->{vschema}->resultset('Table'); |
0d865134 |
113 | return 0 unless ($self->_source_exists($vtable)); |
114 | |
e6129e56 |
115 | my $psearch = $vtable->search(undef, |
116 | { select => [ |
117 | { 'max' => 'Installed' }, |
118 | ], |
119 | as => ['maxinstall'], |
120 | })->first; |
f925f7cb |
121 | my $pversion = $vtable->search({ Installed => $psearch->get_column('maxinstall'), |
e6129e56 |
122 | })->first; |
123 | $pversion = $pversion->Version if($pversion); |
124 | return $pversion; |
125 | } |
126 | |
a2800991 |
127 | sub _source_exists |
c9d2e0a2 |
128 | { |
129 | my ($self, $rs) = @_; |
130 | |
131 | my $c = eval { |
132 | $rs->search({ 1, 0 })->count; |
133 | }; |
134 | return 0 if $@ || !defined $c; |
135 | |
136 | return 1; |
137 | } |
138 | |
139 | sub backup |
140 | { |
141 | my ($self) = @_; |
142 | ## Make each ::DBI::Foo do this |
8795fefb |
143 | $self->storage->backup($self->backup_directory()); |
c9d2e0a2 |
144 | } |
145 | |
b7e303a8 |
146 | # TODO: some of this needs to be merged with ->create_ddl_dir |
c9d2e0a2 |
147 | sub upgrade |
148 | { |
149 | my ($self) = @_; |
0d865134 |
150 | my $db_version = $self->get_db_version(); |
c9d2e0a2 |
151 | |
1d48fcff |
152 | my %driver_to_db_map = ( |
153 | 'mysql' => 'MySQL' |
154 | ); |
0d865134 |
155 | if (!$db_version) { |
0d865134 |
156 | my $db = $driver_to_db_map{$self->storage->dbh->{Driver}->{Name}}; |
157 | unless ($db) { |
158 | print "Sorry, this is an unsupported DB\n"; |
159 | return; |
160 | } |
161 | |
162 | require SQL::Translator; |
163 | require SQL::Translator::Diff; |
0d865134 |
164 | my $db_tr = SQL::Translator->new({ |
165 | add_drop_table => 1, |
166 | parser => 'DBI', |
bcd1448c |
167 | parser_args => { dbh => $self->storage->dbh } |
0d865134 |
168 | }); |
169 | |
1d48fcff |
170 | $db_tr->producer($db); |
0d865134 |
171 | my $dbic_tr = SQL::Translator->new; |
172 | $dbic_tr->parser('SQL::Translator::Parser::DBIx::Class'); |
173 | $dbic_tr = $self->storage->configure_sqlt($dbic_tr, $db); |
174 | $dbic_tr->data($self); |
175 | $dbic_tr->producer($db); |
176 | |
bcd1448c |
177 | $db_tr->schema->name('db_schema'); |
178 | $dbic_tr->schema->name('dbic_schema'); |
0d865134 |
179 | |
180 | # is this really necessary? |
181 | foreach my $tr ($db_tr, $dbic_tr) { |
182 | my $data = $tr->data; |
183 | $tr->parser->($tr, $$data); |
184 | } |
1d48fcff |
185 | |
0d865134 |
186 | my $diff = SQL::Translator::Diff::schema_diff($db_tr->schema, $db, |
187 | $dbic_tr->schema, $db, |
da153fe5 |
188 | { caseopt => 1 }); |
0d865134 |
189 | |
190 | my $filename = $self->ddl_filename( |
1d48fcff |
191 | $db, |
0d865134 |
192 | $self->upgrade_directory, |
193 | $self->schema_version, |
194 | 'PRE', |
195 | ); |
196 | my $file; |
197 | if(!open($file, ">$filename")) |
198 | { |
199 | $self->throw_exception("Can't open $filename for writing ($!)"); |
200 | next; |
201 | } |
202 | print $file $diff; |
203 | close($file); |
204 | |
bcd1448c |
205 | # create versions table |
206 | $self->{vschema}->deploy; |
207 | |
208 | 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"; |
0d865134 |
209 | } else { |
1d48fcff |
210 | if ($db_version eq $self->schema_version) { |
211 | print "Upgrade not necessary\n"; |
212 | return; |
213 | } |
214 | |
0d865134 |
215 | my $file = $self->ddl_filename( |
b98d9e8a |
216 | $self->storage->sqlt_type, |
217 | $self->upgrade_directory, |
218 | $self->schema_version, |
0d865134 |
219 | $db_version, |
b98d9e8a |
220 | ); |
221 | |
0d865134 |
222 | if(!-f $file) |
223 | { |
224 | warn "Upgrade not possible, no upgrade file found ($file)\n"; |
225 | return; |
226 | } |
227 | |
228 | my $fh; |
229 | open $fh, "<$file" or warn("Can't open upgrade file, $file ($!)"); |
da153fe5 |
230 | my @data = split(/\n/, join('', <$fh>)); |
231 | @data = grep(!/^--/, @data); |
232 | @data = split(/;/, join('', @data)); |
0d865134 |
233 | close($fh); |
234 | @data = grep { $_ && $_ !~ /^-- / } @data; |
235 | @data = grep { $_ !~ /^(BEGIN TRANACTION|COMMIT)/m } @data; |
236 | |
237 | $self->_filedata(\@data); |
238 | $self->backup() if($self->do_backup); |
239 | |
240 | $self->txn_do(sub { |
241 | $self->do_upgrade(); |
242 | }); |
b98d9e8a |
243 | } |
244 | |
e6129e56 |
245 | my $vtable = $self->{vschema}->resultset('Table'); |
246 | $vtable->create({ Version => $self->schema_version, |
247 | Installed => strftime("%Y-%m-%d %H:%M:%S", gmtime()) |
248 | }); |
f925f7cb |
249 | |
e6129e56 |
250 | } |
c9d2e0a2 |
251 | |
e6129e56 |
252 | sub do_upgrade |
253 | { |
254 | my ($self) = @_; |
255 | |
256 | ## overridable sub, per default just run all the commands. |
c9d2e0a2 |
257 | $self->run_upgrade(qr/create/i); |
258 | $self->run_upgrade(qr/alter table .*? add/i); |
259 | $self->run_upgrade(qr/alter table .*? (?!drop)/i); |
260 | $self->run_upgrade(qr/alter table .*? drop/i); |
261 | $self->run_upgrade(qr/drop/i); |
c9d2e0a2 |
262 | } |
263 | |
c9d2e0a2 |
264 | sub run_upgrade |
265 | { |
266 | my ($self, $stm) = @_; |
267 | # print "Reg: $stm\n"; |
268 | my @statements = grep { $_ =~ $stm } @{$self->_filedata}; |
269 | # print "Statements: ", join("\n", @statements), "\n"; |
270 | $self->_filedata([ grep { $_ !~ /$stm/i } @{$self->_filedata} ]); |
271 | |
272 | for (@statements) |
273 | { |
70f39278 |
274 | $self->storage->debugobj->query_start($_) if $self->storage->debug; |
c9d2e0a2 |
275 | $self->storage->dbh->do($_) or warn "SQL was:\n $_"; |
70f39278 |
276 | $self->storage->debugobj->query_end($_) if $self->storage->debug; |
c9d2e0a2 |
277 | } |
278 | |
279 | return 1; |
280 | } |
281 | |
e2c0df8e |
282 | 1; |
283 | |
c9d2e0a2 |
284 | =head1 NAME |
285 | |
7d9fbacf |
286 | DBIx::Class::Schema::Versioned - DBIx::Class::Schema plugin for Schema upgrades |
c9d2e0a2 |
287 | |
288 | =head1 SYNOPSIS |
289 | |
290 | package Library::Schema; |
291 | use base qw/DBIx::Class::Schema/; |
292 | # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD |
293 | __PACKAGE__->load_classes(qw/CD Book DVD/); |
294 | |
295 | __PACKAGE__->load_components(qw/+DBIx::Class::Schema::Versioned/); |
296 | __PACKAGE__->upgrade_directory('/path/to/upgrades/'); |
8795fefb |
297 | __PACKAGE__->backup_directory('/path/to/backups/'); |
c9d2e0a2 |
298 | |
299 | sub backup |
300 | { |
301 | my ($self) = @_; |
302 | # my special backup process |
303 | } |
304 | |
305 | sub upgrade |
306 | { |
307 | my ($self) = @_; |
308 | |
309 | ## overridable sub, per default just runs all the commands. |
310 | |
311 | $self->run_upgrade(qr/create/i); |
312 | $self->run_upgrade(qr/alter table .*? add/i); |
313 | $self->run_upgrade(qr/alter table .*? (?!drop)/i); |
314 | $self->run_upgrade(qr/alter table .*? drop/i); |
315 | $self->run_upgrade(qr/drop/i); |
316 | $self->run_upgrade(qr//i); |
317 | } |
318 | |
319 | =head1 DESCRIPTION |
320 | |
321 | This module is a component designed to extend L<DBIx::Class::Schema> |
322 | classes, to enable them to upgrade to newer schema layouts. To use this |
323 | module, you need to have called C<create_ddl_dir> on your Schema to |
324 | create your upgrade files to include with your delivery. |
325 | |
326 | A table called I<SchemaVersions> is created and maintained by the |
327 | module. This contains two fields, 'Version' and 'Installed', which |
328 | contain each VERSION of your Schema, and the date+time it was installed. |
329 | |
330 | If you would like to influence which levels of version change need |
331 | upgrades in your Schema, you can override the method C<ddl_filename> |
332 | in L<DBIx::Class::Schema>. Return a false value if there is no upgrade |
333 | path between the two versions supplied. By default, every change in |
334 | your VERSION is regarded as needing an upgrade. |
335 | |
8795fefb |
336 | The actual upgrade is called manually by calling C<upgrade> on your |
337 | schema object. Code is run at connect time to determine whether an |
338 | upgrade is needed, if so, a warning "Versions out of sync" is |
339 | produced. |
340 | |
c9d2e0a2 |
341 | NB: At the moment, SQLite upgrading is rather spotty, as SQL::Translator::Diff |
342 | returns SQL statements that SQLite does not support. |
343 | |
344 | |
345 | =head1 METHODS |
346 | |
347 | =head2 backup |
348 | |
349 | This is an overwritable method which is called just before the upgrade, to |
350 | allow you to make a backup of the database. Per default this method attempts |
351 | to call C<< $self->storage->backup >>, to run the standard backup on each |
352 | database type. |
353 | |
e6129e56 |
354 | This method should return the name of the backup file, if appropriate.. |
c9d2e0a2 |
355 | |
356 | =head2 upgrade |
357 | |
e6129e56 |
358 | This is the main upgrade method which calls the overridable do_upgrade and |
359 | also handles the backups and updating of the SchemaVersion table. |
360 | |
361 | =head2 do_upgrade |
362 | |
c9d2e0a2 |
363 | This is an overwritable method used to run your upgrade. The freeform method |
364 | allows you to run your upgrade any way you please, you can call C<run_upgrade> |
365 | any number of times to run the actual SQL commands, and in between you can |
366 | sandwich your data upgrading. For example, first run all the B<CREATE> |
367 | commands, then migrate your data from old to new tables/formats, then |
368 | issue the DROP commands when you are finished. |
369 | |
370 | =head2 run_upgrade |
371 | |
372 | $self->run_upgrade(qr/create/i); |
373 | |
374 | Runs a set of SQL statements matching a passed in regular expression. The |
375 | idea is that this method can be called any number of times from your |
376 | C<upgrade> method, running whichever commands you specify via the |
377 | regex in the parameter. |
378 | |
8795fefb |
379 | =head2 upgrade_directory |
380 | |
381 | Use this to set the directory your upgrade files are stored in. |
382 | |
383 | =head2 backup_directory |
384 | |
385 | Use this to set the directory you want your backups stored in. |
386 | |
42416a0b |
387 | =head2 schema_version |
388 | |
389 | Returns the current schema class' $VERSION; does -not- use $schema->VERSION |
390 | since that varies in results depending on if version.pm is installed, and if |
391 | so the perl or XS versions. If you want this to change, bug the version.pm |
392 | author to make vpp and vxs behave the same. |
393 | |
c9d2e0a2 |
394 | =head1 AUTHOR |
395 | |
396 | Jess Robinson <castaway@desert-island.demon.co.uk> |