package Test::Harness;
-use 5.002;
+BEGIN {require 5.002;}
use Exporter;
use Benchmark;
use Config;
@ISA @EXPORT @EXPORT_OK);
$have_devel_corestack = 0;
-$VERSION = "1.12";
+$VERSION = "1.1502";
@ISA=('Exporter');
@EXPORT= qw(&runtests);
format STDOUT_TOP =
Failed Test Status Wstat Total Fail Failed List of failed
-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
.
format STDOUT =
-@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
{ $curtest->{name},
$curtest->{estat},
$curtest->{wstat},
$curtest->{percent},
$curtest->{canon}
}
+~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ $curtest->{canon}
.
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 = ();
+ my $skipped = 0;
while (<$fh>) {
if( $verbose ){
print $_;
if (/^not ok\s*(\d*)/){
$this = $1 if $1 > 0;
push @failed, $this;
- } elsif (/^ok\s*(\d*)/) {
+ } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) {
$this = $1 if $1 > 0;
$ok++;
$totok++;
+ $skipped++ if defined $2;
}
if ($this > $next) {
# warn "Test output counter mismatch [test $this]\n";
}
$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) {
- print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n";
+ my $estatus;
+ $estatus = ($^O eq 'VMS'
+ ? eval 'use vmsish "status"; $estatus = $?'
+ : $wstatus >> 8);
+ if ($wstatus) {
+ my ($failed, $canon, $percent) = ('??', '??');
+ printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
+ $wstatus,$wstatus;
+ 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);
}
}
$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) {
- if ($max) {
+ if ($max and $skipped) {
+ my $ender = 's' x ($skipped > 1);
+ print "ok, $skipped subtest$ender skipped on this platform\n";
+ } elsif ($max) {
print "ok\n";
} else {
print "skipping test on this platform\n";
}
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){
$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);
$ret = WCOREDUMP($st);
}
- eval {require Devel::CoreStack};
- $have_devel_corestack++ unless $@;
+ eval { require Devel::CoreStack; $have_devel_corestack++ }
+ unless $tried_devel_corestack++;
$ret;
}
used to let runtests() display the standard output of the script
without altering the behavior otherwise.
+The global variable $Test::Harness::switches is exportable and can be
+used to set perl command line options used for running the test
+script(s). The default value is C<-w>.
+
+If the standard output line contains substring C< # Skip> (with
+variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
+counted as a skipped test. If the whole testscript succeeds, the
+count of skipped tests is included in the generated output.
+
=head1 EXPORT
C<&runtests> is exported by Test::Harness per default.
=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>
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
projects / p5sagit/p5-mst-13.2.git / blobdiff