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