From: Arthur Axel 'fREW' Schmidt <frioux@gmail.com>
Date: Sat, 3 Mar 2012 19:14:14 +0000 (-0600)
Subject: much better coderef sandboxing
X-Git-Tag: v0.002100~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a89cd737a24077f9d021d975a8ee628dc23bfb06;p=dbsrgits%2FDBIx-Class-DeploymentHandler.git

much better coderef sandboxing
---

diff --git a/Changes b/Changes
index b574754..9608cb7 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,9 @@
 Revision history for {{$dist->name}}
 
 {{$NEXT}}
+       - Added better sandboxing (stolen straight from Plack::Util) for coderefs
+         to avoid accidental leakage
+       - Sandboxing also makes $0 and thus FindBin et al work in perl scripts
 
 0.002000  2012-02-28 21:20:48 CST6CDT
        - Added DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator::ScriptHelpers,
diff --git a/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm b/lib/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm
index e34a6b8..d1385ee 100644
--- 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!";
diff --git a/t/deploy_methods/coderef-leakage.t b/t/deploy_methods/coderef-leakage.t
new file mode 100644
index 0000000..7254ca7
--- /dev/null
+++ b/t/deploy_methods/coderef-leakage.t
@@ -0,0 +1,45 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use aliased 'DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator';
+use File::Temp;
+
+use lib 't/lib';
+
+use DBICDHTest;
+
+my $dbh = DBICDHTest::dbh();
+my @connection = (sub { $dbh }, { ignore_version => 1 });
+
+DBICDHTest::ready;
+
+use_ok 'DBICVersion_v1';
+my $s = DBICVersion::Schema->connect(@connection);
+my $dm = Translator->new({ schema => $s });
+
+my ($fname1, $fname2) = @_;
+
+{
+   my $fh = File::Temp->new(UNLINK => 0);
+   print {$fh} 'sub leak {} sub { leak() }';
+   $fname1 = $fh->filename;
+   close $fh;
+}
+
+{
+   my $fh = File::Temp->new(UNLINK => 0);
+   print {$fh} 'sub { leak() }';
+   $fname2 = $fh->filename;
+   close $fh;
+}
+
+$dm->_run_perl($fname1, [1]);
+dies_ok { $dm->_run_perl($fname2, [1]) } 'info should not leak between coderefs';
+
+done_testing;
+
+END { unlink $fname1; unlink $fname2 }