Sys::Hostname fails under Solaris 2.5 when setuid

[p5sagit/p5-mst-13.2.git] / lib / Test / Harness.pm

diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index cca05b7..24e9148 100644 (file)
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -1,7 +1,6 @@
 package Test::Harness;
 
-require 5.002;
-
+BEGIN {require 5.002;}
 use Exporter;
 use Benchmark;
 use Config;
@@ -12,7 +11,7 @@ use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
            @ISA @EXPORT @EXPORT_OK);
 $have_devel_corestack = 0;
 
-$VERSION = "1.13";
+$VERSION = "1.1502";
 
 @ISA=('Exporter');
 @EXPORT= qw(&runtests);
@@ -48,17 +47,28 @@ sub runtests {
     my $bad = 0;
     my $good = 0;
     my $total = @tests;
+
+    # pass -I flags to children
     my $old5lib = $ENV{PERL5LIB};
-    local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children
+    local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC);
+
+    if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g }
 
     my $t_start = new Benchmark;
     while ($test = shift(@tests)) {
        $te = $test;
        chop($te);
+       if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./; }
        print "$te" . '.' x (20 - length($te));
        my $fh = new FileHandle;
-       if ($^O eq 'VMS') { $fh->open("MCR $^X $switches $test|") || (print "can't run. $!\n"); }
-       else              { $fh->open("$^X $switches $test|")     || (print "can't run. $!\n"); }
+       $fh->open($test) or print "can't open $test. $!\n";
+       my $first = <$fh>;
+       my $s = $switches;
+       $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/;
+       $fh->close or print "can't close $test. $!\n";
+       my $cmd = "$^X $s $test|";
+       $cmd = "MCR $cmd" if $^O eq 'VMS';
+       $fh->open($cmd) or print "can't run $test. $!\n";
        $ok = $next = $max = 0;
        @failed = ();
        while (<$fh>) {
@@ -94,9 +104,14 @@ sub runtests {
        }
        $fh->close; # must close to reap child resource values
        my $wstatus = $?;
-       my $estatus = $^O eq 'VMS' ? $wstatus : $wstatus >> 8;
-       if ($^O eq 'VMS' ? !($wstatus & 1) : $wstatus) {
+       my $estatus;
+       $estatus = ($^O eq 'VMS'
+                      ? eval 'use vmsish "status"; $estatus = $?'
+                      : $wstatus >> 8);
+       if ($wstatus) {
+           my ($failed, $canon, $percent) = ('??', '??');
            print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n";
+           print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
            if (corestatus($wstatus)) { # until we have a wait module
                if ($have_devel_corestack) {
                    Devel::CoreStack::stack($^X);
@@ -105,9 +120,22 @@ sub runtests {
                }
            }
            $bad++;
-           $failedtests{$test} = { canon => '??',  max => $max || '??',
-                                   failed => '??', 
-                                   name => $test, percent => undef,
+           if ($max) {
+             if ($next == $max + 1 and not @failed) {
+               print "\tafter all the subtests completed successfully\n";
+               $percent = 0;
+               $failed = 0;    # But we do not set $canon!
+             } else {
+               push @failed, $next..$max;
+               $failed = @failed;
+               (my $txt, $canon) = canonfailed($max,@failed);
+               $percent = 100*(scalar @failed)/$max;
+               print "DIED. ",$txt;
+             }
+           }
+           $failedtests{$test} = { canon => $canon,  max => $max || '??',
+                                   failed => $failed, 
+                                   name => $test, percent => $percent,
                                    estat => $estatus, wstat => $wstatus,
                                  };
        } elsif ($ok == $max && $next == $max+1) {
@@ -150,7 +178,13 @@ sub runtests {
     }
     my $t_total = timediff(new Benchmark, $t_start);
     
-    if ($^O eq 'VMS' and defined($old5lib)) { $ENV{PERL5LIB} = $old5lib; }
+    if ($^O eq 'VMS') {
+       if (defined $old5lib) {
+           $ENV{PERL5LIB} = $old5lib;
+       } else {
+           delete $ENV{PERL5LIB};
+       }
+    }
     if ($bad == 0 && $totmax) {
            print "All tests successful.\n";
     } elsif ($total==0){
@@ -167,7 +201,7 @@ sub runtests {
          $curtest = $failedtests{$script};
          write;
        }
-       if ($bad > 1) {
+       if ($bad) {
            die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
        }
     }
@@ -176,6 +210,7 @@ sub runtests {
     return ($bad == 0 && $totmax) ;
 }
 
+my $tried_devel_corestack;
 sub corestatus {
     my($st) = @_;
     my($ret);
@@ -189,8 +224,8 @@ sub corestatus {
        $ret = WCOREDUMP($st);
     }
 
-    eval {require Devel::CoreStack};
-    $have_devel_corestack++ unless $@;
+    eval { require Devel::CoreStack; $have_devel_corestack++ } 
+      unless $tried_devel_corestack++;
 
     $ret;
 }
@@ -326,8 +361,8 @@ See L<Benchmark> for the underlying timing routines.
 
 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 sure is, that it was inspired by Larry Wall's TEST script that came
-with perl distributions for ages. Current maintainer is Andreas
-Koenig.
+with perl distributions for ages. Numerous anonymous contributors
+exist. Current maintainer is Andreas Koenig.
 
 =head1 BUGS