X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler%2FDeployMethod%2FSQL%2FTranslator.pm;h=ed05b01f70b77e302321839037a752e9f6d63f72;hb=1f0d0633940a59386e5c0ebec602d0650a3694ed;hp=6f183fce65da28daa472ff98585e0379ad5f232c;hpb=0df68524a051e42f1a7f8606aee56e7c6b70b302;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 6f183fc..ed05b01 100644
--- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
@@ -76,9 +76,16 @@ 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 }
 
+has _json => (
+  is => 'ro',
+  lazy_build => 1,
+);
+
+sub _build__json { require JSON; JSON->new->pretty }
+
 method __ddl_consume_with_prefix($type, $versions, $prefix) {
   my $base_dir = $self->script_directory;
 
@@ -97,7 +104,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) {
@@ -125,7 +132,7 @@ method _ddl_schema_produce_filename($type, $version) {
   my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
   mkpath($dirname) unless -d $dirname;
 
-  return catfile( $dirname, '001-auto.sql' );
+  return catfile( $dirname, '001-auto.sql-json' );
 }
 
 method _ddl_schema_up_consume_filenames($type, $versions) {
@@ -142,60 +149,88 @@ method _ddl_schema_up_produce_filename($type, $versions) {
   my $dirname = catfile( $dir, $type, 'up', join q(-), @{$versions});
   mkpath($dirname) unless -d $dirname;
 
-  return catfile( $dirname, '001-auto.sql'
-  );
+  return catfile( $dirname, '001-auto.sql-json' );
 }
 
 method _ddl_schema_down_produce_filename($type, $versions, $dir) {
   my $dirname = catfile( $dir, $type, 'down', join q(-), @{$versions} );
   mkpath($dirname) unless -d $dirname;
 
-  return catfile( $dirname, '001-auto.sql');
+  return catfile( $dirname, '001-auto.sql-json');
 }
 
-method _run_sql_and_perl($filenames) {
-  my @files = @{$filenames};
+method _run_sql_array($sql) {
   my $storage = $self->storage;
 
+  $sql = [grep {
+    $_ && # remove blank lines
+    !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
+  } map {
+    s/^\s+//; s/\s+$//; # trim whitespace
+    join '', grep { !/^--/ } split /\n/ # remove comments
+  } @$sql];
+
+  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$/) {
-      log_debug { "[DBICDH] Running SQL from $filename" };
-      my @sql = @{$self->_read_sql_file($filename)};
-      $sql .= join "\n", @sql;
-      log_trace { "[DBICDH] Running SQL $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$/ ) {
-      log_debug { "[DBICDH] Running Perl from $filename" };
-      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;
-      log_trace { '[DBICDH] Running Perl ' . Dumper($fn) };
+  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)
-      } else {
-        carp "$filename should define an anonymouse sub that takes a schema but it didn't!";
-      }
+  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!";
+  }
+}
+
+method _run_serialized_sql($filename, $type) {
+  if (lc $type eq 'json') {
+    return $self->_run_sql_array($self->_json->decode(
+      do { local( @ARGV, $/ ) = $filename; <> } # slurp
+    ))
+  } else {
+    croak "$type is not one of the supported serialzed types"
+  }
+}
+
+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!";
     }
@@ -261,6 +296,7 @@ sub _prepare_install {
   my $version   = $self->schema_version;
 
   my $sqlt = SQL::Translator->new({
+    no_comments             => 1,
     add_drop_table          => 1,
     ignore_constraint_names => 1,
     ignore_index_names      => 1,
@@ -282,17 +318,22 @@ sub _prepare_install {
       unlink $filename;
     }
 
-    my $output = $sqlt->translate;
-    if(!$output) {
+    my $sql = $self->_generate_final_sql($sqlt);
+    if(!$sql) {
       carp("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
       next;
     }
     open my $file, q(>), $filename;
-    print {$file} $output;
+    print {$file} $sql;
     close $file;
   }
 }
 
+method _generate_final_sql($sqlt) {
+  my @output = $sqlt->translate;
+  $self->_json->encode(\@output);
+}
+
 sub _resultsource_install_filename {
   my ($self, $source_name) = @_;
   return sub {
@@ -300,7 +341,7 @@ sub _resultsource_install_filename {
     my $dirname = catfile( $self->script_directory, $type, 'schema', $version );
     mkpath($dirname) unless -d $dirname;
 
-    return catfile( $dirname, "001-auto-$source_name.sql" );
+    return catfile( $dirname, "001-auto-$source_name.sql-json" );
   }
 }
 
@@ -370,6 +411,7 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction
 
   $sqltargs = {
     add_drop_table => 1,
+    no_comments => 1,
     ignore_constraint_names => 1,
     ignore_index_names => 1,
     %{$sqltargs}
@@ -409,7 +451,8 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction
       $t->parser( $db ) # could this really throw an exception?
         or croak($t->error);
 
-      my $out = $t->translate( $prefilename )
+      my $sql = $self->_default_read_sql_file_as_string($prefilename);
+      my $out = $t->translate( \$sql )
         or croak($t->error);
 
       $source_schema = $t->schema;
@@ -434,7 +477,8 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction
         or croak($t->error);
 
       my $filename = $self->_ddl_schema_produce_filename($db, $to_version, $dir);
-      my $out = $t->translate( $filename )
+      my $sql = $self->_default_read_sql_file_as_string($filename);
+      my $out = $t->translate( \$sql )
         or croak($t->error);
 
       $dest_schema = $t->schema;
@@ -443,17 +487,23 @@ method _prepare_changegrade($from_version, $to_version, $version_set, $direction
         unless $dest_schema->name;
     }
 
-    my $diff = SQL::Translator::Diff::schema_diff(
-       $source_schema, $db,
-       $dest_schema,   $db,
-       $sqltargs
-    );
     open my $file, q(>), $diff_file;
-    print {$file} $diff;
+    print {$file}
+      $self->_generate_final_diff($source_schema, $dest_schema, $db, $sqltargs);
     close $file;
   }
 }
 
+method _generate_final_diff($source_schema, $dest_schema, $db, $sqltargs) {
+  $self->_json->encode([
+     SQL::Translator::Diff::schema_diff(
+        $source_schema, $db,
+        $dest_schema,   $db,
+        $sqltargs
+     )
+  ])
+}
+
 method _read_sql_file($file) {
   return unless $file;
 
@@ -461,17 +511,15 @@ method _read_sql_file($file) {
   my @data = split /;\n/, join '', <$fh>;
   close $fh;
 
-  @data = grep {
-    $_ && # remove blank lines
-    !/^(BEGIN|BEGIN TRANSACTION|COMMIT)/ # strip txn's
-  } map {
-    s/^\s+//; s/\s+$//; # trim whitespace
-    join '', grep { !/^--/ } split /\n/ # remove comments
-  } @data;
-
   return \@data;
 }
 
+method _default_read_sql_file_as_string($file) {
+  return join q(), map "$_;\n", @{$self->_json->decode(
+    do { local( @ARGV, $/ ) = $file; <> } # slurp
+  )};
+}
+
 sub downgrade_single_step {
   my $self = shift;
   my $version_set = (shift @_)->{version_set};