fix silly bug
[dbsrgits/DBIx-Class-DeploymentHandler.git] / lib / DBIx / Class / DeploymentHandler / DeployMethod / SQL / Translator.pm
index 3b46764..45ad608 100644 (file)
@@ -6,7 +6,7 @@ use Moose;
 use autodie;
 use Carp qw( carp croak );
 use DBIx::Class::DeploymentHandler::Logger;
-use Log::Contextual qw(:log :dlog), -default_logger =>
+use Log::Contextual qw(:log :dlog), -package_logger =>
   DBIx::Class::DeploymentHandler::Logger->new({
     env_prefix => 'DBICDH'
   });
@@ -31,6 +31,12 @@ has ignore_ddl => (
   default  => undef,
 );
 
+has force_overwrite => (
+  isa      => 'Bool',
+  is       => 'ro',
+  default  => undef,
+);
+
 has schema => (
   isa      => 'DBIx::Class::Schema',
   is       => 'ro',
@@ -127,14 +133,27 @@ method __ddl_consume_with_prefix($type, $versions, $prefix) {
   return [@files{sort keys %files}]
 }
 
-method _ddl_preinstall_consume_filenames($type, $version) {
-  $self->__ddl_consume_with_prefix($type, [ $version ], 'preinstall')
+method _ddl_initialize_consume_filenames($type, $version) {
+  $self->__ddl_consume_with_prefix($type, [ $version ], 'initialize')
 }
 
 method _ddl_schema_consume_filenames($type, $version) {
   $self->__ddl_consume_with_prefix($type, [ $version ], 'deploy')
 }
 
+method _ddl_protoschema_deploy_consume_filenames($version) {
+  my $base_dir = $self->script_directory;
+
+  my $dir = catfile( $base_dir, '_source', 'deploy', $version);
+  return [] unless -d $dir;
+
+  opendir my($dh), $dir;
+  my %files = map { $_ => "$dir/$_" } grep { /\.yml$/ && -f "$dir/$_" } readdir $dh;
+  closedir $dh;
+
+  return [@files{sort keys %files}]
+}
+
 method _ddl_protoschema_upgrade_consume_filenames($versions) {
   my $base_dir = $self->script_directory;
 
@@ -221,7 +240,7 @@ method _run_sql_array($sql) {
     }
     catch {
       die "$_ (running line '$line')"
-    }
+    };
     $storage->_query_end($line);
   }
   return join "\n", @$sql
@@ -283,7 +302,7 @@ sub deploy {
   my $sql;
   if ($self->ignore_ddl) {
      $sql = $self->_sql_from_yaml({},
-       '_ddl_protoschema_produce_filename', $sqlt_type
+       '_ddl_protoschema_deploy_consume_filenames', $sqlt_type
      );
   }
   return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
@@ -292,14 +311,14 @@ sub deploy {
   ), $sql);
 }
 
