[perl #8698] format bug with undefined _TOP

[p5sagit/p5-mst-13.2.git] / t / TEST

diff --git a/t/TEST b/t/TEST
index 5f95d00..7ff34b2 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -21,8 +21,9 @@ if ($#ARGV >= 0) {
        $verbose = 1 if $1 eq 'v';
        $torture = 1 if $1 eq 'torture';
        $with_utf= 1 if $1 eq 'utf8';
-        $bytecompile = 1 if $1 eq 'bytecompile';
-        $compile = 1 if $1 eq 'compile';
+       $bytecompile = 1 if $1 eq 'bytecompile';
+       $compile = 1 if $1 eq 'compile';
+       $taintwarn = 1 if $1 eq 'taintwarn';
        if ($1 =~ /^deparse(,.+)?$/) {
            $deparse = 1;
            $deparse_opts = $1;
@@ -184,6 +185,7 @@ EOT
     # + 3 : we want three dots between the test name and the "ok"
     $dotdotdot = $maxlen + 3 ;
     my $valgrind = 0;
+    my $valgrind_log = 'current.valgrind';
     while ($test = shift @tests) {
 
        if ( $infinite{$test} && $type eq 'compile' ) {
@@ -219,7 +221,13 @@ EOT
            $switch = qq{"-$1"};
        }
        else {
-           $switch = '';
+           if ($taintwarn) {
+               # not all tests are expected to pass with this option
+               $switch = '"-t"';
+           }
+           else {
+               $switch = '';
+           }
        }
 
         my $test_executable; # for 'compile' tests
@@ -245,9 +253,17 @@ EOT
                or print "can't deparse '$deparse': $!.\n";
        }
        elsif ($type eq 'bytecompile') {
-           my $perl = $ENV{PERL} || './perl';
-           my $redir = ($^O eq 'VMS' ? '2>&1' : '');
-           my $bswitch = "-MO=Bytecode,-H,-TI,-s`pwd`/$test,";
+           my ($pwd, $null);
+            if( $^O eq 'MSWin32') {
+               $pwd = `cd`;
+               $null = 'nul';
+           } else {
+               $pwd = `pwd`;
+               $null = '/dev/null';
+           }
+           chomp $pwd;
+           my $perl = $ENV{PERL} || "$pwd/perl";
+           my $bswitch = "-MO=Bytecode,-H,-TI,-s$pwd/$test,";
            $bswitch .= "-TF$test.plc,"
                if $test =~ m(chdir|pod/|CGI/t/carp|lib/DB);
            $bswitch .= "-k,"
@@ -256,18 +272,19 @@ EOT
                if $test =~ m(op/getpid);
            my $bytecompile =
                "$perl $testswitch $switch -I../lib $bswitch". 
-               "-o$test.plc $test 2>/dev/null &&".
-               "$perl $testswitch $switch -I../lib $utf $test.plc $redir|";
+               "-o$test.plc $test 2>$null &&".
+               "$perl $testswitch $switch -I../lib $utf $test.plc |";
            open(RESULTS,$bytecompile)
                or print "can't byte-compile '$bytecompile': $!.\n";
        }
        elsif ($type eq 'perl') {
            my $perl = $ENV{PERL} || './perl';
-           my $redir = ($^O eq 'VMS' || $ENV{PERL_VALGRIND} ? '2>&1' : '');
+           my $redir = $^O eq 'VMS' ? '2>&1' : '';
            if ($ENV{PERL_VALGRIND}) {
                $perl = "valgrind --suppressions=perl.supp --leak-check=yes "
                                . "--leak-resolution=high --show-reachable=yes "
-                               . "--num-callers=50 $perl";
+                               . "--num-callers=50 --logfile-fd=3 $perl";
+               $redir = "3>$valgrind_log";
            }
            my $run = "$perl" . _quote_args("$testswitch $switch $utf") . " $test $redir|";
            open(RESULTS,$run) or print "can't run '$run': $!.\n";
@@ -308,16 +325,11 @@ EOT
         $next = 0;
         my $seen_leader = 0;
         my $seen_ok = 0;
-       my @valgrind;
        while (<RESULTS>) {
            next if /^\s*$/; # skip blank lines
            if ($verbose) {
                print $_;
            }
-           if ($ENV{PERL_VALGRIND} && /^==\d+== /) {
-               push @valgrind, $_;
-               next;
-           }
            unless (/^\#/) {
                if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
                    $max = $1;
@@ -341,7 +353,7 @@ EOT
                        $seen_ok = 1;
                        if ($2 == $next) {
                            my($not, $num, $extra) = ($1, $2, $3);
-                           my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra;
+                           my($istodo) = $extra =~ /#\s*TODO/ if $extra;
                            $istodo = 1 if $todo{$num};
 
                            if( $not && !$istodo ) {
@@ -365,6 +377,15 @@ EOT
        }
        close RESULTS;
        if ($ENV{PERL_VALGRIND}) {
+           my @valgrind;
+           if (-e $valgrind_log) {
+               if (open(V, $valgrind_log)) {
+                   @valgrind = <V>;
+                   close V;
+               } else {
+                   warn "$0: Failed to open '$valgrind_log': $!\n";
+               }
+           }
            if (@valgrind) {
                my $leaks = 0;
                my $errors = 0;
@@ -382,11 +403,7 @@ EOT
                    }
                }
                if ($errors or $leaks) {
-                   if (open(V, ">$test.valgrind")) {
-                       for (@valgrind) {
-                           print V $_;
-                       }
-                       close V;
+                   if (rename $valgrind_log, "$test.valgrind") {
                        $valgrind++;
                    } else {
                        warn "$0: Failed to create '$test.valgrind': $!\n";
@@ -395,6 +412,10 @@ EOT
            } else {
                warn "No valgrind output?\n";
            }
+           if (-e $valgrind_log) {
+               unlink $valgrind_log
+                   or warn "$0: Failed to unlink '$valgrind_log': $!\n";
+           }
        }
        if ($type eq 'deparse') {
            unlink "./$test.dp";