From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 14 Apr 2012 13:00:57 +0000 (+0200)
Subject: Entire test suite now executable under tainted perl (prove -lT)
X-Git-Tag: v0.08197~36
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=f3ec358e1859eb4ab179fda0d93e8c0336c0f8a9

Entire test suite now executable under tainted perl (prove -lT)
---

diff --git a/t/52leaks.t b/t/52leaks.t
index e36e3e9..61a5d2c 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -422,6 +422,12 @@ assert_empty_weakregistry ($weak_registry);
 # this is ugly and dirty but we do not yet have a Test::Embedded or
 # similar
 
+# set up -I
+require Config;
+$ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
+($ENV{PATH}) = $ENV{PATH} =~ /(.+)/;
+
+
 my $persistence_tests = {
   PPerl => {
     cmd => [qw/pperl --prefork=1/, __FILE__],
@@ -446,10 +452,6 @@ SKIP: {
   skip 'Main test failed - skipping persistent env tests', 1
     unless $TB->is_passing;
 
-  # set up -I
-  require Config;
-  local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC);
-
   local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1;
 
   require IPC::Open2;
diff --git a/t/55namespaces_cleaned.t b/t/55namespaces_cleaned.t
index 24cc22b..2205ded 100644
--- a/t/55namespaces_cleaned.t
+++ b/t/55namespaces_cleaned.t
@@ -48,7 +48,7 @@ use DBIx::Class;
 use DBIx::Class::Carp;
 
 my @modules = grep {
-  my $mod = $_;
+  my ($mod) = $_ =~ /(.+)/;
 
   # not all modules are loadable at all times
   do {
diff --git a/t/746sybase.t b/t/746sybase.t
index 33b3bcd..abf6551 100644
--- a/t/746sybase.t
+++ b/t/746sybase.t
@@ -615,7 +615,8 @@ if (Test::Builder->new->is_passing and $ENV{LANG} and $ENV{LANG} ne 'C') {
 
   pass ("Your lang is set to $oldlang - retesting with C");
 
-  my @cmd = ($^X, __FILE__);
+  local $ENV{PATH};
+  my @cmd = map { $_ =~ /(.+)/ } ($^X, __FILE__);
 
   # this is cheating, and may even hang here and there (testing on windows passed fine)
   # will be replaced with Test::SubExec::Noninteractive in due course
diff --git a/t/94versioning.t b/t/94versioning.t
index 7884cad..146c7c3 100644
--- a/t/94versioning.t
+++ b/t/94versioning.t
@@ -185,7 +185,11 @@ my $schema_v3 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_versio
 }
 
 # add a "harmless" comment before one of the statements.
-system( qq($^X -pi.bak -e "s/ALTER/-- this is a comment\nALTER/" $fn->{trans_v23}) );
+{
+  my ($perl) = $^X =~ /(.+)/;
+  local $ENV{PATH};
+  system( qq($perl -pi.bak -e "s/ALTER/-- this is a comment\nALTER/" $fn->{trans_v23}) );
+}
 
 # Then attempt v1 -> v3 upgrade
 {
diff --git a/t/admin/10script.t b/t/admin/10script.t
index 4369971..575e3a6 100644
--- a/t/admin/10script.t
+++ b/t/admin/10script.t
@@ -5,16 +5,17 @@ use warnings;
 use Test::More;
 use Config;
 use lib qw(t/lib);
-$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
 use DBICTest;
 
-
 BEGIN {
     require DBIx::Class;
     plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin_script')
       unless DBIx::Class::Optional::Dependencies->req_ok_for('admin_script');
 }
 
+$ENV{PATH} = '';
+$ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
+
 my @json_backends = qw/XS JSON DWIW/;
 
 # test the script is setting @INC properly
@@ -66,7 +67,9 @@ sub test_dbicadmin {
     SKIP: {
         skip ("MSWin32 doesn't support -| either", 1) if $^O eq 'MSWin32';
 
-        open(my $fh, "-|",  ( $^X, 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
+        my ($perl) = $^X =~ /(.*)/;
+
+        open(my $fh, "-|",  ( $perl, 'script/dbicadmin', default_args(), qw|--op=select --attrs={"order_by":"name"}| ) ) or die $!;
         my $data = do { local $/; <$fh> };
         close($fh);
         if (!ok( ($data=~/Aran.*Trout/s), "$ENV{JSON_ANY_ORDER}: select with attrs" )) {
@@ -94,7 +97,7 @@ sub default_args {
 # calls it. Bleh.
 #
 sub test_exec {
-  my $perl = $^X;
+  my ($perl) = $^X =~ /(.*)/;
 
   my @args = ('script/dbicadmin', @_);
 
diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm
index be36371..d24acbd 100644
--- a/t/lib/DBICTest/Schema.pm
+++ b/t/lib/DBICTest/Schema.pm
@@ -165,7 +165,12 @@ sub connection {
       # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate
       # if we do not do this we may end up trampling over some long-running END or somesuch
       seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!";
-      if (read ($lock_fh, my $old_pid, 100) ) {
+      my $old_pid;
+      if (
+        read ($lock_fh, $old_pid, 100)
+          and
+        ($old_pid) = $old_pid =~ /^(\d+)$/
+      ) {
         for (1..50) {
           kill (0, $old_pid) or last;
           sleep 0.1;