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