# -*- Mode: cperl; cperl-indent-level: 4 -*-
-# $Id: Harness.pm,v 1.11 2001/05/23 18:24:41 schwern Exp $
+# $Id: Harness.pm,v 1.38 2002/06/19 21:01:01 schwern Exp $
package Test::Harness;
require 5.004;
+use Test::Harness::Straps;
+use Test::Harness::Assert;
use Exporter;
use Benchmark;
use Config;
use strict;
use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest
- $Columns $verbose $switches
+ $Columns $verbose $switches $ML $Strap
@ISA @EXPORT @EXPORT_OK
);
$Have_Devel_Corestack = 0;
-$VERSION = "1.21";
+$VERSION = '2.26';
$ENV{HARNESS_ACTIVE} = 1;
+END {
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+}
+
# 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};
+$Strap = Test::Harness::Straps->new;
@ISA = ('Exporter');
@EXPORT = qw(&runtests);
@EXPORT_OK = qw($verbose $switches);
-$Verbose = 0;
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
$Switches = "-w";
$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
$Columns--; # Some shells have trouble with a full line of text.
=item B<'1..M'>
-This header tells how many tests there will be. It should be the
-first line output by your test program (but its okay if its preceded
-by comments).
+This header tells how many tests there will be. For example, C<1..10>
+means you plan on running 10 tests. This is a safeguard in case your
+test dies quietly in the middle of its run.
+
+It should be the first non-comment line output by your test program.
-In certain instanced, you may not know how many tests you will
-ultimately be running. In this case, it is permitted (but not
-encouraged) for the 1..M header to appear as the B<last> line output
-by your test (again, it can be followed by further comments). But we
-strongly encourage you to put it first.
+In certain instances, you may not know how many tests you will
+ultimately be running. In this case, it is permitted for the 1..M
+header to appear as the B<last> line output by your test (again, it
+can be followed by further comments).
Under B<no> circumstances should 1..M appear in the middle of your
output or more than once.
FAILED tests 1, 3, 6
Failed 3/6 tests, 50.00% okay
+=item B<test names>
-=item B<$Test::Harness::verbose>
+Anything after the test number but before the # is considered to be
+the name of the test.
-The global variable $Test::Harness::verbose is exportable and can be
-used to let runtests() display the standard output of the script
-without altering the behavior otherwise.
-
-=item B<$Test::Harness::switches>
+ ok 42 this is the name of the test
-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>.
+Currently, Test::Harness does nothing with this information.
=item B<Skipping tests>
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\S*\s+> as a reason
-for skipping.
+for skipping.
ok 23 # skip Insufficient flogiston pressure.
not ok 13 # TODO harness the power of the atom
+=begin _deprecated
+
+Alternatively, you can specify a list of what tests are todo as part
+of the test header.
+
+ 1..23 todo 5 12 23
+
+This only works if the header appears at the beginning of the test.
+
+This style is B<deprecated>.
+
+=end _deprecated
+
These tests represent a feature to be implemented or a bug to be fixed
and act as something of an executable "thing to do" list. They are
B<not> expected to succeed. Should a todo test begin succeeding,
=back
+=head2 Taint mode
+
+Test::Harness will honor the C<-T> in the #! line on your test files. So
+if you begin a test with:
+
+ #!perl -T
+
+the test will be run with taint mode on.
+
+
+=head2 Configuration variables.
+
+These variables can be used to configure the behavior of
+Test::Harness. They are exported on request.
+
+=over 4
+
+=item B<$Test::Harness::verbose>
+
+The global variable $Test::Harness::verbose is exportable and can be
+used to let runtests() display the standard output of the script
+without altering the behavior otherwise.
+
+=item B<$Test::Harness::switches>
+
+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>.
+
+=back
+
+
=head2 Failure
It will happen, your tests will fail. After you mop up your ego, you
can begin examining the summary report:
- t/base..............ok
- t/nonumbers.........ok
- t/ok................ok
- t/test-harness......ok
- t/waterloo..........dubious
+ t/base..............ok
+ t/nonumbers.........ok
+ t/ok................ok
+ t/test-harness......ok
+ t/waterloo..........dubious
Test returned status 3 (wstat 768, 0x300)
DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19
Failed 10/20 tests, 50.00% okay
out each individual test which failed along with a summary report and
a how long it all took.
-It returns true if everything was ok, false otherwise.
+It returns true if everything was ok. Otherwise it will die() with
+one of the messages in the DIAGNOSTICS section.
=for _private
This is just _run_all_tests() plus _show_results()
my($tot, $failedtests) = _run_all_tests(@tests);
_show_results($tot, $failedtests);
- my $ok = ($tot->{bad} == 0 && $tot->{max});
+ my $ok = _all_ok($tot);
- die q{Assert '$ok xor keys %$failedtests' failed!}
- unless $ok xor keys %$failedtests;
+ assert(($ok xor keys %$failedtests),
+ q{ok status jives with $failedtests});
return $ok;
}
=begin _private
+=item B<_all_ok>
+
+ my $ok = _all_ok(\%tot);
+
+Tells you if this test run is overall successful or not.
+
+=cut
+
+sub _all_ok {
+ my($tot) = shift;
+
+ return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0;
+}
+
=item B<_globdir>
my @files = _globdir $dir;
max Number of individual tests ran
ok Number of individual tests passed
sub_skipped Number of individual tests skipped
+ todo Number of individual todo tests
files Number of test files ran
good Number of test files passed
=cut
+#'#
sub _run_all_tests {
my(@tests) = @_;
local($|) = 1;
good => 0,
tests => scalar @tests,
sub_skipped => 0,
+ todo => 0,
skipped => 0,
- bench => 0
+ bench => 0,
);
- # pass -I flags to children
- my $old5lib = $ENV{PERL5LIB};
-
- # 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;
- my $maxlen = 0;
- foreach (@tests) {
- my $len = length;
- $maxlen = $len if $len > $maxlen;
- }
- # +3 : we want three dots between the test name and the "ok"
- # -2 : the .t suffix
- my $width = $maxlen + 3 - 2;
+ my $width = _leader_width(@tests);
foreach my $tfile (@tests) {
+
my($leader, $ml) = _mk_leader($tfile, $width);
+ local $ML = $ml;
print $leader;
- my $fh = _open_test($tfile);
+ $tot{files}++;
+
+ $Strap->{_seen_header} = 0;
+ my %results = $Strap->analyze_file($tfile) or
+ do { warn "$Strap->{error}\n"; next };
# state of the current test.
+ my @failed = grep { !$results{details}[$_-1]{ok} }
+ 1..@{$results{details}};
my %test = (
- ok => 0,
- 'next' => 0,
- max => 0,
- failed => [],
- todo => {},
- bonus => 0,
- skipped => 0,
- skip_reason => undef,
+ ok => $results{ok},
+ 'next' => $Strap->{'next'},
+ max => $results{max},
+ failed => \@failed,
+ bonus => $results{bonus},
+ skipped => $results{skip},
+ skip_reason => $Strap->{_skip_reason},
+ skip_all => $Strap->{skip_all},
ml => $ml,
);
- my($seen_header, $tests_seen) = (0,0);
- while (<$fh>) {
- if( _parse_header($_, \%test, \%tot) ) {
- warn "Test header seen twice!\n" if $seen_header;
+ $tot{bonus} += $results{bonus};
+ $tot{max} += $results{max};
+ $tot{ok} += $results{ok};
+ $tot{todo} += $results{todo};
+ $tot{sub_skipped} += $results{skip};
- $seen_header = 1;
+ my($estatus, $wstatus) = @results{qw(exit wait)};
- warn "1..M can only appear at the beginning or end of tests\n"
- if $tests_seen && $test{max} < $tests_seen;
- }
- elsif( _parse_test_line($_, \%test, \%tot) ) {
- $tests_seen++;
- }
- # else, ignore it.
- }
-
- my($estatus, $wstatus) = _close_fh($fh);
-
- my $allok = $test{ok} == $test{max} && $test{'next'} == $test{max}+1;
-
- if ($wstatus) {
+ if ($wstatus) {
$failedtests{$tfile} = _dubious_return(\%test, \%tot,
$estatus, $wstatus);
$failedtests{$tfile}{name} = $tfile;
- }
- elsif ($allok) {
- if ($test{max} and $test{skipped} + $test{bonus}) {
- my @msg;
- push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
- if $test{skipped};
- push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
- if $test{bonus};
- print "$test{ml}ok, ".join(', ', @msg)."\n";
- } elsif ($test{max}) {
- print "$test{ml}ok\n";
- } elsif (defined $test{skip_reason}) {
- print "skipped: $test{skip_reason}\n";
- $tot{skipped}++;
- } else {
- print "skipped test on this platform\n";
- $tot{skipped}++;
- }
- $tot{good}++;
- }
+ }
+ elsif ($results{passing}) {
+ if ($test{max} and $test{skipped} + $test{bonus}) {
+ my @msg;
+ push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
+ if $test{skipped};
+ push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
+ if $test{bonus};
+ print "$test{ml}ok\n ".join(', ', @msg)."\n";
+ } elsif ($test{max}) {
+ print "$test{ml}ok\n";
+ } elsif (defined $test{skip_all} and length $test{skip_all}) {
+ print "skipped\n all skipped: $test{skip_all}\n";
+ $tot{skipped}++;
+ } else {
+ print "skipped\n all skipped: no reason given\n";
+ $tot{skipped}++;
+ }
+ $tot{good}++;
+ }
else {
if ($test{max}) {
if ($test{'next'} <= $test{max}) {
}
}
- $tot{sub_skipped} += $test{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;
- }
- }
+ 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;
+ }
+ }
}
$tot{bench} = timediff(new Benchmark, $t_start);
- if ($^O eq 'VMS') {
- if (defined $old5lib) {
- $ENV{PERL5LIB} = $old5lib;
- } else {
- delete $ENV{PERL5LIB};
- }
- }
+ $Strap->_restore_PERL5LIB;
return(\%tot, \%failedtests);
}
Generates the 't/foo........' $leader for the given $test_file as well
as a similar version which will overwrite the current line (by use of
\r and such). $ml may be empty if Test::Harness doesn't think you're
-on TTY. The width is the width of the "yada/blah..." string.
+on TTY.
+
+The $width is the width of the "yada/blah.." string.
=cut
sub _mk_leader {
- my ($te, $width) = @_;
-
- chop($te); # XXX chomp?
+ my($te, $width) = @_;
+ chomp($te);
+ $te =~ s/\.\w+$/./;
if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; }
my $blank = (' ' x 77);
return($leader, $ml);
}
+=item B<_leader_width>
+
+ my($width) = _leader_width(@test_files);
+
+Calculates how wide the leader should be based on the length of the
+longest test name.
+
+=cut
+
+sub _leader_width {
+ my $maxlen = 0;
+ my $maxsuflen = 0;
+ foreach (@_) {
+ my $suf = /\.(\w+)$/ ? $1 : '';
+ my $len = length;
+ my $suflen = length $suf;
+ $maxlen = $len if $len > $maxlen;
+ $maxsuflen = $suflen if $suflen > $maxsuflen;
+ }
+ # + 3 : we want three dots between the test name and the "ok"
+ return $maxlen + 3 - $maxsuflen;
+}
+
sub _show_results {
my($tot, $failedtests) = @_;
my $pct;
my $bonusmsg = _bonusmsg($tot);
- if ($tot->{bad} == 0 && $tot->{max}) {
- print "All tests successful$bonusmsg.\n";
- } elsif ($tot->{tests}==0){
- die "FAILED--no tests were run for some reason.\n";
- } elsif ($tot->{max} == 0) {
- my $blurb = $tot->{tests}==1 ? "script" : "scripts";
- die "FAILED--$tot->{tests} test $blurb could be run, ".
+ if (_all_ok($tot)) {
+ print "All tests successful$bonusmsg.\n";
+ } elsif (!$tot->{tests}){
+ die "FAILED--no tests were run for some reason.\n";
+ } elsif (!$tot->{max}) {
+ my $blurb = $tot->{tests}==1 ? "script" : "scripts";
+ die "FAILED--$tot->{tests} test $blurb could be run, ".
"alas--no output ever seen\n";
} else {
- $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100);
- my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
- $tot->{max} - $tot->{ok}, $tot->{max},
- 100*$tot->{ok}/$tot->{max};
+ $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100);
+ my $percent_ok = 100*$tot->{ok}/$tot->{max};
+ my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
+ $tot->{max} - $tot->{ok}, $tot->{max},
+ $percent_ok;
my($fmt_top, $fmt) = _create_fmts($failedtests);
- # Now write to formats
- for my $script (sort keys %$failedtests) {
- $Curtest = $failedtests->{$script};
- write;
- }
- if ($tot->{bad}) {
- $bonusmsg =~ s/^,\s*//;
- print "$bonusmsg.\n" if $bonusmsg;
- die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.".
+ # Now write to formats
+ for my $script (sort keys %$failedtests) {
+ $Curtest = $failedtests->{$script};
+ write;
+ }
+ if ($tot->{bad}) {
+ $bonusmsg =~ s/^,\s*//;
+ print "$bonusmsg.\n" if $bonusmsg;
+ die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.".
"$subpct\n";
- }
+ }
}
printf("Files=%d, Tests=%d, %s\n",
}
-sub _parse_header {
- my($line, $test, $tot) = @_;
-
- my $is_header = 0;
-
+my %Handlers = ();
+$Strap->{callback} = sub {
+ my($self, $line, $type, $totals) = @_;
print $line if $Verbose;
- # 1..10 todo 4 7 10;
- if ($line =~ /^1\.\.([0-9]+) todo([\d\s]+);?/i) {
- $test->{max} = $1;
- for (split(/\s+/, $2)) { $test->{todo}{$_} = 1; }
+ my $meth = $Handlers{$type};
+ $meth->($self, $line, $type, $totals) if $meth;
+};
- $tot->{max} += $test->{max};
- $tot->{files}++;
- $is_header = 1;
- }
- # 1..10
- # 1..0 # skip Why? Because I said so!
- elsif ($line =~ /^1\.\.([0-9]+)
- (\s*\#\s*[Ss]kip\S*\s* (.+))?
- /x
- )
- {
- $test->{max} = $1;
- $tot->{max} += $test->{max};
- $tot->{files}++;
- $test->{'next'} = 1 unless $test->{'next'};
- $test->{skip_reason} = $3 if not $test->{max} and defined $3;
-
- $is_header = 1;
- }
- else {
- $is_header = 0;
- }
+$Handlers{header} = sub {
+ my($self, $line, $type, $totals) = @_;
- return $is_header;
-}
+ warn "Test header seen more than once!\n" if $self->{_seen_header};
+ $self->{_seen_header}++;
-sub _open_test {
- my($test) = shift;
+ warn "1..M can only appear at the beginning or end of tests\n"
+ if $totals->{seen} &&
+ $totals->{max} < $totals->{seen};
+};
- my $s = _set_switches($test);
+$Handlers{test} = sub {
+ my($self, $line, $type, $totals) = @_;
- # XXX This is WAY too core specific!
- my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
- ? "./perl -I../lib ../utils/perlcc $test "
- . "-r 2>> ./compilelog |"
- : "$^X $s $test|";
- $cmd = "MCR $cmd" if $^O eq 'VMS';
+ my $curr = $totals->{seen};
+ my $next = $self->{'next'};
+ my $max = $totals->{max};
+ my $detail = $totals->{details}[-1];
- if( open(PERL, $cmd) ) {
- return \*PERL;
+ if( $detail->{ok} ) {
+ _print_ml("ok $curr/$max");
+
+ if( $detail->{type} eq 'skip' ) {
+ $self->{_skip_reason} = $detail->{reason}
+ unless defined $self->{_skip_reason};
+ $self->{_skip_reason} = 'various reasons'
+ if $self->{_skip_reason} ne $detail->{reason};
+ }
}
else {
- print "can't run $test. $!\n";
- return;
+ _print_ml("NOK $curr");
}
-}
-sub _run_one_test {
- my($test) = @_;
+ if( $curr > $next ) {
+ print "Test output counter mismatch [test $curr]\n";
+ }
+ elsif( $curr < $next ) {
+ print "Confused test output: test $curr answered after ".
+ "test ", $next - 1, "\n";
+ }
-
-}
+};
+$Handlers{bailout} = sub {
+ my($self, $line, $type, $totals) = @_;
-sub _parse_test_line {
- my($line, $test, $tot) = @_;
-
- if ($line =~ /^(not\s+)?ok\b/i) {
- my $this = $test->{'next'} || 1;
- # "not ok 23"
- if ($line =~ /^(not )?ok\s*(\d*)(\s*#.*)?/) {
- my($not, $tnum, $extra) = ($1, $2, $3);
-
- $this = $tnum if $tnum;
-
- my($type, $reason) = $extra =~ /^\s*#\s*([Ss]kip\S*|TODO)(\s+.+)?/
- if defined $extra;
-
- my($istodo, $isskip);
- if( defined $type ) {
- $istodo = $type =~ /TODO/;
- $isskip = $type =~ /skip/i;
- }
-
- $test->{todo}{$tnum} = 1 if $istodo;
-
- if( $not ) {
- print "$test->{ml}NOK $this" if $test->{ml};
- if (!$test->{todo}{$this}) {
- push @{$test->{failed}}, $this;
- } else {
- $test->{ok}++;
- $tot->{ok}++;
- }
- }
- else {
- print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
- $test->{ok}++;
- $tot->{ok}++;
- $test->{skipped}++ if $isskip;
-
- if (defined $reason and defined $test->{skip_reason}) {
- # print "was: '$skip_reason' new '$reason'\n";
- $test->{skip_reason} = 'various reasons'
- if $test->{skip_reason} ne $reason;
- } elsif (defined $reason) {
- $test->{skip_reason} = $reason;
- }
-
- $test->{bonus}++, $tot->{bonus}++ if $test->{todo}{$this};
- }
- }
- # XXX ummm... dunno
- elsif ($line =~ /^ok\s*(\d*)\s*\#([^\r]*)$/) { # XXX multiline ok?
- $this = $1 if $1 > 0;
- print "$test->{ml}ok $this/$test->{max}" if $test->{ml};
- $test->{ok}++;
- $tot->{ok}++;
- }
- else {
- # an ok or not ok not matching the 3 cases above...
- # just ignore it for compatibility with TEST
- next;
- }
+ die "FAILED--Further testing stopped" .
+ ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n");
+};
- if ($this > $test->{'next'}) {
- # print "Test output counter mismatch [test $this]\n";
- # no need to warn probably
- push @{$test->{failed}}, $test->{'next'}..$this-1;
- }
- elsif ($this < $test->{'next'}) {
- #we have seen more "ok" lines than the number suggests
- print "Confused test output: test $this answered after ".
- "test ", $test->{'next'}-1, "\n";
- $test->{'next'} = $this;
- }
- $test->{'next'} = $this + 1;
- }
- elsif ($line =~ /^Bail out!\s*(.*)/i) { # magic words
- die "FAILED--Further testing stopped" .
- ($1 ? ": $1\n" : ".\n");
- }
+sub _print_ml {
+ print join '', $ML, @_ if $ML;
}
my $bonusmsg = '';
$bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
- " UNEXPECTEDLY SUCCEEDED)")
- if $tot->{bonus};
+ " UNEXPECTEDLY SUCCEEDED)")
+ if $tot->{bonus};
if ($tot->{skipped}) {
- $bonusmsg .= ", $tot->{skipped} test"
+ $bonusmsg .= ", $tot->{skipped} test"
. ($tot->{skipped} != 1 ? 's' : '');
- if ($tot->{sub_skipped}) {
- $bonusmsg .= " and $tot->{sub_skipped} subtest"
- . ($tot->{sub_skipped} != 1 ? 's' : '');
- }
- $bonusmsg .= ' skipped';
+ if ($tot->{sub_skipped}) {
+ $bonusmsg .= " and $tot->{sub_skipped} subtest"
+ . ($tot->{sub_skipped} != 1 ? 's' : '');
+ }
+ $bonusmsg .= ' skipped';
}
elsif ($tot->{sub_skipped}) {
- $bonusmsg .= ", $tot->{sub_skipped} subtest"
- . ($tot->{sub_skipped} != 1 ? 's' : '')
- . " skipped";
+ $bonusmsg .= ", $tot->{sub_skipped} subtest"
+ . ($tot->{sub_skipped} != 1 ? 's' : '')
+ . " skipped";
}
return $bonusmsg;
}
-# VMS has some subtle nastiness with closing the test files.
-sub _close_fh {
- my($fh) = shift;
-
- close($fh); # must close to reap child resource values
-
- my $wstatus = $Ignore_Exitcode ? 0 : $?; # Can trust $? ?
- my $estatus;
- $estatus = ($^O eq 'VMS'
- ? eval 'use vmsish "status"; $estatus = $?'
- : $wstatus >> 8);
-
- return($estatus, $wstatus);
-}
-
-
-# Set up the command-line switches to run perl as.
-sub _set_switches {
- my($test) = shift;
-
- local *TEST;
- open(TEST, $test) or print "can't open $test. $!\n";
- my $first = <TEST>;
- my $s = $Switches;
- $s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
- if exists $ENV{'HARNESS_PERL_SWITCHES'};
- $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
- if $first =~ /^#!.*\bperl.*-\w*T/;
-
- close(TEST) or print "can't close $test. $!\n";
-
- return $s;
-}
-
-
# Test program go boom.
sub _dubious_return {
my($test, $tot, $estatus, $wstatus) = @_;
if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
print "\tafter all the subtests completed successfully\n";
$percent = 0;
- $failed = 0; # But we do not set $canon!
+ $failed = 0; # But we do not set $canon!
}
else {
push @{$test->{failed}}, $test->{'next'}..$test->{max};
}
-sub _garbled_output {
- my($gibberish) = shift;
- warn "Confusing test output: '$gibberish'\n";
-}
-
-
sub _create_fmts {
my($failedtests) = @_;
my $fmt_top = "format STDOUT_TOP =\n"
. sprintf("%-${max_namelen}s", $failed_str)
. $middle_str
- . $list_str . "\n"
- . "-" x $Columns
- . "\n.\n";
+ . $list_str . "\n"
+ . "-" x $Columns
+ . "\n.\n";
my $fmt = "format STDOUT =\n"
- . "@" . "<" x ($max_namelen - 1)
+ . "@" . "<" x ($max_namelen - 1)
. " @>> @>>>> @>>>> @>>> ^##.##% "
- . "^" . "<" x ($list_len - 1) . "\n"
- . '{ $Curtest->{name}, $Curtest->{estat},'
- . ' $Curtest->{wstat}, $Curtest->{max},'
- . ' $Curtest->{failed}, $Curtest->{percent},'
- . ' $Curtest->{canon}'
- . "\n}\n"
- . "~~" . " " x ($Columns - $list_len - 2) . "^"
- . "<" x ($list_len - 1) . "\n"
- . '$Curtest->{canon}'
- . "\n.\n";
+ . "^" . "<" x ($list_len - 1) . "\n"
+ . '{ $Curtest->{name}, $Curtest->{estat},'
+ . ' $Curtest->{wstat}, $Curtest->{max},'
+ . ' $Curtest->{failed}, $Curtest->{percent},'
+ . ' $Curtest->{canon}'
+ . "\n}\n"
+ . "~~" . " " x ($Columns - $list_len - 2) . "^"
+ . "<" x ($list_len - 1) . "\n"
+ . '$Curtest->{canon}'
+ . "\n.\n";
eval $fmt_top;
die $@ if $@;
sub corestatus {
my($st) = @_;
- eval {require 'wait.ph'};
- my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200;
+ eval {
+ local $^W = 0; # *.ph files are often *very* noisy
+ require 'wait.ph'
+ };
+ return if $@;
+ my $did_core = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200;
eval { require Devel::CoreStack; $Have_Devel_Corestack++ }
unless $tried_devel_corestack++;
- $ret;
+ return $did_core;
}
}
my $last = $min = shift @failed;
my $canon;
if (@failed) {
- for (@failed, $failed[-1]) { # don't forget the last one
- if ($_ > $last+1 || $_ == $last) {
- if ($min == $last) {
- push @canon, $last;
- } else {
- push @canon, "$min-$last";
- }
- $min = $_;
- }
- $last = $_;
- }
- local $" = ", ";
- push @result, "FAILED tests @canon\n";
- $canon = join ' ', @canon;
+ for (@failed, $failed[-1]) { # don't forget the last one
+ if ($_ > $last+1 || $_ == $last) {
+ if ($min == $last) {
+ push @canon, $last;
+ } else {
+ push @canon, "$min-$last";
+ }
+ $min = $_;
+ }
+ $last = $_;
+ }
+ local $" = ", ";
+ push @result, "FAILED tests @canon\n";
+ $canon = join ' ', @canon;
} else {
- push @result, "FAILED test $last\n";
- $canon = $last;
+ push @result, "FAILED test $last\n";
+ $canon = $last;
}
push @result, "\tFailed $failed/$max tests, ";
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, ".
+ push @result, " (less $skipped skipped test$ender: $good okay, ".
"$goodper%)"
if $skipped;
push @result, "\n";
If not all tests were successful, the script dies with one of the
above messages.
-=item C<FAILED--Further testing stopped%s>
+=item C<FAILED--Further testing stopped: %s>
If a single subtest decides that further testing will not make sense,
the script dies with this message.
=over 4
-=item C<HARNESS_IGNORE_EXITCODE>
+=item C<HARNESS_ACTIVE>
-Makes harness ignore the exit status of child processes when defined.
+Harness sets this before executing the individual tests. This allows
+the tests to determine if they are being executed through the harness
+or by any other means.
-=item C<HARNESS_NOTTY>
+=item C<HARNESS_COLUMNS>
-When set 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).
+This value will be used for the width of the terminal. If it is not
+set then it will default to C<COLUMNS>. If this is not set, it will
+default to 80. Note that users of Bourne-sh based shells will need to
+C<export COLUMNS> for this module to use that variable.
=item C<HARNESS_COMPILE_TEST>
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.
+C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
+
+=item C<HARNESS_IGNORE_EXITCODE>
+
+Makes harness ignore the exit status of child processes when defined.
+
+=item C<HARNESS_NOTTY>
+
+When set 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).
=item C<HARNESS_PERL_SWITCHES>
each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
run all tests with all warnings enabled.
-=item C<HARNESS_COLUMNS>
+=item C<HARNESS_VERBOSE>
-This value will be used for the width of the terminal. If it is not
-set then it will default to C<COLUMNS>. If this is not set, it will
-default to 80. Note that users of Bourne-sh based shells will need to
-C<export COLUMNS> for this module to use that variable.
-
-=item C<HARNESS_ACTIVE>
-
-Harness sets this before executing the individual tests. This allows
-the tests to determine if they are being executed through the harness
-or by any other means.
+If true, Test::Harness will output the verbose results of running
+its tests. Setting $Test::Harness::verbose will override this.
=back
Provide a way of running tests quietly (ie. no printing) for automated
validation of tests. This will probably take the form of a version
of runtests() which rather than printing its output returns raw data
-on the state of the tests.
+on the state of the tests. (Partially done in Test::Harness::Straps)
Fix HARNESS_COMPILE_TEST without breaking its core usage.
Figure a way to report test names in the failure summary.
Rework the test summary so long test names are not truncated as badly.
-
-Merge back into bleadperl.
+(Partially done with new skip test styles)
Deal with VMS's "not \nok 4\n" mistake.
=head1 BUGS
-Test::Harness uses $^X to determine the perl binary to run the tests
-with. Test scripts running via the shebang (C<#!>) line may not be
-portable because $^X is not consistent for shebang scripts across
-platforms. This is no problem when Test::Harness is run with an
-absolute path to the perl binary or when $^X can be found in the path.
-
-HARNESS_COMPILE_TEST currently assumes its run from the Perl source
+HARNESS_COMPILE_TEST currently assumes it's run from the Perl source
directory.
=cut
projects / p5sagit/p5-mst-13.2.git / blobdiff