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