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