ZOMG use strict and warnings in tests
[dbsrgits/DBIx-Class-DeploymentHandler.git] / lib / DBIx / Class / DeploymentHandler / DeployMethod / SQL / Translator.pm
CommitLineData
45d0d9d5 1package DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator;
334bced5 2use Moose;
9af9d0b2 3
9a3a62f1 4# ABSTRACT: Manage your SQL and Perl migrations in nicely laid out directories
5
9af9d0b2 6use autodie;
7use Carp qw( carp croak );
8465e767 8use DBIx::Class::DeploymentHandler::Logger;
c4f51462 9use Log::Contextual qw(:log :dlog), -package_logger =>
8465e767 10 DBIx::Class::DeploymentHandler::Logger->new({
11 env_prefix => 'DBICDH'
12 });
9af9d0b2 13
2e68a8e1 14use Method::Signatures::Simple;
7f50d101 15use Try::Tiny;
9af9d0b2 16
d23c7c77 17use SQL::Translator;
18require SQL::Translator::Diff;
9af9d0b2 19
d23c7c77 20require DBIx::Class::Storage; # loaded for type constraint
41863428 21use DBIx::Class::DeploymentHandler::Types;
22
9af9d0b2 23use File::Path 'mkpath';
24use File::Spec::Functions;
2e68a8e1 25
7521a845 26with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
3c1b5ee8 27
93460690 28has ignore_ddl => (
29 isa => 'Bool',
30 is => 'ro',
31 default => undef,
32);
33
92624ee5 34has force_overwrite => (
35 isa => 'Bool',
36 is => 'ro',
37 default => undef,
38);
39
d54b8d69 40has schema => (
41 isa => 'DBIx::Class::Schema',
42 is => 'ro',
43 required => 1,
d54b8d69 44);
45
334bced5 46has storage => (
47 isa => 'DBIx::Class::Storage',
48 is => 'ro',
49 lazy_build => 1,
50);
51
2eaf903b 52method _build_storage {
53 my $s = $self->schema->storage;
54 $s->_determine_driver;
55 $s
56}
57
02a7b8ac 58has sql_translator_args => (
334bced5 59 isa => 'HashRef',
60 is => 'ro',
61 default => sub { {} },
62);
91adde75 63has script_directory => (
334bced5 64 isa => 'Str',
65 is => 'ro',
66 required => 1,
67 default => 'sql',
68);
69
334bced5 70has databases => (
71 coerce => 1,
72 isa => 'DBIx::Class::DeploymentHandler::Databases',
73 is => 'ro',
74 default => sub { [qw( MySQL SQLite PostgreSQL )] },
75);
76
a7d53deb 77has txn_wrap => (
78 is => 'ro',
79 isa => 'Bool',
80 default => 1,
81);
82
73caa630 83has schema_version => (
84 is => 'ro',
e86c0c07 85 isa => 'Str',
73caa630 86 lazy_build => 1,
87);
88
6df6dcb9 89# this will probably never get called as the DBICDH
90# will be passing down a schema_version normally, which
91# is built the same way, but we leave this in place
73caa630 92method _build_schema_version { $self->schema->schema_version }
93
76d311e7 94method __ddl_consume_with_prefix($type, $versions, $prefix) {
91adde75 95 my $base_dir = $self->script_directory;
262166c1 96
76d08d08 97 my $main = catfile( $base_dir, $type );
76d08d08 98 my $common =
99 catfile( $base_dir, '_common', $prefix, join q(-), @{$versions} );
262166c1 100
101 my $dir;
102 if (-d $main) {
76d08d08 103 $dir = catfile($main, $prefix, join q(-), @{$versions})
262166c1 104 } else {
38857f30 105 if ($self->ignore_ddl) {
106 return []
107 } else {
108 croak "$main does not exist; please write/generate some SQL"
109 }
262166c1 110 }
111
ef44838b 112 my %files;
113 try {
114 opendir my($dh), $dir;
115 %files =
116 map { $_ => "$dir/$_" }
117 grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" }
118 readdir $dh;
119 closedir $dh;
120 } catch {
121 die $_ unless $self->ignore_ddl;
122 };
262166c1 123 if (-d $common) {
124 opendir my($dh), $common;
41219a5d 125 for my $filename (grep { /\.(?:sql|pl)$/ && -f catfile($common,$_) } readdir $dh) {
262166c1 126 unless ($files{$filename}) {
9af9d0b2 127 $files{$filename} = catfile($common,$filename);
262166c1 128 }
129 }
130 closedir $dh;
131 }
132
133 return [@files{sort keys %files}]
134}
3c1b5ee8 135
ff40cb1f 136method _ddl_initialize_consume_filenames($type, $version) {
137 $self->__ddl_consume_with_prefix($type, [ $version ], 'initialize')
fc4b7602 138}
139
76d311e7 140method _ddl_schema_consume_filenames($type, $version) {
58eb99c3 141 $self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
3c1b5ee8 142}
143
c72832d7 144method _ddl_protoschema_deploy_consume_filenames($version) {
145 my $base_dir = $self->script_directory;
146
147 my $dir = catfile( $base_dir, '_source', 'deploy', $version);
148 return [] unless -d $dir;
149
150 opendir my($dh), $dir;
151 my %files = map { $_ => "$dir/$_" } grep { /\.yml$/ && -f "$dir/$_" } readdir $dh;
152 closedir $dh;
153
154 return [@files{sort keys %files}]
155}
156
58eb99c3 157method _ddl_protoschema_upgrade_consume_filenames($versions) {
f9c6ab50 158 my $base_dir = $self->script_directory;
159
58eb99c3 160 my $dir = catfile( $base_dir, '_preprocess_schema', 'upgrade', join q(-), @{$versions});
f9c6ab50 161
162 return [] unless -d $dir;
163
164 opendir my($dh), $dir;
165 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
166 closedir $dh;
167
168 return [@files{sort keys %files}]
169}
170
58eb99c3 171method _ddl_protoschema_downgrade_consume_filenames($versions) {
f9c6ab50 172 my $base_dir = $self->script_directory;
173
58eb99c3 174 my $dir = catfile( $base_dir, '_preprocess_schema', 'downgrade', join q(-), @{$versions});
f9c6ab50 175
176 return [] unless -d $dir;
177
178 opendir my($dh), $dir;
179 my %files = map { $_ => "$dir/$_" } grep { /\.pl$/ && -f "$dir/$_" } readdir $dh;
180 closedir $dh;
181
182 return [@files{sort keys %files}]
183}
184
7e08eddd 185method _ddl_protoschema_produce_filename($version) {
58eb99c3 186 my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
7e08eddd 187 mkpath($dirname) unless -d $dirname;
188
189 return catfile( $dirname, '001-auto.yml' );
190}
191
76d311e7 192method _ddl_schema_produce_filename($type, $version) {
58eb99c3 193 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
76d08d08 194 mkpath($dirname) unless -d $dirname;
d54b8d69 195
09bc35e3 196 return catfile( $dirname, '001-auto.sql' );
d54b8d69 197}
198
58eb99c3 199method _ddl_schema_upgrade_consume_filenames($type, $versions) {
200 $self->__ddl_consume_with_prefix($type, $versions, 'upgrade')
3c1b5ee8 201}
202
58eb99c3 203method _ddl_schema_downgrade_consume_filenames($type, $versions) {
204 $self->__ddl_consume_with_prefix($type, $versions, 'downgrade')
a41a04e5 205}
206
58eb99c3 207method _ddl_schema_upgrade_produce_filename($type, $versions) {
91adde75 208 my $dir = $self->script_directory;
76d311e7 209
58eb99c3 210 my $dirname = catfile( $dir, $type, 'upgrade', join q(-), @{$versions});
76d08d08 211 mkpath($dirname) unless -d $dirname;
a41a04e5 212
e62add58 213 return catfile( $dirname, '001-auto.sql' );
a41a04e5 214}
215
58eb99c3 216method _ddl_schema_downgrade_produce_filename($type, $versions, $dir) {
217 my $dirname = catfile( $dir, $type, 'downgrade', join q(-), @{$versions} );
76d08d08 218 mkpath($dirname) unless -d $dirname;
24f4524b 219
09bc35e3 220 return catfile( $dirname, '001-auto.sql');
24f4524b 221}
222
f36afe83 223method _run_sql_array($sql) {
41219a5d 224 my $storage = $self->storage;
5d7b27cf 225
1f0d0633 226 $sql = [grep {
227 $_ && # remove blank lines
228 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
229 } map {
230 s/^\s+//; s/\s+$//; # trim whitespace
231 join '', grep { !/^--/ } split /\n/ # remove comments
232 } @$sql];
233
f4075791 234 Dlog_trace { "Running SQL $_" } $sql;
f36afe83 235 foreach my $line (@{$sql}) {
5d7b27cf 236 $storage->_query_start($line);
10a62c3d 237 # the whole reason we do this is so that we can see the line that was run
5d7b27cf 238 try {
5d7b27cf 239 $storage->dbh_do (sub { $_[1]->do($line) });
240 }
241 catch {
10a62c3d 242 die "$_ (running line '$line')"
60e09fce 243 };
5d7b27cf 244 $storage->_query_end($line);
245 }
4d09f712 246 return join "\n", @$sql
f36afe83 247}
248
249method _run_sql($filename) {
f4075791 250 log_debug { "Running SQL from $filename" };
f36afe83 251 return $self->_run_sql_array($self->_read_sql_file($filename));
5d7b27cf 252}
2e68a8e1 253
5d7b27cf 254method _run_perl($filename) {
f4075791 255 log_debug { "Running Perl from $filename" };
5d7b27cf 256 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
c8a2f7bd 257
5d7b27cf 258 no warnings 'redefine';
259 my $fn = eval "$filedata";
260 use warnings;
f4075791 261 Dlog_trace { "Running Perl $_" } $fn;
5d7b27cf 262
263 if ($@) {
264 carp "$filename failed to compile: $@";
265 } elsif (ref $fn eq 'CODE') {
266 $fn->($self->schema)
267 } else {
268 carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
269 }
270}
5d7b27cf 271
ef44838b 272method _run_sql_and_perl($filenames, $sql_to_run) {
5d7b27cf 273 my @files = @{$filenames};
274 my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
275
ef44838b 276 $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
277
278 my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
279 FILENAME:
41219a5d 280 for my $filename (@files) {
ef44838b 281 if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
282 next FILENAME
283 } elsif ($filename =~ /\.sql$/) {
5d7b27cf 284 $sql .= $self->_run_sql($filename)
398b1385 285 } elsif ( $filename =~ /\.pl$/ ) {
5d7b27cf 286 $self->_run_perl($filename)
41219a5d 287 } else {
fc4b7602 288 croak "A file ($filename) got to deploy that wasn't sql or perl!";
2e68a8e1 289 }
2e68a8e1 290 }
a7d53deb 291
292 $guard->commit if $self->txn_wrap;
41219a5d 293
294 return $sql;
295}
296
297sub deploy {
298 my $self = shift;
be140a5f 299 my $version = (shift @_ || {})->{version} || $self->schema_version;
f4075791 300 log_info { "deploying version $version" };
ef44838b 301 my $sqlt_type = $self->storage->sqlt_type;
302 my $sql;
303 if ($self->ignore_ddl) {
304 $sql = $self->_sql_from_yaml({},
4ea5caf5 305 '_ddl_protoschema_deploy_consume_filenames', $sqlt_type
ef44838b 306 );
307 }
308 return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
309 $sqlt_type,
310 $version,
311 ), $sql);
2e68a8e1 312}
313
ff40cb1f 314sub initialize {
9faec51a 315 my $self = shift;
316 my $args = shift;
317 my $version = $args->{version} || $self->schema_version;
ff40cb1f 318 log_info { "initializing version $version" };
9faec51a 319 my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
fc4b7602 320
ff40cb1f 321 my @files = @{$self->_ddl_initialize_consume_filenames(
9faec51a 322 $storage_type,
fc4b7602 323 $version,
324 )};
325
326 for my $filename (@files) {
327 # We ignore sql for now (till I figure out what to do with it)
328 if ( $filename =~ /^(.+)\.pl$/ ) {
fc4b7602 329 my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
fc4b7602 330
9faec51a 331 no warnings 'redefine';
5b5defbc 332 my $fn = eval "$filedata";
fc4b7602 333 use warnings;
5b5defbc 334
9faec51a 335 if ($@) {
3fa64c79 336 carp "$filename failed to compile: $@";
9faec51a 337 } elsif (ref $fn eq 'CODE') {
fc4b7602 338 $fn->()
339 } else {
5b5defbc 340 carp "$filename should define an anonymous sub but it didn't!";
fc4b7602 341 }
342 } else {
ff40cb1f 343 croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!";
fc4b7602 344 }
345 }
346}
347
f9c6ab50 348method _sqldiff_from_yaml($from_version, $to_version, $db, $direction) {
91adde75 349 my $dir = $self->script_directory;
28563f97 350 my $sqltargs = {
351 add_drop_table => 1,
352 ignore_constraint_names => 1,
353 ignore_index_names => 1,
354 %{$self->sql_translator_args}
355 };
d54b8d69 356
28563f97 357 my $source_schema;
358 {
359 my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir);
360
361 # should probably be a croak
362 carp("No previous schema file found ($prefilename)")
363 unless -e $prefilename;
364
365 my $t = SQL::Translator->new({
366 %{$sqltargs},
367 debug => 0,
368 trace => 0,
369 parser => 'SQL::Translator::Parser::YAML',
370 });
371
372 my $out = $t->translate( $prefilename )
373 or croak($t->error);
374
375 $source_schema = $t->schema;
376
377 $source_schema->name( $prefilename )
378 unless $source_schema->name;
379 }
380
381 my $dest_schema;
382 {
383 my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir);
384
385 # should probably be a croak
386 carp("No next schema file found ($filename)")
387 unless -e $filename;
388
389 my $t = SQL::Translator->new({
390 %{$sqltargs},
391 debug => 0,
392 trace => 0,
393 parser => 'SQL::Translator::Parser::YAML',
394 });
395
396 my $out = $t->translate( $filename )
397 or croak($t->error);
398
399 $dest_schema = $t->schema;
400
401 $dest_schema->name( $filename )
402 unless $dest_schema->name;
403 }
f9c6ab50 404
405 my $transform_files_method = "_ddl_protoschema_${direction}_consume_filenames";
406 my $transforms = $self->_coderefs_per_files(
407 $self->$transform_files_method([$from_version, $to_version])
408 );
409 $_->($source_schema, $dest_schema) for @$transforms;
410
28563f97 411 return [SQL::Translator::Diff::schema_diff(
412 $source_schema, $db,
413 $dest_schema, $db,
414 $sqltargs
415 )];
416}
417
418method _sql_from_yaml($sqltargs, $from_file, $db) {
419 my $schema = $self->schema;
420 my $version = $self->schema_version;
93460690 421
4ea5caf5 422 my @sql;
2e68a8e1 423
4ea5caf5 424 my $actual_file = $self->$from_file($version);
425 for my $yaml_filename (@{
426 DlogS_trace { "generating SQL from Serialized SQL Files: $_" }
427 (ref $actual_file?$actual_file:[$actual_file])
428 }) {
429 my $sqlt = SQL::Translator->new({
430 add_drop_table => 0,
431 parser => 'SQL::Translator::Parser::YAML',
432 %{$sqltargs},
433 producer => $db,
434 });
435
436 push @sql, $sqlt->translate($yaml_filename);
437 if(!@sql) {
438 carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
439 return undef;
440 }
28563f97 441 }
442 return \@sql;
443}
444
445sub _prepare_install {
446 my $self = shift;
447 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
448 my $from_file = shift;
449 my $to_file = shift;
450 my $dir = $self->script_directory;
451 my $databases = $self->databases;
452 my $version = $self->schema_version;
453
2e68a8e1 454 foreach my $db (@$databases) {
28563f97 455 my $sql = $self->_sql_from_yaml($sqltargs, $from_file, $db ) or next;
2e68a8e1 456
c8a2f7bd 457 my $filename = $self->$to_file($db, $version, $dir);
9600776d 458 if (-e $filename ) {
92624ee5 459 if ($self->force_overwrite) {
460 carp "Overwriting existing DDL file - $filename";
461 unlink $filename;
462 } else {
463 die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
464 }
2e68a8e1 465 }
387b11d2 466 open my $file, q(>), $filename;
28563f97 467 print {$file} join ";\n", @$sql;
2e68a8e1 468 close $file;
469 }
470}
471
c8a2f7bd 472sub _resultsource_install_filename {
473 my ($self, $source_name) = @_;
474 return sub {
475 my ($self, $type, $version) = @_;
58eb99c3 476 my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
c8a2f7bd 477 mkpath($dirname) unless -d $dirname;
478
09bc35e3 479 return catfile( $dirname, "001-auto-$source_name.sql" );
c8a2f7bd 480 }
481}
482
e62add58 483sub _resultsource_protoschema_filename {
484 my ($self, $source_name) = @_;
485 return sub {
486 my ($self, $version) = @_;
d3d6512c 487 my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
e62add58 488 mkpath($dirname) unless -d $dirname;
489
490 return catfile( $dirname, "001-auto-$source_name.yml" );
491 }
492}
493
c8a2f7bd 494sub install_resultsource {
be140a5f 495 my ($self, $args) = @_;
496 my $source = $args->{result_source};
497 my $version = $args->{version};
f4075791 498 log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
c8a2f7bd 499 my $rs_install_file =
500 $self->_resultsource_install_filename($source->source_name);
501
502 my $files = [
503 $self->$rs_install_file(
504 $self->storage->sqlt_type,
505 $version,
506 )
507 ];
508 $self->_run_sql_and_perl($files);
509}
510
511sub prepare_resultsource_install {
512 my $self = shift;
be140a5f 513 my $source = (shift @_)->{result_source};
f4075791 514 log_info { 'preparing install for resultsource ' . $source->source_name };
c8a2f7bd 515
e62add58 516 my $install_filename = $self->_resultsource_install_filename($source->source_name);
517 my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name);
6cae2f56 518 $self->prepare_protoschema({
c8a2f7bd 519 parser_args => { sources => [$source->source_name], }
e62add58 520 }, $proto_filename);
521 $self->_prepare_install({}, $proto_filename, $install_filename);
c8a2f7bd 522}
523
91557c90 524sub prepare_deploy {
f4075791 525 log_info { 'preparing deploy' };
c8a2f7bd 526 my $self = shift;
6776a6d4 527 $self->prepare_protoschema({
528 # Exclude __VERSION so that it gets installed separately
529 parser_args => { sources => [grep { $_ ne '__VERSION' } $self->schema->sources], }
530 }, '_ddl_protoschema_produce_filename');
e62add58 531 $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
c8a2f7bd 532}
533
a41a04e5 534sub prepare_upgrade {
be140a5f 535 my ($self, $args) = @_;
0df68524 536 log_info {
f4075791 537 "preparing upgrade from $args->{from_version} to $args->{to_version}"
0df68524 538 };
be140a5f 539 $self->_prepare_changegrade(
58eb99c3 540 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'upgrade'
be140a5f 541 );
76d311e7 542}
543
544sub prepare_downgrade {
be140a5f 545 my ($self, $args) = @_;
0df68524 546 log_info {
f4075791 547 "preparing downgrade from $args->{from_version} to $args->{to_version}"
0df68524 548 };
be140a5f 549 $self->_prepare_changegrade(
58eb99c3 550 $args->{from_version}, $args->{to_version}, $args->{version_set}, 'downgrade'
be140a5f 551 );
76d311e7 552}
553
f9c6ab50 554method _coderefs_per_files($files) {
555 no warnings 'redefine';
556 [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
557}
558
76d311e7 559method _prepare_changegrade($from_version, $to_version, $version_set, $direction) {
2e68a8e1 560 my $schema = $self->schema;
561 my $databases = $self->databases;
91adde75 562 my $dir = $self->script_directory;
2e68a8e1 563
73caa630 564 my $schema_version = $self->schema_version;
e62add58 565 my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
e62add58 566 foreach my $db (@$databases) {
567 my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
568 if(-e $diff_file) {
92624ee5 569 if ($self->force_overwrite) {
570 carp("Overwriting existing $direction-diff file - $diff_file");
571 unlink $diff_file;
572 } else {
573 die "Cannot overwrite '$diff_file', either enable force_overwrite or delete it"
574 }
2e68a8e1 575 }
576
387b11d2 577 open my $file, q(>), $diff_file;
f9c6ab50 578 print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)};
2e68a8e1 579 close $file;
580 }
581}
582
334bced5 583method _read_sql_file($file) {
584 return unless $file;
585
aabd4237 586 open my $fh, '<', $file;
0d19af1d 587 my @data = split /;\n/, join '', <$fh>;
334bced5 588 close $fh;
589
09bc35e3 590 @data = grep {
591 $_ && # remove blank lines
592 !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
593 } map {
594 s/^\s+//; s/\s+$//; # trim whitespace
595 join '', grep { !/^--/ } split /\n/ # remove comments
596 } @data;
334bced5 597
09bc35e3 598 return \@data;
1f0d0633 599}
600
7d2a6974 601sub downgrade_single_step {
76d311e7 602 my $self = shift;
be140a5f 603 my $version_set = (shift @_)->{version_set};
f4075791 604 Dlog_info { "downgrade_single_step'ing $_" } $version_set;
41219a5d 605
ef44838b 606 my $sqlt_type = $self->storage->sqlt_type;
607 my $sql_to_run;
608 if ($self->ignore_ddl) {
609 $sql_to_run = $self->_sqldiff_from_yaml(
58eb99c3 610 $version_set->[0], $version_set->[1], $sqlt_type, 'downgrade',
ef44838b 611 );
612 }
58eb99c3 613 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames(
ef44838b 614 $sqlt_type,
627581cd 615 $version_set,
ef44838b 616 ), $sql_to_run);
3249629f 617
41219a5d 618 return ['', $sql];
76d311e7 619}
620
7d2a6974 621sub upgrade_single_step {
7521a845 622 my $self = shift;
be140a5f 623 my $version_set = (shift @_)->{version_set};
f4075791 624 Dlog_info { "upgrade_single_step'ing $_" } $version_set;
41219a5d 625
ef44838b 626 my $sqlt_type = $self->storage->sqlt_type;
627 my $sql_to_run;
628 if ($self->ignore_ddl) {
629 $sql_to_run = $self->_sqldiff_from_yaml(
58eb99c3 630 $version_set->[0], $version_set->[1], $sqlt_type, 'upgrade',
ef44838b 631 );
632 }
58eb99c3 633 my $sql = $self->_run_sql_and_perl($self->_ddl_schema_upgrade_consume_filenames(
ef44838b 634 $sqlt_type,
627581cd 635 $version_set,
ef44838b 636 ), $sql_to_run);
41219a5d 637 return ['', $sql];
334bced5 638}
639
6cae2f56 640sub prepare_protoschema {
7e08eddd 641 my $self = shift;
e62add58 642 my $sqltargs = { %{$self->sql_translator_args}, %{shift @_} };
643 my $to_file = shift;
7e08eddd 644 my $filename
e62add58 645 = $self->$to_file($self->schema_version);
7e08eddd 646
e62add58 647 # we do this because the code that uses this sets parser args,
648 # so we just need to merge in the package
649 $sqltargs->{parser_args}{package} = $self->schema;
7e08eddd 650 my $sqlt = SQL::Translator->new({
651 parser => 'SQL::Translator::Parser::DBIx::Class',
652 producer => 'SQL::Translator::Producer::YAML',
e62add58 653 %{ $sqltargs },
7e08eddd 654 });
655
656 my $yml = $sqlt->translate;
657
658 croak("Failed to translate to YAML: " . $sqlt->error)
659 unless $yml;
660
661 if (-e $filename ) {
92624ee5 662 if ($self->force_overwrite) {
663 carp "Overwriting existing DDL-YML file - $filename";
664 unlink $filename;
665 } else {
666 die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
667 }
7e08eddd 668 }
669
670 open my $file, q(>), $filename;
671 print {$file} $yml;
672 close $file;
673}
674
aabd4237 675__PACKAGE__->meta->make_immutable;
676
2e68a8e1 6771;
e051bb00 678
e52174e3 679# vim: ts=2 sw=2 expandtab
680
e051bb00 681__END__
682
bcc72297 683=head1 DESCRIPTION
684
e62add58 685This class is the meat of L<DBIx::Class::DeploymentHandler>. It takes care
686of generating serialized schemata as well as sql files to move from one
687version of a schema to the rest. One of the hallmark features of this class
688is that it allows for multiple sql files for deploy and upgrade, allowing
689developers to fine tune deployment. In addition it also allows for perl
690files to be run at any stage of the process.
bcc72297 691
692For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>. What's
693documented here is extra fun stuff or private methods.
694
695=head1 DIRECTORY LAYOUT
696
39c88a9a 697Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.
698It's spiritually based upon L<DBIx::Migration::Directories>, but has a
699lot of extensions and modifications, so even if you are familiar with it,
700please read this. I feel like the best way to describe the layout is with
701the following example:
92c34cab 702
703 $sql_migration_dir
58eb99c3 704 |- _source
705 | |- deploy
03882cab 706 | |- 1
707 | | `- 001-auto.yml
708 | |- 2
709 | | `- 001-auto.yml
710 | `- 3
711 | `- 001-auto.yml
92c34cab 712 |- SQLite
58eb99c3 713 | |- downgrade
4f85efc6 714 | | `- 2-1
e62add58 715 | | `- 001-auto.sql
58eb99c3 716 | |- deploy
92c34cab 717 | | `- 1
e62add58 718 | | `- 001-auto.sql
58eb99c3 719 | `- upgrade
92c34cab 720 | |- 1-2
e62add58 721 | | `- 001-auto.sql
92c34cab 722 | `- 2-3
e62add58 723 | `- 001-auto.sql
92c34cab 724 |- _common
58eb99c3 725 | |- downgrade
4f85efc6 726 | | `- 2-1
92c34cab 727 | | `- 002-remove-customers.pl
58eb99c3 728 | `- upgrade
92c34cab 729 | `- 1-2
730 | `- 002-generate-customers.pl
92c34cab 731 `- MySQL
58eb99c3 732 |- downgrade
4f85efc6 733 | `- 2-1
e62add58 734 | `- 001-auto.sql
ff40cb1f 735 |- initialize
80ff6f6d 736 | `- 1
737 | |- 001-create_database.pl
738 | `- 002-create_users_and_permissions.pl
58eb99c3 739 |- deploy
92c34cab 740 | `- 1
e62add58 741 | `- 001-auto.sql
58eb99c3 742 `- upgrade
92c34cab 743 `- 1-2
e62add58 744 `- 001-auto.sql
92c34cab 745
746So basically, the code
747
748 $dm->deploy(1)
749
750on an C<SQLite> database that would simply run
58eb99c3 751C<$sql_migration_dir/SQLite/deploy/1/001-auto.sql>. Next,
92c34cab 752
753 $dm->upgrade_single_step([1,2])
754
58eb99c3 755would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by
756C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>.
92c34cab 757
0824f31f 758C<.pl> files don't have to be in the C<_common> directory, but most of the time
39c88a9a 759they should be, because perl scripts are generally database independent.
92c34cab 760
ff40cb1f 761Note that unlike most steps in the process, C<initialize> will not run SQL, as
762there may not even be an database at initialize time. It will run perl scripts
80ff6f6d 763just like the other steps in the process, but nothing is passed to them.
764Until people have used this more it will remain freeform, but a recommended use
ff40cb1f 765of initialize is to have it prompt for username and password, and then call the
80ff6f6d 766appropriate C<< CREATE DATABASE >> commands etc.
767
03882cab 768=head2 Directory Specification
769
770The following subdirectories are recognized by this DeployMethod:
771
772=over 2
773
58eb99c3 774=item C<_source> This directory can contain the following directories:
03882cab 775
776=over 2
777
39c88a9a 778=item C<deploy> This directory merely contains directories named after schema
779versions, which in turn contain C<yaml> files that are serialized versions
780of the schema at that version. These files are not for editing by hand.
781
782=back
783
784=item C<_preprocess_schema> This directory can contain the following
785directories:
786
787=over 2
788
58eb99c3 789=item C<downgrade> This directory merely contains directories named after
03882cab 790migrations, which are of the form C<$from_version-$to_version>. Inside of
791these directories you may put Perl scripts which are to return a subref
792that takes the arguments C<< $from_schema, $to_schema >>, which are
793L<SQL::Translator::Schema> objects.
794
58eb99c3 795=item C<upgrade> This directory merely contains directories named after
03882cab 796migrations, which are of the form C<$from_version-$to_version>. Inside of
797these directories you may put Perl scripts which are to return a subref
798that takes the arguments C<< $from_schema, $to_schema >>, which are
799L<SQL::Translator::Schema> objects.
800
03882cab 801=back
802
5b766a24 803=item C<$storage_type> This is a set of scripts that gets run depending on what
804your storage type is. If you are not sure what your storage type is, take a
805look at the producers listed for L<SQL::Translator>. Also note, C<_common>
806is a special case. C<_common> will get merged into whatever other files you
807already have. This directory can containt the following directories itself:
71d00500 808
809=over 2
810
ff40cb1f 811=item C<initialize> Gets run before the C<deploy> is C<deploy>ed. Has the
58eb99c3 812same structure as the C<deploy> subdirectory as well; that is, it has a
813directory for each schema version. Unlike C<deploy>, C<upgrade>, and C<downgrade>
71d00500 814though, it can only run C<.pl> files, and the coderef in the perl files get
815no arguments passed to them.
816
58eb99c3 817=item C<deploy> Gets run when the schema is C<deploy>ed. Structure is a
71d00500 818directory per schema version, and then files are merged with C<_common> and run
819in filename order. C<.sql> files are merely run, as expected. C<.pl> files are
820run according to L</PERL SCRIPTS>.
821
58eb99c3 822=item C<upgrade> Gets run when the schema is C<upgrade>d. Structure is a directory
71d00500 823per upgrade step, (for example, C<1-2> for upgrading from version 1 to version
8242,) and then files are merged with C<_common> and run in filename order.
825C<.sql> files are merely run, as expected. C<.pl> files are run according
826to L</PERL SCRIPTS>.
827
58eb99c3 828=item C<downgrade> Gets run when the schema is C<downgrade>d. Structure is a directory
71d00500 829per downgrade step, (for example, C<2-1> for downgrading from version 2 to version
8301,) and then files are merged with C<_common> and run in filename order.
831C<.sql> files are merely run, as expected. C<.pl> files are run according
832to L</PERL SCRIPTS>.
833
834
835=back
836
03882cab 837=back
838
92c34cab 839=head1 PERL SCRIPTS
840
7d0b0f2b 841A perl script for this tool is very simple. It merely needs to contain an
842anonymous sub that takes a L<DBIx::Class::Schema> as it's only argument.
92c34cab 843A very basic perl script might look like:
844
845 #!perl
846
847 use strict;
848 use warnings;
849
7d0b0f2b 850 sub {
92c34cab 851 my $schema = shift;
852
853 $schema->resultset('Users')->create({
854 name => 'root',
855 password => 'root',
856 })
857 }
bcc72297 858
39c88a9a 859=attr ignore_ddl
860
861This attribute will, when set to true (default is false), cause the DM to use
862L<SQL::Translator> to use the C<_source>'s serialized SQL::Translator::Schema
863instead of any pregenerated SQL. If you have a development server this is
864probably the best plan of action as you will not be putting as many generated
865files in your version control. Goes well with with C<databases> of C<[]>.
866
92624ee5 867=attr force_overwrite
868
869When this attribute is true generated files will be overwritten when the
870methods which create such files are run again. The default is false, in which
871case the program will die with a message saying which file needs to be deleted.
872
eb28403b 873=attr schema
a65184c8 874
bcc72297 875The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
876and generate the DDL.
877
eb28403b 878=attr storage
a65184c8 879
bcc72297 880The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
881and generate the DDL. This is automatically created with L</_build_storage>.
882
02a7b8ac 883=attr sql_translator_args
cfc9edf9 884
02a7b8ac 885The arguments that get passed to L<SQL::Translator> when it's used.
a65184c8 886
91adde75 887=attr script_directory
cfc9edf9 888
91adde75 889The directory (default C<'sql'>) that scripts are stored in
cfc9edf9 890
eb28403b 891=attr databases
cfc9edf9 892
893The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
894generate files for
895
eb28403b 896=attr txn_wrap
897
bcc72297 898Set to true (which is the default) to wrap all upgrades and deploys in a single
899transaction.
900
73caa630 901=attr schema_version
902
903The version the schema on your harddrive is at. Defaults to
904C<< $self->schema->schema_version >>.