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

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