X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-DeploymentHandler.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FDeploymentHandler%2FDeployMethod%2FSQL%2FTranslator.pm;h=cee797faf54556ebb9e06912e9d41d5a19fe76fa;hp=5fb6918461f21e868ef16bf9e3d16f72b3f2ace1;hb=32bd7c454317d19db26bd3034a1d0ca9eabd55db;hpb=115c68ce0fc0e56265d201a8f7bbcf912efa86db

diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
index 5fb6918..cee797f 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));
 }
 
+sub _load_sandbox {
+  my $_file = shift;
+
+  my $_package = $_file;
+  $_package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", ord($1))/eg;
+
+  my $fn = eval sprintf <<'END_EVAL', $_package;
+package DBICDH::Sandbox::%s;
+{
+  our $app;
+  $app ||= require $_file;
+  if ( !$app && ( my $error = $@ || $! )) { die $error; }
+  $app;
+}
+END_EVAL
+
+  croak $@ if $@;
+
+  croak "$_file should define an anonymouse sub that takes a schema but it didn't!"
+     unless ref $fn && ref $fn eq 'CODE';
+
+  return $fn;
+}
+
 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') {
-    $fn->($self->schema, $versions)
-  } else {
-    croak "$filename should define an anonymouse sub that takes a schema but it didn't!";
-  }
+  $fn->($self->schema, $versions)
 }
 
-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 {
@@ -897,7 +921,10 @@ A very basic perl script might look like:
  use strict;
  use warnings;
 
- sub {
+ use DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers
+    'schema_from_schema_loader';
+
+ schema_from_schema_loader({ naming => 'v4' }, sub {
    my $schema = shift;
 
    # [1] for deploy, [1,2] for upgrade or downgrade, probably used with _any
@@ -907,7 +934,12 @@ A very basic perl script might look like:
      name => 'root',
      password => 'root',
    })
- }
+ })
+
+Note that the above uses
+L<DBIx::Class::DeploymentHanlder::DeployMethod::SQL::Translator::ScriptHelpers/schema_from_schema_loader>.
+Using a raw coderef is strongly discouraged as it is likely to break as you
+modify your schema.
 
 =attr ignore_ddl
 
@@ -955,3 +987,9 @@ transaction.
 
 The version the schema on your harddrive is at.  Defaults to
 C<< $self->schema->schema_version >>.
+
+=head1 SEE ALSO
+
+This class is an implementation of
+L<DBIx::Class::DeploymentHandler::HandlesDeploy>.  Pretty much all the
+documentation is there.