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