-sub preinstall {
+sub initialize {
   my $self         = shift;
   my $args         = shift;
   my $version      = $args->{version}      || $self->schema_version;
-  log_info { "preinstalling version $version" };
+  log_info { "initializing version $version" };
   my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
 
-  my @files = @{$self->_ddl_preinstall_consume_filenames(
+  my @files = @{$self->_ddl_initialize_consume_filenames(
     $storage_type,
     $version,
   )};
@@ -321,7 +340,7 @@ sub preinstall {
         carp "$filename should define an anonymous sub but it didn't!";
       }
     } else {
-      croak "A file ($filename) got to preinstall_scripts that wasn't sql or perl!";
+      croak "A file ($filename) got to initialize_scripts that wasn't sql or perl!";
     }
   }
 }
@@ -400,19 +419,25 @@ method _sql_from_yaml($sqltargs, $from_file, $db) {
   my $schema    = $self->schema;
   my $version   = $self->schema_version;
 
-  my $sqlt = SQL::Translator->new({
-    add_drop_table          => 0,
-    parser                  => 'SQL::Translator::Parser::YAML',
-    %{$sqltargs},
-    producer => $db,
-  });
-
-  my $yaml_filename = $self->$from_file($version);
+  my @sql;
 
-  my @sql = $sqlt->translate($yaml_filename);
-  if(!@sql) {
-    carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
-    return undef;
+  my $actual_file = $self->$from_file($version);
+  for my $yaml_filename (@{
+     DlogS_trace { "generating SQL from Serialized SQL Files: $_" }
+        (ref $actual_file?$actual_file:[$actual_file])
+  }) {
+     my $sqlt = SQL::Translator->new({
+       add_drop_table          => 0,
+       parser                  => 'SQL::Translator::Parser::YAML',
+       %{$sqltargs},
+       producer => $db,
+     });
+
+     push @sql, $sqlt->translate($yaml_filename);
+     if(!@sql) {
+       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
+       return undef;
+     }
   }
   return \@sql;
 }
@@ -431,8 +456,12 @@ sub _prepare_install {
 
     my $filename = $self->$to_file($db, $version, $dir);
     if (-e $filename ) {
-      carp "Overwriting existing DDL file - $filename";
-      unlink $filename;
+      if ($self->force_overwrite) {
+         carp "Overwriting existing DDL file - $filename";
+         unlink $filename;
+      } else {
+         die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
+      }
     }
     open my $file, q(>), $filename;
     print {$file} join ";\n", @$sql;
@@ -455,7 +484,7 @@ sub _resultsource_protoschema_filename {
   my ($self, $source_name) = @_;
   return sub {
     my ($self, $version) = @_;
-    my $dirname = catfile( $self->script_directory, '_source', $version );
+    my $dirname = catfile( $self->script_directory, '_source', 'deploy', $version );
     mkpath($dirname) unless -d $dirname;
 
     return catfile( $dirname, "001-auto-$source_name.yml" );
@@ -464,8 +493,10 @@ sub _resultsource_protoschema_filename {
 
 sub install_resultsource {
   my ($self, $args) = @_;
-  my $source          = $args->{result_source};
-  my $version         = $args->{version};
+  my $source          = $args->{result_source}
+    or die 'result_source must be passed to install_resultsource';
+  my $version         = $args->{version}
+    or die 'version must be passed to install_resultsource';
   log_info { 'installing_resultsource ' . $source->source_name . ", version $version" };
   my $rs_install_file =
     $self->_resultsource_install_filename($source->source_name);
@@ -495,7 +526,10 @@ sub prepare_resultsource_install {
 sub prepare_deploy {
   log_info { 'preparing deploy' };
   my $self = shift;
-  $self->prepare_protoschema({}, '_ddl_protoschema_produce_filename');
+  $self->prepare_protoschema({
+      # Exclude __VERSION so that it gets installed separately
+      parser_args => { sources => [grep { $_ ne '__VERSION' } $self->schema->sources], }
+  }, '_ddl_protoschema_produce_filename');
   $self->_prepare_install({}, '_ddl_protoschema_produce_filename', '_ddl_schema_produce_filename');
 }
 
@@ -534,8 +568,12 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction
   foreach my $db (@$databases) {
     my $diff_file = $self->$diff_file_method($db, $version_set, $dir );
     if(-e $diff_file) {
-      carp("Overwriting existing $direction-diff file - $diff_file");
-      unlink $diff_file;
+      if ($self->force_overwrite) {
+         carp("Overwriting existing $direction-diff file - $diff_file");
+         unlink $diff_file;
+      } else {
+         die "Cannot overwrite '$diff_file', either enable force_overwrite or delete it"
+      }
     }
 
     open my $file, q(>), $diff_file;
@@ -623,8 +661,12 @@ sub prepare_protoschema {
     unless $yml;
 
   if (-e $filename ) {
-    carp "Overwriting existing DDL-YML file - $filename";
-    unlink $filename;
+    if ($self->force_overwrite) {
+       carp "Overwriting existing DDL-YML file - $filename";
+       unlink $filename;
+    } else {
+       die "Cannot overwrite '$filename', either enable force_overwrite or delete it"
+    }
   }
 
   open my $file, q(>), $filename;
@@ -654,10 +696,11 @@ documented here is extra fun stuff or private methods.
 
 =head1 DIRECTORY LAYOUT
 
-Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.  It's
-heavily based upon L<DBIx::Migration::Directories>, but has some extensions and
-modifications, so even if you are familiar with it, please read this.  I feel
-like the best way to describe the layout is with the following example:
+Arguably this is the best feature of L<DBIx::Class::DeploymentHandler>.
+It's spiritually based upon L<DBIx::Migration::Directories>, but has a
+lot of extensions and modifications, so even if you are familiar with it,
+please read this.  I feel like the best way to describe the layout is with
+the following example:
 
  $sql_migration_dir
  |- _source
@@ -691,7 +734,7 @@ like the best way to describe the layout is with the following example:
     |- downgrade
     |  `- 2-1
     |     `- 001-auto.sql
-    |- preinstall
+    |- initialize
     |  `- 1
     |     |- 001-create_database.pl
     |     `- 002-create_users_and_permissions.pl
@@ -715,13 +758,13 @@ would run C<$sql_migration_dir/SQLite/upgrade/1-2/001-auto.sql> followed by
 C<$sql_migration_dir/_common/upgrade/1-2/002-generate-customers.pl>.
 
 C<.pl> files don't have to be in the C<_common> directory, but most of the time
-they should be, because perl scripts are generally be database independent.
+they should be, because perl scripts are generally database independent.
 
-Note that unlike most steps in the process, C<preinstall> will not run SQL, as
-there may not even be an database at preinstall time.  It will run perl scripts
+Note that unlike most steps in the process, C<initialize> will not run SQL, as
+there may not even be an database at initialize time.  It will run perl scripts
 just like the other steps in the process, but nothing is passed to them.
 Until people have used this more it will remain freeform, but a recommended use
-of preinstall is to have it prompt for username and password, and then call the
+of initialize is to have it prompt for username and password, and then call the
 appropriate C<< CREATE DATABASE >> commands etc.
 
 =head2 Directory Specification
@@ -734,6 +777,17 @@ The following subdirectories are recognized by this DeployMethod:
 
 =over 2
 
+=item C<deploy> This directory merely contains directories named after schema
+versions, which in turn contain C<yaml> files that are serialized versions
+of the schema at that version.  These files are not for editing by hand.
+
+=back
+
+=item C<_preprocess_schema> This directory can contain the following
+directories:
+
+=over 2
+
 =item C<downgrade> This directory merely contains directories named after
 migrations, which are of the form C<$from_version-$to_version>.  Inside of
 these directories you may put Perl scripts which are to return a subref
@@ -746,10 +800,6 @@ these directories you may put Perl scripts which are to return a subref
 that takes the arguments C<< $from_schema, $to_schema >>, which are
 L<SQL::Translator::Schema> objects.
 
-=item C<deploy> This directory merely contains directories named after schema
-versions, which in turn contain C<yaml> files that are serialized versions
-of the schema at that version.  These files are not for editing by hand.
-
 =back
 
 =item C<$storage_type> This is a set of scripts that gets run depending on what
@@ -760,7 +810,7 @@ already have.  This directory can containt the following directories itself:
 
 =over 2
 
-=item C<preinstall> Gets run before the C<deploy> is C<deploy>ed.  Has the
+=item C<initialize> Gets run before the C<deploy> is C<deploy>ed.  Has the
 same structure as the C<deploy> subdirectory as well; that is, it has a
 directory for each schema version.  Unlike C<deploy>, C<upgrade>, and C<downgrade>
 though, it can only run C<.pl> files, and the coderef in the perl files get
@@ -808,6 +858,20 @@ A very basic perl script might look like:
    })
  }
 
+=attr ignore_ddl
+
+This attribute will, when set to true (default is false), cause the DM to use
+L<SQL::Translator> to use the C<_source>'s serialized SQL::Translator::Schema
+instead of any pregenerated SQL.  If you have a development server this is
+probably the best plan of action as you will not be putting as many generated
+files in your version control.  Goes well with with C<databases> of C<[]>.
+
+=attr force_overwrite
+
+When this attribute is true generated files will be overwritten when the
+methods which create such files are run again.  The default is false, in which
+case the program will die with a message saying which file needs to be deleted.
+
 =attr schema
 
 The L<DBIx::Class::Schema> (B<required>) that is used to talk to the database