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 387c40c..24e9148 100644 (file)
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -1,6 +1,6 @@
 package Test::Harness;
 
-use 5.002;
+BEGIN {require 5.002;}
 use Exporter;
 use Benchmark;
 use Config;
@@ -11,7 +11,7 @@ use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
            @ISA @EXPORT @EXPORT_OK);
 $have_devel_corestack = 0;
 
-$VERSION = "1.12";
+$VERSION = "1.1502";
 
 @ISA=('Exporter');
 @EXPORT= qw(&runtests);
@@ -47,15 +47,28 @@ sub runtests {
     my $bad = 0;
     my $good = 0;
     my $total = @tests;
-    local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children
+
+    # pass -I flags to children
+    my $old5lib = $ENV{PERL5LIB};
+    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;
-       $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>) {
@@ -91,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);
@@ -102,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) {
@@ -147,6 +178,13 @@ sub runtests {
     }
     my $t_total = timediff(new Benchmark, $t_start);
     
+    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){
@@ -163,13 +201,16 @@ sub runtests {
          $curtest = $failedtests{$script};
          write;
        }
-       if ($bad > 1) {
+       if ($bad) {
            die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
        }
     }
     printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
+
+    return ($bad == 0 && $totmax) ;
 }
 
+my $tried_devel_corestack;
 sub corestatus {
     my($st) = @_;
     my($ret);
@@ -183,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;
 }
@@ -300,7 +341,7 @@ above are printed.
 
 =item C<Test returned status %d (wstat %d)>
 
-Scripts that return a non-zero exit status, both $?>>8 and $? are
+Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
 printed in a message similar to the above.
 
 =item C<Failed 1 test, %.2f%% okay. %s>
@@ -320,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