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 use Context::Preserve;
  14
  15 use Try::Tiny;
  16
  17 use SQL::Translator;
  18 require SQL::Translator::Diff;
  19
  20 require DBIx::Class::Storage;   # loaded for type constraint
  21 use DBIx::Class::DeploymentHandler::Types;
  22
  23 use File::Path 'mkpath';
  24 use File::Spec::Functions;
  25
  26 with 'DBIx::Class::DeploymentHandler::HandlesDeploy';
  27
  28 has ignore_ddl => (
  29   isa      => 'Bool',
  30   is       => 'ro',
  31   default  => undef,
  32 );
  33
  34 has force_overwrite => (
  35   isa      => 'Bool',
  36   is       => 'ro',
  37   default  => undef,
  38 );
  39
  40 has 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 = [ _split_sql_chunk( @$sql ) ];
 247
 248   Dlog_trace { "Running SQL $_" } $sql;
 249   foreach my $line (@{$sql}) {
 250     $storage->_query_start($line);
 251     # the whole reason we do this is so that we can see the line that was run
 252     try {
 253       $storage->dbh_do (sub { $_[1]->do($line) });
 254     }
 255     catch {
 256       die "$_ (running line '$line')"
 257     };
 258     $storage->_query_end($line);
 259   }
 260   return join "\n", @$sql
 261 }
 262
 263 # split a chunk o' SQL into statements
 264 sub _split_sql_chunk {
 265     my @sql = map { split /;\n/, $_ } @_;
 266
 267     for ( @sql ) {
 268         # strip transactions
 269         s/^(?:BEGIN|BEGIN TRANSACTION|COMMIT).*//mgi;
 270
 271         # trim whitespaces
 272         s/^\s+|\s+$//mg;
 273
 274         # remove comments
 275         s/^--.*//gm;
 276
 277         # remove blank lines
 278         s/^\n//mg;
 279
 280         # put on single line
 281         s/\n/ /g;
 282     }
 283
 284     return @sql;
 285 }
 286
 287 sub _run_sql {
 288   my ($self, $filename) = @_;
 289   log_debug { "Running SQL from $filename" };
 290   return $self->_run_sql_array($self->_read_sql_file($filename));
 291 }
 292
 293 sub _load_sandbox {
 294   my $_file = shift;
 295
 296   my $_package = $_file;
 297   $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", ord($1))/eg;
 298
 299   my $fn = eval sprintf <<'END_EVAL', $_package;
 300 package DBICDH::Sandbox::%s;
 301 {
 302   our $app;
 303   $app ||= require $_file;
 304   if ( !$app && ( my $error = $@ || $! )) { die $error; }
 305   $app;
 306 }
 307 END_EVAL
 308
 309   croak $@ if $@;
 310
 311   croak "$_file should define an anonymous sub that takes a schema but it didn't!"
 312      unless ref $fn && ref $fn eq 'CODE';
 313
 314   return $fn;
 315 }
 316
 317 sub _run_perl {
 318   my ($self, $filename, $versions) = @_;
 319   log_debug { "Running Perl from $filename" };
 320
 321   my $fn = _load_sandbox($filename);
 322
 323   Dlog_trace { "Running Perl $_" } $fn;
 324
 325   $fn->($self->schema, $versions)
 326 }
 327
 328 sub txn_do {
 329    my ( $self, $code ) = @_;
 330    return $code->() unless $self->txn_wrap;
 331
 332    my $guard = $self->schema->txn_scope_guard;
 333
 334    return preserve_context { $code->() } after => sub { $guard->commit };
 335 }
 336
 337 sub _run_sql_and_perl {
 338   my ($self, $filenames, $sql_to_run, $versions) = @_;
 339   my @files   = @{$filenames};
 340   $self->txn_do(sub {
 341      $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
 342
 343      my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
 344      FILENAME:
 345      for my $filename (@files) {
 346        if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
 347          next FILENAME
 348        } elsif ($filename =~ /\.sql$/) {
 349           $sql .= $self->_run_sql($filename)
 350        } elsif ( $filename =~ /\.pl$/ ) {
 351           $self->_run_perl($filename, $versions)
 352        } else {
 353          croak "A file ($filename) got to deploy that wasn't sql or perl!";
 354        }
 355      }
 356
 357      return $sql;
 358   });
 359 }
 360
 361 sub deploy {
 362   my $self = shift;
 363   my $version = (shift @_ || {})->{version} || $self->schema_version;
 364   log_info { "deploying version $version" };
 365   my $sqlt_type = $self->storage->sqlt_type;
 366   my $sql;
 367   if ($self->ignore_ddl) {
 368      $sql = $self->_sql_from_yaml({},
 369        '_ddl_protoschema_deploy_consume_filenames', $sqlt_type
 370      );
 371   }
 372   return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
 373     $sqlt_type,
 374     $version,
 375   ), $sql, [$version]);
 376 }
 377
 378 sub initialize {
 379   my $self         = shift;
 380   my $args         = shift;
 381   my $version      = $args->{version}      || $self->schema_version;
 382   log_info { "initializing version $version" };
 383   my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
 384
 385   my @files = @{$self->_ddl_initialize_consume_filenames(
 386     $storage_type,
 387     $version,
 388   )};
 389
 390   for my $filename (@files) {
 391     # We ignore sql for now (till I figure out what to do with it)
 392     if ( $filename =~ /^(.+)\.pl$/ ) {
 393       my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
 394
 395       no warnings 'redefine';
 396       my $fn = eval "$filedata";
 397       use warnings;
 398
 399       if ($@) {
 400         croak "$filename failed to compile: $@";
 401       } elsif (ref $fn eq 'CODE') {
 402         $fn->()
 403       } else {
 404         croak "$filename should define an anonymous sub but it didn't!";
 405       }
 406     } else {
 407       croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!";
 408     }
 409   }
 410 }
 411
 412 sub _sqldiff_from_yaml {
 413   my ($self, $from_version, $to_version, $db, $direction) = @_;
 414   my $dir       = $self->script_directory;
 415   my $sqltargs = {
 416     add_drop_table => 1,
 417     ignore_constraint_names => 1,
 418     ignore_index_names => 1,
 419     %{$self->sql_translator_args}
 420   };
 421
 422   my $source_schema;
 423   {
 424     my $prefilename = $self->_ddl_protoschema_produce_filename($from_version, $dir);
 425
 426     # should probably be a croak
 427     carp("No previous schema file found ($prefilename)")
 428        unless -e $prefilename;
 429
 430     my $t = SQL::Translator->new({
 431        %{$sqltargs},
 432        debug => 0,
 433        trace => 0,
 434        parser => 'SQL::Translator::Parser::YAML',
 435     });
 436
 437     my $out = $t->translate( $prefilename )
 438       or croak($t->error);
 439
 440     $source_schema = $t->schema;
 441
 442     $source_schema->name( $prefilename )
 443       unless  $source_schema->name;
 444   }
 445
 446   my $dest_schema;
 447   {
 448     my $filename = $self->_ddl_protoschema_produce_filename($to_version, $dir);
 449
 450     # should probably be a croak
 451     carp("No next schema file found ($filename)")
 452        unless -e $filename;
 453
 454     my $t = SQL::Translator->new({
 455        %{$sqltargs},
 456        debug => 0,
 457        trace => 0,
 458        parser => 'SQL::Translator::Parser::YAML',
 459     });
 460
 461     my $out = $t->translate( $filename )
 462       or croak($t->error);
 463
 464     $dest_schema = $t->schema;
 465
 466     $dest_schema->name( $filename )
 467       unless $dest_schema->name;
 468   }
 469
 470   my $transform_files_method =  "_ddl_protoschema_${direction}_consume_filenames";
 471   my $transforms = $self->_coderefs_per_files(
 472     $self->$transform_files_method([$from_version, $to_version])
 473   );
 474   $_->($source_schema, $dest_schema) for @$transforms;
 475
 476   return [SQL::Translator::Diff::schema_diff(
 477      $source_schema, $db,
 478      $dest_schema,   $db,
 479      $sqltargs
 480   )];
 481 }
 482
 483 sub _sql_from_yaml {
 484   my ($self, $sqltargs, $from_file, $db) = @_;
 485   my $schema    = $self->schema;
 486   my $version   = $self->schema_version;
 487
 488   my @sql;
 489
 490   my $actual_file = $self->$from_file($version);
 491   for my $yaml_filename (@{
 492      DlogS_trace { "generating SQL from Serialized SQL Files: $_" }
 493         (ref $actual_file?$actual_file:[$actual_file])
 494   }) {
 495      my $sqlt = SQL::Translator->new({
 496        add_drop_table          => 0,
 497        parser                  => 'SQL::Translator::Parser::YAML',
 498        %{$sqltargs},
 499        producer => $db,
 500      });
 501
 502      push @sql, $sqlt->translate($yaml_filename);
 503      if(!@sql) {
 504        carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
 505        return undef;
 506      }
 507   }
 508   return \@sql;
 509 }
 510
 511 sub _prepare_install {
 512   my $self      = shift;
 513   my $sqltargs  = { %{$self->sql_translator_args}, %{shift @_} };
 514   my $from_file = shift;
 515   my $to_file   = shift;
 516   my $dir       = $self->script_directory;
 517   my $databases = $self->databases;
 518   my $version   = $self->schema_version;
 519
 520   foreach my $db (@$databases) {
 521     my $sql = $self->_sql_from_yaml($sqltargs, $from_file, $db ) or next;
 522
 523     my $filename = $self->$to_file($db, $version, $dir);
 524     if (-e $filename ) {
 525       if ($self->force_overwrite) {
 526          carp "Overwriting existing DDL file - $filename";
 527          unlink $filename;
 528       } else {
 529          die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
 530       }
 531     }
 532     open my $file, q(>), $filename;
 533     print {$file} join ";\n", @$sql;
 534     close $file;
 535   }
 536 }
 537
 538 sub _resultsource_install_filename {
 539   my ($self, $source_name) = @_;
 540   return sub {
 541     my ($self, $type, $version) = @_;
 542     my $dirname = catfile( $self->script_directory, $type, 'deploy', $version );
 543     mkpath($dirname) unless -d $dirname;
 544
 545     return catfile( $dirname, "001-auto-$source_name.sql" );
 546   }
 547 }
 548
 549 sub _resultsource_protoschema_filename {
 550   my ($self, $source_name) = @_;
 551   return sub {
 552     my ($self, $version) = @_;
 553     my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
 554     mkpath($dirname) unless -d $dirname;
 555
 556     return catfile( $dirname, "001-auto-$source_name.yml" );
 557   }
 558 }
 559
 560 sub install_resultsource {
 561   my ($self, $args) = @_;
 562   my $source          = $args->{result_source}
 563     or die 'result_source must be passed to install_resultsource';
 564   my $version         = $args->{version}
 565     or die 'version must be passed to install_resultsource';
 566   log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
 567   my $rs_install_file =
 568     $self->_resultsource_install_filename($source->source_name);
 569
 570   my $files = [
 571      $self->$rs_install_file(
 572       $self->storage->sqlt_type,
 573       $version,
 574     )
 575   ];
 576   $self->_run_sql_and_perl($files, '', [$version]);
 577 }
 578
 579 sub prepare_resultsource_install {
 580   my $self = shift;
 581   my $source = (shift @_)->{result_source};
 582   log_info { 'preparing install for resultsource ' . $source->source_name };
 583
 584   my $install_filename = $self->_resultsource_install_filename($source->source_name);
 585   my $proto_filename = $self->_resultsource_protoschema_filename($source->source_name);
 586   $self->prepare_protoschema({
 587       parser_args => { sources => [$source->source_name], }
 588   }, $proto_filename);
 589   $self->_prepare_install({}, $proto_filename, $install_filename);
 590 }
 591
 592 sub prepare_deploy {
 593   log_info { 'preparing deploy' };
 594   my $self = shift;
 595   $self->prepare_protoschema({
 596       # Exclude __VERSION so that it gets installed separately
 597       parser_args => { sources => [grep { $_ ne '__VERSION' } $self->schema->sources], }
 598   }, '_ddl_protoschema_produce_filename');
 599   $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
 600 }
 601
 602 sub prepare_upgrade {
 603   my ($self, $args) = @_;
 604   log_info {
 605      "preparing upgrade from $args->{from_version} to $args->{to_version}"
 606   };
 607   $self->_prepare_changegrade(
 608     $args->{from_version}, $args->{to_version}, $args->{version_set}, 'upgrade'
 609   );
 610 }
 611
 612 sub prepare_downgrade {
 613   my ($self, $args) = @_;
 614   log_info {
 615      "preparing downgrade from $args->{from_version} to $args->{to_version}"
 616   };
 617   $self->_prepare_changegrade(
 618     $args->{from_version}, $args->{to_version}, $args->{version_set}, 'downgrade'
 619   );
 620 }
 621
 622 sub _coderefs_per_files {
 623   my ($self, $files) = @_;
 624   no warnings 'redefine';
 625   [map eval do { local( @ARGV, $/ ) = $_; <> }, @$files]
 626 }
 627
 628 sub _prepare_changegrade {
 629   my ($self, $from_version, $to_version, $version_set, $direction) = @_;
 630   my $schema    = $self->schema;
 631   my $databases = $self->databases;
 632   my $dir       = $self->script_directory;
 633
 634   my $schema_version = $self->schema_version;
 635   my $diff_file_method = "_ddl_schema_${direction}_produce_filename";
 636   foreach my $db (@$databases) {
 637     my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
 638     if(-e $diff_file) {
 639       if ($self->force_overwrite) {
 640          carp("Overwriting existing $direction-diff file - $diff_file");
 641          unlink $diff_file;
 642       } else {
 643          die "Cannot overwrite '$diff_file', either enable force_overwrite or delete it"
 644       }
 645     }
 646
 647     open my $file, q(>), $diff_file;
 648     print {$file} join ";\n", @{$self->_sqldiff_from_yaml($from_version, $to_version, $db, $direction)};
 649     close $file;
 650   }
 651 }
 652
 653 sub _read_sql_file {
 654   my ($self, $file)  = @_;
 655   return unless $file;
 656
 657    local $/ = undef;  #sluuuuuurp
 658
 659   open my $fh, '<', $file;
 660   return [ _split_sql_chunk( <$fh> ) ];
 661 }
 662
 663 sub downgrade_single_step {
 664   my $self = shift;
 665   my $version_set = (shift @_)->{version_set};
 666   Dlog_info { "downgrade_single_step'ing $_" } $version_set;
 667
 668   my $sqlt_type = $self->storage->sqlt_type;
 669   my $sql_to_run;
 670   if ($self->ignore_ddl) {
 671      $sql_to_run = $self->_sqldiff_from_yaml(
 672        $version_set->[0], $version_set->[1], $sqlt_type, 'downgrade',
 673      );
 674   }
 675   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_downgrade_consume_filenames(
 676     $sqlt_type,
 677     $version_set,
 678   ), $sql_to_run, $version_set);
 679
 680   return ['', $sql];
 681 }
 682
 683 sub upgrade_single_step {
 684   my $self = shift;
 685   my $version_set = (shift @_)->{version_set};
 686   Dlog_info { "upgrade_single_step'ing $_" } $version_set;
 687
 688   my $sqlt_type = $self->storage->sqlt_type;
 689   my $sql_to_run;
 690   if ($self->ignore_ddl) {
 691      $sql_to_run = $self->_sqldiff_from_yaml(
 692        $version_set->[0], $version_set->[1], $sqlt_type, 'upgrade',
 693      );
 694   }
 695   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_upgrade_consume_filenames(
 696     $sqlt_type,
 697     $version_set,
 698   ), $sql_to_run, $version_set);
 699   return ['', $sql];
 700 }
 701
 702 sub prepare_protoschema {
 703   my $self      = shift;
 704   my $sqltargs  = { %{$self->sql_translator_args}, %{shift @_} };
 705   my $to_file   = shift;
 706   my $filename
 707     = $self->$to_file($self->schema_version);
 708
 709   # we do this because the code that uses this sets parser args,
 710   # so we just need to merge in the package
 711   $sqltargs->{parser_args}{package} = $self->schema;
 712   my $sqlt = SQL::Translator->new({
 713     parser                  => 'SQL::Translator::Parser::DBIx::Class',
 714     producer                => 'SQL::Translator::Producer::YAML',
 715     %{ $sqltargs },
 716   });
 717
 718   my $yml = $sqlt->translate;
 719
 720   croak("Failed to translate to YAML: " . $sqlt->error)
 721     unless $yml;
 722
 723   if (-e $filename ) {
 724     if ($self->force_overwrite) {
 725        carp "Overwriting existing DDL-YML file - $filename";
 726        unlink $filename;
 727     } else {
 728        die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
 729     }
 730   }
 731
 732   open my $file, q(>), $filename;
 733   print {$file} $yml;
 734   close $file;
 735 }
 736
 737 __PACKAGE__->meta->make_immutable;
 738
 739 1;
 740
 741 # vim: ts=2 sw=2 expandtab
 742
 743 __END__
 744
 745 =head1 DESCRIPTION
 746
 747 This class is the meat of L<DBIx::Class::DeploymentHandler>.  It takes care
 748 of generating serialized schemata  as well as sql files to move from one
 749 version of a schema to the rest.  One of the hallmark features of this class
 750 is that it allows for multiple sql files for deploy and upgrade, allowing
 751 developers to fine tune deployment.  In addition it also allows for perl
 752 files to be run at any stage of the process.
 753
 754 For basic usage see L<DBIx::Class::DeploymentHandler::HandlesDeploy>.  What's
 755 documented here is extra fun stuff or private methods.
 756
 757 =head1 DIRECTORY LAYOUT
 758
 759 Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.
 760 It's spiritually based upon L<DBIx::Migration::Directories>, but has a
 761 lot of extensions and modifications, so even if you are familiar with it,
 762 please read this.  I feel like the best way to describe the layout is with
 763 the following example:
 764
 765  $sql_migration_dir
 766  |- _source
 767  |  |- deploy
 768  |     |- 1
 769  |     |  `- 001-auto.yml
 770  |     |- 2
 771  |     |  `- 001-auto.yml
 772  |     `- 3
 773  |        `- 001-auto.yml
 774  |- SQLite
 775  |  |- downgrade
 776  |  |  `- 2-1
 777  |  |     `- 001-auto.sql
 778  |  |- deploy
 779  |  |  `- 1
 780  |  |     `- 001-auto.sql
 781  |  `- upgrade
 782  |     |- 1-2
 783  |     |  `- 001-auto.sql
 784  |     `- 2-3
 785  |        `- 001-auto.sql
 786  |- _common
 787  |  |- downgrade
 788  |  |  `- 2-1
 789  |  |     `- 002-remove-customers.pl
 790  |  `- upgrade
 791  |     `- 1-2
 792  |     |  `- 002-generate-customers.pl
 793  |     `- _any
 794  |        `- 999-bump-action.pl
 795  `- MySQL
 796     |- downgrade
 797     |  `- 2-1
 798     |     `- 001-auto.sql
 799     |- initialize
 800     |  `- 1
 801     |     |- 001-create_database.pl
 802     |     `- 002-create_users_and_permissions.pl
 803     |- deploy
 804     |  `- 1
 805     |     `- 001-auto.sql
 806     `- upgrade
 807        `- 1-2
 808           `- 001-auto.sql
 809
 810 So basically, the code
 811
 812  $dm->deploy(1)
 813
 814 on an C<SQLite> database that would simply run
 815 C<$sql_migration_dir/SQLite/deploy/1/001-auto.sql>.  Next,
 816
 817  $dm->upgrade_single_step([1,2])
 818
 819 would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by
 820 C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>, and
 821 finally punctuated by
 822 C<$sql_migration_dir/_common/upgrade/_any/999-bump-action.pl>.
 823
 824 C<.pl> files don't have to be in the C<_common> directory, but most of the time
 825 they should be, because perl scripts are generally database independent.
 826
 827 Note that unlike most steps in the process, C<initialize> will not run SQL, as
 828 there may not even be an database at initialize time.  It will run perl scripts
 829 just like the other steps in the process, but nothing is passed to them.
 830 Until people have used this more it will remain freeform, but a recommended use
 831 of initialize is to have it prompt for username and password, and then call the
 832 appropriate C<< CREATE DATABASE >> commands etc.
 833
 834 =head2 Directory Specification
 835
 836 The following subdirectories are recognized by this DeployMethod:
 837
 838 =over 2
 839
 840 =item C<_source> This directory can contain the following directories:
 841
 842 =over 2
 843
 844 =item C<deploy> This directory merely contains directories named after schema
 845 versions, which in turn contain C<yaml> files that are serialized versions
 846 of the schema at that version.  These files are not for editing by hand.
 847
 848 =back
 849
 850 =item C<_preprocess_schema> This directory can contain the following
 851 directories:
 852
 853 =over 2
 854
 855 =item C<downgrade> This directory merely contains directories named after
 856 migrations, which are of the form C<$from_version-$to_version>.  Inside of
 857 these directories you may put Perl scripts which are to return a subref
 858 that takes the arguments C<< $from_schema, $to_schema >>, which are
 859 L<SQL::Translator::Schema> objects.
 860
 861 =item C<upgrade> This directory merely contains directories named after
 862 migrations, which are of the form C<$from_version-$to_version>.  Inside of
 863 these directories you may put Perl scripts which are to return a subref
 864 that takes the arguments C<< $from_schema, $to_schema >>, which are
 865 L<SQL::Translator::Schema> objects.
 866
 867 =back
 868
 869 =item C<$storage_type> This is a set of scripts that gets run depending on what
 870 your storage type is.  If you are not sure what your storage type is, take a
 871 look at the producers listed for L<SQL::Translator>.  Also note, C<_common>
 872 is a special case.  C<_common> will get merged into whatever other files you
 873 already have.  This directory can contain the following directories itself:
 874
 875 =over 2
 876
 877 =item C<initialize> Gets run before the C<deploy> is C<deploy>ed.  Has the
 878 same structure as the C<deploy> subdirectory as well; that is, it has a
 879 directory for each schema version.  Unlike C<deploy>, C<upgrade>, and C<downgrade>
 880 though, it can only run C<.pl> files, and the coderef in the perl files get
 881 no arguments passed to them.
 882
 883 =item C<deploy> Gets run when the schema is C<deploy>ed.  Structure is a
 884 directory per schema version, and then files are merged with C<_common> and run
 885 in filename order.  C<.sql> files are merely run, as expected.  C<.pl> files are
 886 run according to L</PERL SCRIPTS>.
 887
 888 =item C<upgrade> Gets run when the schema is C<upgrade>d.  Structure is a directory
 889 per upgrade step, (for example, C<1-2> for upgrading from version 1 to version
 890 2,) and then files are merged with C<_common> and run in filename order.
 891 C<.sql> files are merely run, as expected.  C<.pl> files are run according
 892 to L</PERL SCRIPTS>.
 893
 894 =item C<downgrade> Gets run when the schema is C<downgrade>d.  Structure is a directory
 895 per downgrade step, (for example, C<2-1> for downgrading from version 2 to version
 896 1,) and then files are merged with C<_common> and run in filename order.
 897 C<.sql> files are merely run, as expected.  C<.pl> files are run according
 898 to L</PERL SCRIPTS>.
 899
 900
 901 =back
 902
 903 =back
 904
 905 Note that there can be an C<_any> in the place of any of the versions (like
 906 C<1-2> or C<1>), which means those scripts will be run B<every> time.  So if
 907 you have an C<_any> in C<_common/upgrade>, that script will get run for every
 908 upgrade.
 909
 910 =head1 PERL SCRIPTS
 911
 912 A perl script for this tool is very simple.  It merely needs to contain an
 913 anonymous sub that takes a L<DBIx::Class::Schema> and the version set as it's
 914 arguments.
 915
 916 A very basic perl script might look like:
 917
 918  #!perl
 919
 920  use strict;
 921  use warnings;
 922
 923  use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
 924     'schema_from_schema_loader';
 925
 926  schema_from_schema_loader({ naming => 'v4' }, sub {
 927    my $schema = shift;
 928
 929    # [1] for deploy, [1,2] for upgrade or downgrade, probably used with _any
 930    my $versions = shift;
 931
 932    $schema->resultset('Users')->create({
 933      name => 'root',
 934      password => 'root',
 935    })
 936  })
 937
 938 Note that the above uses
 939 L<DBIx::Class::DeploymentHanlder::DeployMethod::SQL::Translator::ScriptHelpers/schema_from_schema_loader>.
 940 Using a raw coderef is strongly discouraged as it is likely to break as you
 941 modify your schema.
 942
 943 =attr ignore_ddl
 944
 945 This attribute will, when set to true (default is false), cause the DM to use
 946 L<SQL::Translator> to use the C<_source>'s serialized SQL::Translator::Schema
 947 instead of any pregenerated SQL.  If you have a development server this is
 948 probably the best plan of action as you will not be putting as many generated
 949 files in your version control.  Goes well with with C<databases> of C<[]>.
 950
 951 =attr force_overwrite
 952
 953 When this attribute is true generated files will be overwritten when the
 954 methods which create such files are run again.  The default is false, in which
 955 case the program will die with a message saying which file needs to be deleted.
 956
 957 =attr schema
 958
 959 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database
 960 and generate the DDL.
 961
 962 =attr storage
 963
 964 The L<DBIx::Class::Storage> that is I<actually> used to talk to the database
 965 and generate the DDL.  This is automatically created with L</_build_storage>.
 966
 967 =attr sql_translator_args
 968
 969 The arguments that get passed to L<SQL::Translator> when it's used.
 970
 971 =attr script_directory
 972
 973 The directory (default C<'sql'>) that scripts are stored in
 974
 975 =attr databases
 976
 977 The types of databases (default C<< [qw( MySQL SQLite PostgreSQL )] >>) to
 978 generate files for
 979
 980 =attr txn_wrap
 981
 982 Set to true (which is the default) to wrap all upgrades and deploys in a single
 983 transaction.
 984
 985 =attr schema_version
 986
 987 The version the schema on your harddrive is at.  Defaults to
 988 C<< $self->schema->schema_version >>.
 989
 990 =head1 SEE ALSO
 991
 992 This class is an implementation of
 993 L<DBIx::Class::DeploymentHandler::HandlesDeploy>.  Pretty much all the
 994 documentation is there.