lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm

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