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