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