package Test::Harness;
-BEGIN {require 5.002;}
+use 5.005_64;
use Exporter;
use Benchmark;
use Config;
use FileHandle;
use strict;
-use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
- @ISA @EXPORT @EXPORT_OK);
+our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest,
+ @ISA, @EXPORT, @EXPORT_OK);
$have_devel_corestack = 0;
-$VERSION = "1.1602";
+$VERSION = "1.1604";
+
+$ENV{HARNESS_ACTIVE} = 1;
# Some experimental versions of OS/2 build have broken $?
my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
+my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};
+
my $tests_skipped = 0;
my $subtests_skipped = 0;
$verbose = 0;
$switches = "-w";
+sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
+
sub runtests {
my(@tests) = @_;
local($|) = 1;
# 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 }
+ # VMS has a 255-byte limit on the length of %ENV entries, so
+ # toss the ones that involve perl_root, the install location
+ # for VMS
+ my $new5lib;
+ if ($^O eq 'VMS') {
+ $new5lib = join($Config{path_sep}, grep {!/perl_root/i;} @INC);
+ $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
+ }
+ else {
+ $new5lib = join($Config{path_sep}, @INC);
+ }
+ local($ENV{'PERL5LIB'}) = $new5lib;
+
+ my @dir_files = globdir $files_in_dir if defined $files_in_dir;
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));
+ if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./s; }
+ my $blank = (' ' x 77);
+ my $leader = "$te" . '.' x (20 - length($te));
+ my $ml = "";
+ $ml = "\r$blank\r$leader"
+ if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $verbose;
+ print $leader;
my $fh = new FileHandle;
$fh->open($test) or print "can't open $test. $!\n";
my $first = <$fh>;
my $s = $switches;
- $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/;
+ $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
+ if exists $ENV{'HARNESS_PERL_SWITCHES'};
+ $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
+ if $first =~ /^#!.*\bperl.*-\w*T/;
$fh->close or print "can't close $test. $!\n";
- my $cmd = ($ENV{'COMPILE_TEST'})?
-"./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |"
- : "$^X $s $test|";
+ my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
+ ? "./perl -I../lib ../utils/perlcc $test "
+ . "-run 2>> ./compilelog |"
+ : "$^X $s $test|";
$cmd = "MCR $cmd" if $^O eq 'VMS';
$fh->open($cmd) or print "can't run $test. $!\n";
$ok = $next = $max = 0;
my %todo = ();
my $bonus = 0;
my $skipped = 0;
+ my $skip_reason;
while (<$fh>) {
if( $verbose ){
print $_;
$totmax += $max;
$files++;
$next = 1;
- } elsif (/^1\.\.([0-9]+)/) {
+ } elsif (/^1\.\.([0-9]+)(\s*\#\s*[Ss]kip\S*(?>\s+)(.+))?/) {
$max = $1;
$totmax += $max;
$files++;
$next = 1;
+ $skip_reason = $3 if not $max and defined $3;
} elsif ($max && /^(not\s+)?ok\b/) {
my $this = $next;
if (/^not ok\s*(\d*)/){
$this = $1 if $1 > 0;
+ print "${ml}NOK $this" if $ml;
if (!$todo{$this}) {
push @failed, $this;
} else {
$ok++;
$totok++;
}
- } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) {
+ } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?/) {
$this = $1 if $1 > 0;
+ print "${ml}ok $this/$max" if $ml;
$ok++;
$totok++;
$skipped++ if defined $2;
+ my $reason;
+ $reason = 'unknown reason' if defined $2;
+ $reason = $3 if defined $3;
+ if (defined $reason and defined $skip_reason) {
+ # print "was: '$skip_reason' new '$reason'\n";
+ $skip_reason = 'various reasons'
+ if $skip_reason ne $reason;
+ } elsif (defined $reason) {
+ $skip_reason = $reason;
+ }
$bonus++, $totbonus++ if $todo{$this};
}
if ($this > $next) {
: $wstatus >> 8);
if ($wstatus) {
my ($failed, $canon, $percent) = ('??', '??');
- printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
+ printf "${ml}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
} else {
push @failed, $next..$max;
$failed = @failed;
- (my $txt, $canon) = canonfailed($max,@failed);
+ (my $txt, $canon) = canonfailed($max,$skipped,@failed);
$percent = 100*(scalar @failed)/$max;
print "DIED. ",$txt;
}
} elsif ($ok == $max && $next == $max+1) {
if ($max and $skipped + $bonus) {
my @msg;
- push(@msg, "$skipped subtest".($skipped>1?'s':'')." skipped")
+ push(@msg, "$skipped/$max skipped: $skip_reason")
if $skipped;
- push(@msg, "$bonus subtest".($bonus>1?'s':'').
- " unexpectedly succeeded")
+ push(@msg, "$bonus/$max unexpectedly succeeded")
if $bonus;
- print "ok, ".join(', ', @msg)."\n";
+ print "${ml}ok, ".join(', ', @msg)."\n";
} elsif ($max) {
- print "ok\n";
+ print "${ml}ok\n";
+ } elsif (defined $skip_reason) {
+ print "skipped: $skip_reason\n";
+ $tests_skipped++;
} else {
- print "skipping test on this platform\n";
+ print "skipped test on this platform\n";
$tests_skipped++;
}
$good++;
push @failed, $next..$max;
}
if (@failed) {
- my ($txt, $canon) = canonfailed($max,@failed);
+ my ($txt, $canon) = canonfailed($max,$skipped,@failed);
print $txt;
$failedtests{$test} = { canon => $canon, max => $max,
failed => scalar @failed,
};
}
$subtests_skipped += $skipped;
+ if (defined $files_in_dir) {
+ my @new_dir_files = globdir $files_in_dir;
+ if (@new_dir_files != @dir_files) {
+ my %f;
+ @f{@new_dir_files} = (1) x @new_dir_files;
+ delete @f{@dir_files};
+ my @f = sort keys %f;
+ print "LEAKED FILES: @f\n";
+ @dir_files = @new_dir_files;
+ }
+ }
}
my $t_total = timediff(new Benchmark, $t_start);
" UNEXPECTEDLY SUCCEEDED)")
if $totbonus;
if ($tests_skipped) {
- $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '') .
- ' skipped';
+ $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '');
+ if ($subtests_skipped) {
+ $bonusmsg .= " and $subtests_skipped subtest"
+ . ($subtests_skipped != 1 ? 's' : '');
+ }
+ $bonusmsg .= ' skipped';
}
- if ($subtests_skipped) {
- $bonusmsg .= ($tests_skipped ? ', plus ' : ', ').
- "$subtests_skipped subtest"
- . ($subtests_skipped != 1 ? 's' : '') .
- " skipped";
+ elsif ($subtests_skipped) {
+ $bonusmsg .= ", $subtests_skipped subtest"
+ . ($subtests_skipped != 1 ? 's' : '')
+ . " skipped";
}
if ($bad == 0 && $totmax) {
print "All tests successful$bonusmsg.\n";
die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
}
}
- printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
+ printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
return ($bad == 0 && $totmax) ;
}
}
sub canonfailed ($@) {
- my($max,@failed) = @_;
+ my($max,$skipped,@failed) = @_;
my %seen;
@failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
my $failed = @failed;
}
push @result, "\tFailed $failed/$max tests, ";
- push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
+ push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay";
+ my $ender = 's' x ($skipped > 1);
+ my $good = $max - $failed - $skipped;
+ my $goodper = sprintf("%.2f",100*($good/$max));
+ push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped;
+ push @result, "\n";
my $txt = join "", @result;
($txt, $canon);
}
counted as a skipped test. If the whole testscript succeeds, the
count of skipped tests is included in the generated output.
+C<Test::Harness> reports the text after C< # Skip(whatever)> as a
+reason for skipping. Similarly, one can include a similar explanation
+in a C<1..0> line emitted if the test is skipped completely:
+
+ 1..0 # Skipped: no leverage found
+
=head1 EXPORT
C<&runtests> is exported by Test::Harness per default.
=head1 ENVIRONMENT
-Setting C<HARNESS_IGNORE_EXITCODE> makes it ignore the exit status
+Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status
of child processes.
+Setting C<HARNESS_NOTTY> to a true value forces it to behave as though
+STDOUT were not a console. You may need to set this if you don't want
+harness to output more frequent progress messages using carriage returns.
+Some consoles may not handle carriage returns properly (which results
+in a somewhat messy output).
+
+Setting C<HARNESS_COMPILE_TEST> to a true value will make harness attempt
+to compile the test using C<perlcc> before running it.
+
+If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness
+will check after each test whether new files appeared in that directory,
+and report them as
+
+ LEAKED FILES: scr.tmp 0 my.db
+
+If relative, directory name is with respect to the current directory at
+the moment runtests() was called. Putting absolute path into
+C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
+
+The value of C<HARNESS_PERL_SWITCHES> will be prepended to the
+switches used to invoke perl on each test. For example, setting
+C<HARNESS_PERL_SWITCHES> to "-W" will run all tests with all
+warnings enabled.
+
+Harness sets C<HARNESS_ACTIVE> before executing the individual tests.
+This allows the tests to determine if they are being executed through the
+harness or by any other means.
+
=head1 SEE ALSO
L<Test> for writing test scripts and also L<Benchmark> for the
projects / p5sagit/p5-mst-13.2.git / blobdiff