From: Peter Rabbitson Date: Sat, 14 Apr 2012 13:00:57 +0000 (+0200) Subject: Entire test suite now executable under tainted perl (prove -lT) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f3ec358e1859eb4ab179fda0d93e8c0336c0f8a9;p=dbsrgits%2FDBIx-Class-Historic.git 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;