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

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