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

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