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