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