Commit | Line | Data |
b974984a |
1 | package DBIx::Class::DeploymentHandler; |
2 | |
3 | use Moose; |
4 | use Method::Signatures::Simple; |
12fdd461 |
5 | require DBIx::Class::Schema; # loaded for type constraint |
6 | require DBIx::Class::Storage; # loaded for type constraint |
7 | require DBIx::Class::ResultSet; # loaded for type constraint |
e1f67607 |
8 | use Carp::Clan '^DBIx::Class::DeploymentHandler'; |
ecc3b6be |
9 | use SQL::Translator; |
9e1c29c2 |
10 | require SQL::Translator::Diff; |
d76abae0 |
11 | use Try::Tiny; |
b974984a |
12 | |
cf400f48 |
13 | BEGIN { |
14 | use Moose::Util::TypeConstraints; |
15 | subtype 'DBIx::Class::DeploymentHandler::Databases' |
16 | => as 'ArrayRef[Str]'; |
17 | |
18 | coerce 'DBIx::Class::DeploymentHandler::Databases' |
19 | => from 'Str' |
20 | => via { [$_] }; |
21 | no Moose::Util::TypeConstraints; |
22 | } |
23 | |
b974984a |
24 | has schema => ( |
61847972 |
25 | isa => 'DBIx::Class::Schema', |
26 | is => 'ro', |
27 | required => 1, |
4ea147c6 |
28 | handles => [qw( ddl_filename schema_version )], |
b974984a |
29 | ); |
30 | |
31 | has upgrade_directory => ( |
61847972 |
32 | isa => 'Str', |
33 | is => 'ro', |
34 | required => 1, |
4ea147c6 |
35 | default => 'sql', |
b974984a |
36 | ); |
37 | |
38 | has backup_directory => ( |
61847972 |
39 | isa => 'Str', |
40 | is => 'ro', |
b974984a |
41 | ); |
42 | |
43 | has storage => ( |
61847972 |
44 | isa => 'DBIx::Class::Storage', |
45 | is => 'ro', |
46 | lazy_build => 1, |
b974984a |
47 | ); |
48 | |
7eec7eb7 |
49 | method _build_storage { |
61847972 |
50 | my $s = $self->schema->storage; |
51 | $s->_determine_driver; |
52 | $s |
7eec7eb7 |
53 | } |
12fdd461 |
54 | |
b974984a |
55 | has _filedata => ( |
4ea147c6 |
56 | isa => 'ArrayRef[Str]', |
61847972 |
57 | is => 'rw', |
b974984a |
58 | ); |
59 | |
60 | has do_backup => ( |
61847972 |
61 | isa => 'Bool', |
62 | is => 'ro', |
63 | default => undef, |
b974984a |
64 | ); |
65 | |
66 | has do_diff_on_init => ( |
61847972 |
67 | isa => 'Bool', |
68 | is => 'ro', |
69 | default => undef, |
b974984a |
70 | ); |
71 | |
12fdd461 |
72 | has version_rs => ( |
61847972 |
73 | isa => 'DBIx::Class::ResultSet', |
74 | is => 'ro', |
75 | lazy_build => 1, |
76 | handles => [qw( is_installed db_version )], |
12fdd461 |
77 | ); |
78 | |
9e1c29c2 |
79 | method _build_version_rs { |
80 | $self->schema->set_us_up_the_bomb; |
81 | $self->schema->resultset('__VERSION') |
82 | } |
83 | |
9e401dc2 |
84 | has databases => ( |
cf400f48 |
85 | coerce => 1, |
86 | isa => 'DBIx::Class::DeploymentHandler::Databases', |
87 | is => 'ro', |
9e401dc2 |
88 | default => sub { [qw( MySQL SQLite PostgreSQL )] }, |
89 | ); |
90 | |
ecc3b6be |
91 | has sqltargs => ( |
92 | isa => 'HashRef', |
93 | is => 'ro', |
94 | default => sub { {} }, |
95 | ); |
96 | |
46a47cd4 |
97 | method deployment_statements { |
98 | my $dir = $self->upgrade_directory; |
99 | my $schema = $self->schema; |
100 | my $type = $self->storage->sqlt_type; |
101 | my $sqltargs = $self->sqltargs; |
d76abae0 |
102 | my $version = $self->schema_version || '1.x'; |
46a47cd4 |
103 | |
d76abae0 |
104 | my $filename = $self->ddl_filename($type, $version, $dir); |
105 | if(-f $filename) { |
741620a6 |
106 | my $file; |
d76abae0 |
107 | open $file, q(<), $filename |
108 | or carp "Can't open $filename ($!)"; |
741620a6 |
109 | my @rows = <$file>; |
d76abae0 |
110 | close $file; |
111 | return join '', @rows; |
741620a6 |
112 | } |
113 | |
114 | # sources needs to be a parser arg, but for simplicty allow at top level |
115 | # coming in |
116 | $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} |
117 | if exists $sqltargs->{sources}; |
118 | |
119 | my $tr = SQL::Translator->new( |
120 | producer => "SQL::Translator::Producer::${type}", |
121 | %$sqltargs, |
122 | parser => 'SQL::Translator::Parser::DBIx::Class', |
123 | data => $schema, |
124 | ); |
125 | |
126 | my @ret; |
127 | my $wa = wantarray; |
128 | if ($wa) { |
129 | @ret = $tr->translate; |
130 | } |
131 | else { |
132 | $ret[0] = $tr->translate; |
133 | } |
134 | |
135 | $schema->throw_exception( 'Unable to produce deployment statements: ' . $tr->error) |
136 | unless (@ret && defined $ret[0]); |
137 | |
138 | return $wa ? @ret : $ret[0]; |
139 | } |
140 | |
141 | method deploy { |
46a47cd4 |
142 | my $schema = $self->schema; |
143 | my $type = undef; |
741620a6 |
144 | my $sqltargs = $self->sqltargs; |
46a47cd4 |
145 | my $dir = $self->upgrade_directory; |
146 | my $storage = $self->storage; |
741620a6 |
147 | |
148 | my $deploy = sub { |
149 | my $line = shift; |
d76abae0 |
150 | return if(!$line || $line =~ /^--|^BEGIN TRANSACTION|^COMMIT|^\s+$/); |
741620a6 |
151 | $storage->_query_start($line); |
d76abae0 |
152 | try { |
741620a6 |
153 | # do a dbh_do cycle here, as we need some error checking in |
154 | # place (even though we will ignore errors) |
155 | $storage->dbh_do (sub { $_[1]->do($line) }); |
d76abae0 |
156 | } |
157 | catch { |
158 | carp "$_ (running '${line}')" |
741620a6 |
159 | } |
160 | $storage->_query_end($line); |
161 | }; |
d76abae0 |
162 | my @statements = $self->deployment_statements(); |
741620a6 |
163 | if (@statements > 1) { |
164 | foreach my $statement (@statements) { |
165 | $deploy->( $statement ); |
166 | } |
167 | } |
168 | elsif (@statements == 1) { |
169 | foreach my $line ( split(";\n", $statements[0])) { |
170 | $deploy->( $line ); |
171 | } |
172 | } |
173 | } |
174 | |
12fdd461 |
175 | method backup { $self->storage->backup($self->backup_directory) } |
b974984a |
176 | |
177 | method install($new_version) { |
12fdd461 |
178 | carp 'Install not possible as versions table already exists in database' |
ceef4ff5 |
179 | if $self->is_installed; |
b974984a |
180 | |
12fdd461 |
181 | $new_version ||= $self->schema_version; |
b974984a |
182 | |
183 | if ($new_version) { |
741620a6 |
184 | $self->deploy(); |
12fdd461 |
185 | |
186 | $self->version_rs->create({ |
61847972 |
187 | version => $new_version, |
188 | # ddl => $ddl, |
189 | # upgrade_sql => $upgrade_sql, |
12fdd461 |
190 | }); |
b974984a |
191 | } |
192 | } |
193 | |
12fdd461 |
194 | method create_upgrade_path { } |
b974984a |
195 | |
8636376a |
196 | method ordered_schema_versions { undef } |
b974984a |
197 | |
198 | method upgrade { |
12fdd461 |
199 | my $db_version = $self->db_version; |
200 | my $schema_version = $self->schema_version; |
b974984a |
201 | |
b974984a |
202 | unless ($db_version) { |
61847972 |
203 | # croak? |
204 | carp 'Upgrade not possible as database is unversioned. Please call install first.'; |
205 | return; |
b974984a |
206 | } |
207 | |
12fdd461 |
208 | if ( $db_version eq $schema_version ) { |
61847972 |
209 | # croak? |
210 | carp "Upgrade not necessary\n"; |
211 | return; |
b974984a |
212 | } |
213 | |
12fdd461 |
214 | my @version_list = $self->ordered_schema_versions || |
215 | ( $db_version, $schema_version ); |
b974984a |
216 | |
217 | # remove all versions in list above the required version |
12fdd461 |
218 | while ( @version_list && ( $version_list[-1] ne $schema_version ) ) { |
61847972 |
219 | pop @version_list; |
b974984a |
220 | } |
221 | |
222 | # remove all versions in list below the current version |
12fdd461 |
223 | while ( @version_list && ( $version_list[0] ne $db_version ) ) { |
61847972 |
224 | shift @version_list; |
b974984a |
225 | } |
226 | |
227 | # check we have an appropriate list of versions |
12fdd461 |
228 | die if @version_list < 2; |
b974984a |
229 | |
230 | # do sets of upgrade |
12fdd461 |
231 | while ( @version_list >= 2 ) { |
61847972 |
232 | $self->upgrade_single_step( $version_list[0], $version_list[1] ); |
233 | shift @version_list; |
b974984a |
234 | } |
235 | } |
236 | |
237 | method upgrade_single_step($db_version, $target_version) { |
b974984a |
238 | if ($db_version eq $target_version) { |
e1f67607 |
239 | # croak? |
b974984a |
240 | carp "Upgrade not necessary\n"; |
241 | return; |
242 | } |
243 | |
b974984a |
244 | my $upgrade_file = $self->ddl_filename( |
12fdd461 |
245 | $self->storage->sqlt_type, |
246 | $target_version, |
247 | $self->upgrade_directory, |
248 | $db_version, |
249 | ); |
b974984a |
250 | |
251 | $self->create_upgrade_path({ upgrade_file => $upgrade_file }); |
252 | |
253 | unless (-f $upgrade_file) { |
e1f67607 |
254 | # croak? |
b974984a |
255 | carp "Upgrade not possible, no upgrade file found ($upgrade_file), please create one\n"; |
256 | return; |
257 | } |
258 | |
259 | carp "DB version ($db_version) is lower than the schema version (".$self->schema_version."). Attempting upgrade.\n"; |
260 | |
e1f67607 |
261 | $self->_filedata($self->_read_sql_file($upgrade_file)); # I don't like this --fREW 2010-02-22 |
12fdd461 |
262 | $self->backup if $self->do_backup; |
263 | $self->schema->txn_do(sub { $self->do_upgrade }); |
b974984a |
264 | |
12fdd461 |
265 | $self->version_rs->create({ |
61847972 |
266 | version => $target_version, |
267 | # ddl => $ddl, |
268 | # upgrade_sql => $upgrade_sql, |
12fdd461 |
269 | }); |
b974984a |
270 | } |
271 | |
9e1c29c2 |
272 | method create_install_ddl { |
ecc3b6be |
273 | my $schema = $self->schema; |
9e401dc2 |
274 | my $databases = $self->databases; |
ecc3b6be |
275 | my $dir = $self->upgrade_directory; |
276 | my $sqltargs = $self->sqltargs; |
9e401dc2 |
277 | unless( -d $dir ) { |
278 | carp "Upgrade directory $dir does not exist, using ./\n"; |
8164e4d0 |
279 | $dir = "./"; |
280 | } |
8164e4d0 |
281 | |
9e1c29c2 |
282 | my $version = $schema->schema_version || '1.x'; |
8164e4d0 |
283 | my $schema_version = $schema->schema_version || '1.x'; |
284 | $version ||= $schema_version; |
285 | |
286 | $sqltargs = { |
287 | add_drop_table => 1, |
288 | ignore_constraint_names => 1, |
289 | ignore_index_names => 1, |
290 | %{$sqltargs || {}} |
291 | }; |
292 | |
8164e4d0 |
293 | my $sqlt = SQL::Translator->new( $sqltargs ); |
294 | |
295 | $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); |
296 | my $sqlt_schema = $sqlt->translate({ data => $schema }) |
297 | or $self->throw_exception ($sqlt->error); |
298 | |
299 | foreach my $db (@$databases) { |
c88c9aaa |
300 | $sqlt->reset; |
8164e4d0 |
301 | $sqlt->{schema} = $sqlt_schema; |
302 | $sqlt->producer($db); |
303 | |
c88c9aaa |
304 | my $filename = $self->ddl_filename($db, $version, $dir); |
8164e4d0 |
305 | if (-e $filename && ($version eq $schema_version )) { |
306 | # if we are dumping the current version, overwrite the DDL |
307 | carp "Overwriting existing DDL file - $filename"; |
c88c9aaa |
308 | unlink $filename; |
8164e4d0 |
309 | } |
310 | |
311 | my $output = $sqlt->translate; |
312 | if(!$output) { |
313 | carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")"); |
314 | next; |
315 | } |
c88c9aaa |
316 | my $file; |
317 | unless( open $file, q(>), $filename ) { |
8164e4d0 |
318 | $self->throw_exception("Can't open $filename for writing ($!)"); |
319 | next; |
320 | } |
c88c9aaa |
321 | print {$file} $output; |
322 | close $file; |
9e1c29c2 |
323 | } |
324 | } |
8164e4d0 |
325 | |
9e1c29c2 |
326 | method create_update_ddl($version, $preversion) { |
327 | my $schema = $self->schema; |
328 | my $databases = $self->databases; |
329 | my $dir = $self->upgrade_directory; |
330 | my $sqltargs = $self->sqltargs; |
8164e4d0 |
331 | |
9e1c29c2 |
332 | unless( -d $dir ) { |
333 | carp "Upgrade directory $dir does not exist, using ./\n"; |
334 | $dir = "./"; |
335 | } |
336 | |
337 | my $schema_version = $schema->schema_version || '1.x'; |
338 | $version ||= $schema_version; |
339 | |
340 | $sqltargs = { |
341 | add_drop_table => 1, |
342 | ignore_constraint_names => 1, |
343 | ignore_index_names => 1, |
344 | %{$sqltargs} |
345 | }; |
346 | |
347 | my $sqlt = SQL::Translator->new( $sqltargs ); |
348 | |
349 | $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); |
350 | my $sqlt_schema = $sqlt->translate({ data => $schema }) |
351 | or $self->throw_exception ($sqlt->error); |
352 | |
353 | foreach my $db (@$databases) { |
354 | $sqlt->reset; |
355 | $sqlt->{schema} = $sqlt_schema; |
356 | $sqlt->producer($db); |
8164e4d0 |
357 | |
c88c9aaa |
358 | my $prefilename = $self->ddl_filename($db, $preversion, $dir); |
359 | unless(-e $prefilename) { |
8164e4d0 |
360 | carp("No previous schema file found ($prefilename)"); |
361 | next; |
362 | } |
363 | |
c88c9aaa |
364 | my $diff_file = $self->ddl_filename($db, $version, $dir, $preversion); |
365 | if(-e $diff_file) { |
366 | carp("Overwriting existing diff file - $diff_file"); |
367 | unlink $diff_file; |
8164e4d0 |
368 | } |
369 | |
370 | my $source_schema; |
371 | { |
c88c9aaa |
372 | my $t = SQL::Translator->new({ |
373 | %{$sqltargs}, |
374 | debug => 0, |
375 | trace => 0, |
376 | }); |
8164e4d0 |
377 | |
c88c9aaa |
378 | $t->parser( $db ) # could this really throw an exception? |
8164e4d0 |
379 | or $self->throw_exception ($t->error); |
380 | |
381 | my $out = $t->translate( $prefilename ) |
382 | or $self->throw_exception ($t->error); |
383 | |
384 | $source_schema = $t->schema; |
385 | |
386 | $source_schema->name( $prefilename ) |
c88c9aaa |
387 | unless $source_schema->name; |
8164e4d0 |
388 | } |
389 | |
390 | # The "new" style of producers have sane normalization and can support |
391 | # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't |
392 | # And we have to diff parsed SQL against parsed SQL. |
393 | my $dest_schema = $sqlt_schema; |
394 | |
395 | unless ( "SQL::Translator::Producer::$db"->can('preprocess_schema') ) { |
c88c9aaa |
396 | my $t = SQL::Translator->new({ |
397 | %{$sqltargs}, |
398 | debug => 0, |
399 | trace => 0, |
400 | }); |
8164e4d0 |
401 | |
c88c9aaa |
402 | $t->parser( $db ) # could this really throw an exception? |
8164e4d0 |
403 | or $self->throw_exception ($t->error); |
404 | |
9e1c29c2 |
405 | my $filename = $self->ddl_filename($db, $version, $dir); |
8164e4d0 |
406 | my $out = $t->translate( $filename ) |
407 | or $self->throw_exception ($t->error); |
408 | |
409 | $dest_schema = $t->schema; |
410 | |
411 | $dest_schema->name( $filename ) |
412 | unless $dest_schema->name; |
413 | } |
414 | |
c88c9aaa |
415 | my $diff = SQL::Translator::Diff::schema_diff( |
416 | $source_schema, $db, |
417 | $dest_schema, $db, |
418 | $sqltargs |
419 | ); |
9e1c29c2 |
420 | my $file; |
c88c9aaa |
421 | unless(open $file, q(>), $diff_file) { |
422 | $self->throw_exception("Can't write to $diff_file ($!)"); |
8164e4d0 |
423 | next; |
424 | } |
c88c9aaa |
425 | print {$file} $diff; |
426 | close $file; |
8164e4d0 |
427 | } |
428 | } |
429 | |
9e1c29c2 |
430 | method create_ddl_dir($version, $preversion) { |
431 | $self->create_install_ddl; |
432 | $self->create_update_ddl($version, $preversion) if $preversion; |
433 | } |
434 | |
12fdd461 |
435 | method do_upgrade { $self->run_upgrade(qr/.*?/) } |
b974984a |
436 | |
437 | method run_upgrade($stm) { |
12fdd461 |
438 | return unless $self->_filedata; |
439 | my @statements = grep { $_ =~ $stm } @{$self->_filedata}; |
b974984a |
440 | |
12fdd461 |
441 | for (@statements) { |
442 | $self->storage->debugobj->query_start($_) if $self->storage->debug; |
443 | $self->apply_statement($_); |
444 | $self->storage->debugobj->query_end($_) if $self->storage->debug; |
445 | } |
b974984a |
446 | } |
447 | |
448 | method apply_statement($statement) { |
e1f67607 |
449 | # croak? |
12fdd461 |
450 | $self->storage->dbh->do($_) or carp "SQL was: $_" |
b974984a |
451 | } |
452 | |
8cf0010a |
453 | method _read_sql_file($file) { |
454 | return unless $file; |
b974984a |
455 | |
456 | open my $fh, '<', $file or carp("Can't open upgrade file, $file ($!)"); |
457 | my @data = split /\n/, join '', <$fh>; |
458 | close $fh; |
459 | |
460 | @data = grep { |
8cf0010a |
461 | $_ && |
462 | !/^--/ && |
463 | !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/m |
b974984a |
464 | } split /;/, |
8cf0010a |
465 | join '', @data; |
b974984a |
466 | |
467 | return \@data; |
468 | } |
469 | |
b974984a |
470 | 1; |
61847972 |
471 | |
472 | __END__ |
473 | |
474 | vim: ts=2,sw=2,expandtab |