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