X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler%2FDeployMethod%2FSQL%2FTranslator.pm;h=16f97cd39b93c1b6dae306cb4e0ad62245275d3f;hb=1fcd4fe6717e0809422856c89673fc78b43174bb;hp=e34a6b84aa5437df93a57c5b80dbc18f4299c297;hpb=57a30fa87043ef203551cc84797133cc88dd03bd;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 e34a6b8..16f97cd 100644
--- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
@@ -10,6 +10,7 @@ use Log::Contextual qw(:log :dlog), -package_logger =>
   DBIx::Class::DeploymentHandler::Logger->new({
     env_prefix => 'DBICDH'
   });
+use Context::Preserve;
 
 use Try::Tiny;
 
@@ -290,49 +291,72 @@ sub _run_sql {
   return $self->_run_sql_array($self->_read_sql_file($filename));
 }
 
+# stolen from Plack::Util::_load_sandbox
+sub _load_sandbox {
+  my $_file = shift;
+
+  my $_package = $_file;
+  $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
+
+  local $0 = $_file; # so FindBin etc. works
+
+  return eval sprintf <<'END_EVAL', $_package;
+package DBICDH::Sandbox::%s;
+{
+  my $app = do $_file;
+  if ( !$app && ( my $error = $@ || $! )) { die $error; }
+  $app;
+}
+END_EVAL
+}
+
 sub _run_perl {
   my ($self, $filename, $versions) = @_;
   log_debug { "Running Perl from $filename" };
   my $filedata = do { local( @ARGV, $/ ) = $filename; <> };
 
-  no warnings 'redefine';
-  my $fn = eval "$filedata";
-  use warnings;
+  my $fn = _load_sandbox($filename);
+
   Dlog_trace { "Running Perl $_" } $fn;
 
-  if ($@) {
-    croak "$filename failed to compile: $@";
-  } elsif (ref $fn eq 'CODE') {
+  if (ref $fn eq 'CODE') {
     $fn->($self->schema, $versions)
   } else {
     croak "$filename should define an anonymouse sub that takes a schema but it didn't!";
   }
 }
 
-sub _run_sql_and_perl {
-  my ($self, $filenames, $sql_to_run, $versions) = @_;
-  my @files   = @{$filenames};
-  my $guard   = $self->schema->txn_scope_guard if $self->txn_wrap;
+sub txn_do {
+   my ( $self, $code ) = @_;
+   return $code->() unless $self->txn_wrap;
 
-  $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
+   my $guard = $self->schema->txn_scope_guard;
 
-  my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
-  FILENAME:
-  for my $filename (@files) {
-    if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
-      next FILENAME
-    } elsif ($filename =~ /\.sql$/) {
-       $sql .= $self->_run_sql($filename)
-    } elsif ( $filename =~ /\.pl$/ ) {
-       $self->_run_perl($filename, $versions)
-    } else {
-      croak "A file ($filename) got to deploy that wasn't sql or perl!";
-    }
-  }
+   return preserve_context { $code->() } after => sub { $guard->commit };
+}
 
-  $guard->commit if $self->txn_wrap;
+sub _run_sql_and_perl {
+  my ($self, $filenames, $sql_to_run, $versions) = @_;
+  my @files   = @{$filenames};
+  $self->txn_do(sub {
+     $self->_run_sql_array($sql_to_run) if $self->ignore_ddl;
+
+     my $sql = ($sql_to_run)?join ";\n", @$sql_to_run:'';
+     FILENAME:
+     for my $filename (@files) {
+       if ($self->ignore_ddl && $filename =~ /^[^_]*-auto.*\.sql$/) {
+         next FILENAME
+       } elsif ($filename =~ /\.sql$/) {
+          $sql .= $self->_run_sql($filename)
+       } elsif ( $filename =~ /\.pl$/ ) {
+          $self->_run_perl($filename, $versions)
+       } else {
+         croak "A file ($filename) got to deploy that wasn't sql or perl!";
+       }
+     }
 
-  return $sql;
+     return $sql;
+  });
 }
 
 sub deploy {