X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler%2FDeployMethod%2FSQL%2FTranslator.pm;h=cb07a895c3bf678577042dbb1f9daa5bc225ef79;hb=4d09f7120015cc9b9f50fb80931be05572492229;hp=d3b787a287188f40e868ce48e7340f55a5c282a1;hpb=5020d6a24f9a9b5c37333c0f140839f5b73153cf;p=dbsrgits%2FDBIx-Class-DeploymentHandler.git

diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
index d3b787a..cb07a89 100644
--- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
@@ -5,6 +5,11 @@ use Moose;
 
 use autodie;
 use Carp qw( carp croak );
+use Log::Contextual::WarnLogger;
+use Log::Contextual qw(:log :dlog), -default_logger => Log::Contextual::WarnLogger->new({
+   env_prefix => 'DBICDH'
+});
+use Data::Dumper::Concise;
 
 use Method::Signatures::Simple;
 use Try::Tiny;
@@ -71,7 +76,7 @@ has schema_version => (
 
 # this will probably never get called as the DBICDH
 # will be passing down a schema_version normally, which
-# is built the same way
+# is built the same way, but we leave this in place
 method _build_schema_version { $self->schema->schema_version }
 
 method __ddl_consume_with_prefix($type, $versions, $prefix) {
@@ -92,7 +97,7 @@ method __ddl_consume_with_prefix($type, $versions, $prefix) {
   }
 
   opendir my($dh), $dir;
-  my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl)$/ && -f "$dir/$_" } readdir $dh;
+  my %files = map { $_ => "$dir/$_" } grep { /\.(?:sql|pl|sql-\w+)$/ && -f "$dir/$_" } readdir $dh;
   closedir $dh;
 
   if (-d $common) {
@@ -148,45 +153,74 @@ method _ddl_schema_down_produce_filename($type, $versions, $dir) {
   return catfile( $dirname, '001-auto.sql');
 }
 
-method _run_sql_and_perl($filenames) {
-  my @files = @{$filenames};
+method _run_sql_array($sql) {
   my $storage = $self->storage;
 
+  log_trace { '[DBICDH] Running SQL ' . Dumper($sql) };
+  foreach my $line (@{$sql}) {
+    $storage->_query_start($line);
+    try {
+      # do a dbh_do cycle here, as we need some error checking in
+      # place (even though we will ignore errors)
+      $storage->dbh_do (sub { $_[1]->do($line) });
+    }
+    catch {
+      carp "$_ (running '${line}')"
+    }
+    $storage->_query_end($line);
+  }
+  return join "\n", @$sql
+}
 
-  my $guard = $self->schema->txn_scope_guard if $self->txn_wrap;
+method _run_sql($filename) {
+  log_debug { "[DBICDH] Running SQL from $filename" };
+  return $self->_run_sql_array($self->_read_sql_file($filename));
+}
 
-  my $sql;
-  for my $filename (@files) {
-    if ($filename =~ /\.sql$/) {
-      my @sql = @{$self->_read_sql_file($filename)};
-      $sql .= join "\n", @sql;
-
-      foreach my $line (@sql) {
-        $storage->_query_start($line);
-        try {
-          # do a dbh_do cycle here, as we need some error checking in
-          # place (even though we will ignore errors)
-          $storage->dbh_do (sub { $_[1]->do($line) });
-        }
-        catch {
-          carp "$_ (running '${line}')"
-        }
-        $storage->_query_end($line);
-      }
-    } elsif ( $filename =~ /^(.+)\.pl$/ ) {
-      my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
+method _run_perl($filename) {
+  log_debug { "[DBICDH] Running Perl from $filename" };
+  my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
 
-      no warnings 'redefine';
-      my $fn = eval "$filedata";
-      use warnings;
+  no warnings 'redefine';
+  my $fn = eval "$filedata";
+  use warnings;
+  log_trace { '[DBICDH] Running Perl ' . Dumper($fn) };
 
-      if ($@) {
-        carp "$filename failed to compile: $@";
-      } elsif (ref $fn eq 'CODE') {
-        $fn->($self->schema)
+  if ($@) {
+    carp "$filename failed to compile: $@";
+  } elsif (ref $fn eq 'CODE') {
+    $fn->($self->schema)
+  } else {
+    carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
+  }
+}
+{
+   my $json;
+
+   method _run_serialized_sql($filename, $type) {
+      if ($type eq 'json') {
+         require JSON;
+         $json ||= JSON->new->pretty;
+         my @sql = @{$json->decode($filename)};
       } else {
-        carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
+         croak "A file ($filename) got to deploy that wasn't sql or perl!";
       }
+   }
+
+}
+
+method _run_sql_and_perl($filenames) {
+  my @files   = @{$filenames};
+  my $guard   = $self->schema->txn_scope_guard if $self->txn_wrap;
+
+  my $sql = '';
+  for my $filename (@files) {
+    if ($filename =~ /\.sql$/) {
+       $sql .= $self->_run_sql($filename)
+    } elsif ( $filename =~ /\.sql-(\w+)$/ ) {
+       $sql .= $self->_run_serialized_sql($filename, $1)
+    } elsif ( $filename =~ /\.pl$/ ) {
+       $self->_run_perl($filename)
     } else {
       croak "A file ($filename) got to deploy that wasn't sql or perl!";
     }
@@ -200,6 +234,7 @@ method _run_sql_and_perl($filenames) {
 sub deploy {
   my $self = shift;
   my $version = (shift @_ || {})->{version} || $self->schema_version;
+  log_info { "[DBICDH] deploying version $version" };
 
   return $self->_run_sql_and_perl($self->_ddl_schema_consume_filenames(
     $self->storage->sqlt_type,
@@ -211,6 +246,7 @@ sub preinstall {
   my $self         = shift;
   my $args         = shift;
   my $version      = $args->{version}      || $self->schema_version;
+  log_info { "[DBICDH] preinstalling version $version" };
   my $storage_type = $args->{storage_type} || $self->storage->sqlt_type;
 
   my @files = @{$self->_ddl_preinstall_consume_filenames(
@@ -297,6 +333,7 @@ sub install_resultsource {
   my ($self, $args) = @_;
   my $source          = $args->{result_source};
   my $version         = $args->{version};
+  log_info { '[DBICDH] installing_resultsource ' . $source->source_name . ", version $version" };
   my $rs_install_file =
     $self->_resultsource_install_filename($source->source_name);
 
@@ -312,6 +349,7 @@ sub install_resultsource {
 sub prepare_resultsource_install {
   my $self = shift;
   my $source = (shift @_)->{result_source};
+  log_info { '[DBICDH] preparing install for resultsource ' . $source->source_name };
 
   my $filename = $self->_resultsource_install_filename($source->source_name);
   $self->_prepare_install({
@@ -320,12 +358,17 @@ sub prepare_resultsource_install {
 }
 
 sub prepare_deploy {
+  log_info { '[DBICDH] preparing deploy' };
   my $self = shift;
   $self->_prepare_install({}, '_ddl_schema_produce_filename');
 }
 
 sub prepare_upgrade {
   my ($self, $args) = @_;
+  log_info {
+     '[DBICDH] preparing upgrade ' .
+     "from $args->{from_version} to $args->{to_version}"
+  };
   $self->_prepare_changegrade(
     $args->{from_version}, $args->{to_version}, $args->{version_set}, 'up'
   );
@@ -333,6 +376,10 @@ sub prepare_upgrade {
 
 sub prepare_downgrade {
   my ($self, $args) = @_;
+  log_info {
+     '[DBICDH] preparing downgrade ' .
+     "from $args->{from_version} to $args->{to_version}"
+  };
   $self->_prepare_changegrade(
     $args->{from_version}, $args->{to_version}, $args->{version_set}, 'down'
   );
@@ -453,6 +500,7 @@ method _read_sql_file($file) {
 sub downgrade_single_step {
   my $self = shift;
   my $version_set = (shift @_)->{version_set};
+  log_info { qq([DBICDH] downgrade_single_step'ing ) . Dumper($version_set) };
 
   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_down_consume_filenames(
     $self->storage->sqlt_type,
@@ -465,6 +513,7 @@ sub downgrade_single_step {
 sub upgrade_single_step {
   my $self = shift;
   my $version_set = (shift @_)->{version_set};
+  log_info { qq([DBICDH] upgrade_single_step'ing ) . Dumper($version_set) };
 
   my $sql = $self->_run_sql_and_perl($self->_ddl_schema_up_consume_filenames(
     $self->storage->sqlt_type,