much better coderef sandboxing

[dbsrgits/DBIx-Class-DeploymentHandler.git] / lib / DBIx / Class / DeploymentHandler / DeployMethod / SQL / Translator.pm

diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
index e34a6b8..d1385ee 100644 (file)
--- a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
+++ b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
@@ -290,19 +290,35 @@ 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!";