From: Arthur Axel 'fREW' Schmidt <frioux@gmail.com>
Date: Thu, 20 May 2010 04:46:09 +0000 (-0500)
Subject: Use serialized sql instead of vanilla sql
X-Git-Tag: v0.001000_11~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-DeploymentHandler.git;a=commitdiff_plain;h=1f0d0633940a59386e5c0ebec602d0650a3694ed

Use serialized sql instead of vanilla sql
---

diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
index cb07a89..ed05b01 100644
--- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
@@ -79,6 +79,13 @@ has schema_version => (
 # 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;
 
@@ -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,20 +149,27 @@ 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_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);
@@ -194,19 +208,15 @@ method _run_perl($filename) {
     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 {
-         croak "A file ($filename) got to deploy that wasn't sql or perl!";
-      }
-   }
 
+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) {
@@ -286,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,
@@ -307,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 {
@@ -325,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" );
   }
 }
 
@@ -395,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}
@@ -434,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;
@@ -459,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;
@@ -468,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;
 
@@ -486,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};
diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/Deprecated.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/Deprecated.pm
index 813013c..6e7a604 100644
--- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/Deprecated.pm
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator/Deprecated.pm
@@ -6,6 +6,7 @@ use Moose;
 use Method::Signatures::Simple;
 
 use File::Spec::Functions;
+require SQL::Translator::Diff;
 
 extends 'DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator',
 
@@ -39,6 +40,20 @@ method _ddl_schema_up_consume_filenames($type, $versions) {
   return [$self->_ddl_schema_up_produce_filename($type, $versions)]
 }
 
+method _generate_final_diff($source_schema, $dest_schema, $db, $sqltargs) {
+  scalar SQL::Translator::Diff::schema_diff(
+	  $source_schema, $db,
+	  $dest_schema,   $db,
+	  $sqltargs
+  )
+}
+
+method _default_read_sql_file_as_string($file) {
+  do { local( @ARGV, $/ ) = $file; <> } # slurp
+}
+
+method _generate_final_sql($sqlt) { scalar $sqlt->translate }
+
 __PACKAGE__->meta->make_immutable;
 
 1;
diff --git a/t/deploy_methods/sql_translator.t b/t/deploy_methods/sql_translator.t
index f7a7cf2..f9f5bfa 100644
--- a/t/deploy_methods/sql_translator.t
+++ b/t/deploy_methods/sql_translator.t
@@ -36,7 +36,7 @@ VERSION1: {
    close $prerun;
    $dm->preinstall({ version => '1.0' });
 
-   ok -e 'foobar';
+   ok -e 'foobar', 'perl migration runs';
 
    {
       my $warned = 0;
@@ -51,7 +51,7 @@ VERSION1: {
    close $common;
 
    ok(
-      -f catfile(qw( t sql SQLite schema 1.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite schema 1.0 001-auto.sql-json )),
       '1.0 schema gets generated properly'
    );
 
@@ -96,7 +96,7 @@ VERSION2: {
    $version = $s->schema_version();
    $dm->prepare_deploy;
    ok(
-      -f catfile(qw( t sql SQLite schema 2.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite schema 2.0 001-auto.sql-json )),
       '2.0 schema gets generated properly'
    );
    mkpath(catfile(qw( t sql SQLite up 1.0-2.0 )));
@@ -117,7 +117,7 @@ VERSION2: {
       ok( $warned, 'prepare_upgrade with a bogus preversion warns' );
    }
    ok(
-      -f catfile(qw( t sql SQLite up 1.0-2.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite up 1.0-2.0 001-auto.sql-json )),
       '1.0-2.0 diff gets generated properly and default start and end versions get set'
    );
    mkpath(catfile(qw( t sql SQLite down 2.0-1.0 )));
@@ -127,7 +127,7 @@ VERSION2: {
      version_set => [$version, '1.0']
    });
    ok(
-      -f catfile(qw( t sql SQLite down 2.0-1.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite down 2.0-1.0 001-auto.sql-json )),
       '2.0-1.0 diff gets generated properly'
    );
    dies_ok {
@@ -203,7 +203,7 @@ VERSION3: {
    $version = $s->schema_version();
    $dm->prepare_deploy;
    ok(
-      -f catfile(qw( t sql SQLite schema 3.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite schema 3.0 001-auto.sql-json )),
       '2.0 schema gets generated properly'
    );
    $dm->prepare_downgrade({
@@ -212,7 +212,7 @@ VERSION3: {
      version_set => [$version, '1.0']
    });
    ok(
-      -f catfile(qw( t sql SQLite down 3.0-1.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite down 3.0-1.0 001-auto.sql-json )),
       '3.0-1.0 diff gets generated properly'
    );
    $dm->prepare_upgrade({
@@ -221,7 +221,7 @@ VERSION3: {
      version_set => ['1.0', $version]
    });
    ok(
-      -f catfile(qw( t sql SQLite up 1.0-3.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite up 1.0-3.0 001-auto.sql-json )),
       '1.0-3.0 diff gets generated properly'
    );
    $dm->prepare_upgrade({
@@ -240,11 +240,11 @@ VERSION3: {
       ok( $warned, 'prepare_upgrade warns if you clobber an existing upgrade file' );
    }
    ok(
-      -f catfile(qw( t sql SQLite up 1.0-2.0 001-auto.sql )),
+      -f catfile(qw( t sql SQLite up 1.0-2.0 001-auto.sql-json )),
       '2.0-3.0 diff gets generated properly'
    );
    mkpath catfile(qw( t sql _generic up 2.0-3.0 ));
-   rename catfile(qw( t sql SQLite up 2.0-3.0 001-auto.sql )), catfile(qw( t sql _generic up 2.0-3.0 001-auto.sql ));
+   rename catfile(qw( t sql SQLite up 2.0-3.0 001-auto.sql-json )), catfile(qw( t sql _generic up 2.0-3.0 001-auto.sql-json ));
    rmtree(catfile(qw( t sql SQLite )));
    warn 'how can this be' if -d catfile(qw( t sql SQLite ));
    dies_ok {