-# -*- Mode: cperl; cperl-indent-level: 4 -*-
package Test::Harness;
-use 5.005_64;
-use Exporter;
-use Benchmark;
-use Config;
+require 5.00405;
+
use strict;
-our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest,
- $columns, @ISA, @EXPORT, @EXPORT_OK);
-$have_devel_corestack = 0;
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source::Perl ();
+
+use TAP::Parser::Utils qw( split_shell );
+
+use Config;
+use Exporter;
+
+# TODO: Emulate at least some of these
+use vars qw(
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Color
+ $Directives
+ $Timer
+ $Strap
+ $has_time_hires
+);
+
+# $ML $Last_ML_Print
+
+BEGIN {
+ eval q{use Time::HiRes 'time'};
+ $has_time_hires = !$@;
+}
-$VERSION = "1.1607";
+=head1 NAME
-$ENV{HARNESS_ACTIVE} = 1;
+Test::Harness - Run Perl standard test scripts with statistics
-# Some experimental versions of OS/2 build have broken $?
-my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
+=head1 VERSION
-my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};
+Version 3.09
-my $tests_skipped = 0;
-my $subtests_skipped = 0;
+=cut
-@ISA=('Exporter');
-@EXPORT= qw(&runtests);
-@EXPORT_OK= qw($verbose $switches);
+$VERSION = '3.09';
-$verbose = 0;
-$switches = "-w";
-$columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+# Backwards compatibility for exportable variable names.
+*verbose = *Verbose;
+*switches = *Switches;
+*debug = *Debug;
-sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
+$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_VERSION} = $VERSION;
-sub runtests {
- my(@tests) = @_;
- local($|) = 1;
- my($test,$te,$ok,$next,$max,$pct,$totbonus,@failed,%failedtests);
- my $totmax = 0;
- my $totok = 0;
- my $files = 0;
- my $bad = 0;
- my $good = 0;
- my $total = @tests;
-
- # 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;
+END {
+
+ # For VMS.
+ delete $ENV{HARNESS_ACTIVE};
+ delete $ENV{HARNESS_VERSION};
+}
+
+@ISA = ('Exporter');
+@EXPORT = qw(&runtests);
+@EXPORT_OK = qw(&execute_tests $verbose $switches);
+
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
+$Debug = $ENV{HARNESS_DEBUG} || 0;
+$Switches = '-w';
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Columns--; # Some shells have trouble with a full line of text.
+$Timer = $ENV{HARNESS_TIMER} || 0;
+$Color = $ENV{HARNESS_COLOR} || 0;
+
+=head1 SYNOPSIS
+
+ use Test::Harness;
+
+ runtests(@test_files);
+
+=head1 DESCRIPTION
+
+Although, for historical reasons, the L<Test::Harness> distribution
+takes its name from this module it now exists only to provide
+L<TAP::Harness> with an interface that is somewhat backwards compatible
+with L<Test::Harness> 2.xx. If you're writing new code consider using
+L<TAP::Harness> directly instead.
+
+Emulation is provided for C<runtests> and C<execute_tests> but the
+pluggable 'Straps' interface that previous versions of L<Test::Harness>
+supported is not reproduced here. Straps is now available as a stand
+alone module: L<Test::Harness::Straps>.
+
+See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
+distribution.
+
+=head1 FUNCTIONS
+
+The following functions are available.
+
+=head2 runtests( @test_files )
+
+This runs all the given I<@test_files> and divines whether they passed
+or failed based on their output to STDOUT (details above). It prints
+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. Otherwise it will C<die()> with
+one of the messages in the DIAGNOSTICS section.
+
+=cut
+
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
+}
+
+sub _aggregate {
+ my ( $harness, $aggregate, @tests ) = @_;
+
+ # Don't propagate to our children
+ local $ENV{HARNESS_OPTIONS};
+
+ if (IS_VMS) {
+
+ # Jiggery pokery doesn't appear to work on VMS - so disable it
+ # pending investigation.
+ _aggregate_tests( $harness, $aggregate, @tests );
}
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./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;
- open(my $fh, $test) or print "can't open $test. $!\n";
- my $first = <$fh>;
- 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($fh) or print "can't close $test. $!\n";
- 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';
- open($fh, $cmd) or print "can't run $test. $!\n";
- $ok = $next = $max = 0;
- @failed = ();
- my %todo = ();
- my $bonus = 0;
- my $skipped = 0;
- my $skip_reason;
- while (<$fh>) {
- if( $verbose ){
- print $_;
- }
- if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
- $max = $1;
- for (split(/\s+/, $2)) { $todo{$_} = 1; }
- $totmax += $max;
- $files++;
- $next = 1;
- } 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\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};
- } elsif (/^ok\s*(\d*)\s*\#([^\r]*)$/) {
- $this = $1 if $1 > 0;
- print "${ml}ok $this/$max" if $ml;
- $ok++;
- $totok++;
- } else {
- # an ok or not ok not matching the 3 cases above...
- # just ignore it for compatibility with TEST
- next;
- }
- if ($this > $next) {
- # print "Test output counter mismatch [test $this]\n";
- # no need to warn probably
- push @failed, $next..$this-1;
- } elsif ($this < $next) {
- #we have seen more "ok" lines than the number suggests
- print "Confused test output: test $this answered after test ", $next-1, "\n";
- $next = $this;
- }
- $next = $this + 1;
- } elsif (/^Bail out!\s*(.*)/i) { # magic words
- die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+ my @extra_inc = _filtered_inc();
+
+ # Supply -I switches in taint mode
+ $harness->callback(
+ parser_args => sub {
+ my ( $args, $test ) = @_;
+ if ( _has_taint( $test->[0] ) ) {
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
}
- }
- 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);
- if ($wstatus) {
- my ($failed, $canon, $percent) = ('??', '??');
- 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
- if ($have_devel_corestack) {
- Devel::CoreStack::stack($^X);
- } else {
- print "\ttest program seems to have generated a core\n";
- }
- }
- $bad++;
- 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,$skipped,@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 and $skipped + $bonus) {
- my @msg;
- push(@msg, "$skipped/$max skipped: $skip_reason")
- if $skipped;
- push(@msg, "$bonus/$max unexpectedly succeeded")
- if $bonus;
- print "${ml}ok, ".join(', ', @msg)."\n";
- } elsif ($max) {
- print "${ml}ok\n";
- } elsif (defined $skip_reason) {
- print "skipped: $skip_reason\n";
- $tests_skipped++;
- } else {
- print "skipped test on this platform\n";
- $tests_skipped++;
- }
- $good++;
- } elsif ($max) {
- if ($next <= $max) {
- push @failed, $next..$max;
- }
- if (@failed) {
- my ($txt, $canon) = canonfailed($max,$skipped,@failed);
- print "${ml}$txt";
- $failedtests{$test} = { canon => $canon, max => $max,
- failed => scalar @failed,
- name => $test, percent => 100*(scalar @failed)/$max,
- estat => '', wstat => '',
- };
- } else {
- print "Don't know which tests failed: got $ok ok, expected $max\n";
- $failedtests{$test} = { canon => '??', max => $max,
- failed => '??',
- name => $test, percent => undef,
- estat => '', wstat => '',
- };
- }
- $bad++;
- } elsif ($next == 0) {
- print "FAILED before any test output arrived\n";
- $bad++;
- $failedtests{$test} = { canon => '??', max => '??',
- failed => '??',
- name => $test, percent => undef,
- estat => '', wstat => '',
- };
- }
- $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 $previous = $ENV{PERL5LIB};
+ local $ENV{PERL5LIB};
+
+ if ($previous) {
+ push @extra_inc, split( $path_pat, $previous );
+ }
+
+ if (@extra_inc) {
+ $ENV{PERL5LIB} = join( $path_sep, @extra_inc );
+ }
+
+ _aggregate_tests( $harness, $aggregate, @tests );
}
- my $t_total = timediff(new Benchmark, $t_start);
-
- if ($^O eq 'VMS') {
- if (defined $old5lib) {
- $ENV{PERL5LIB} = $old5lib;
- } else {
- delete $ENV{PERL5LIB};
- }
+}
+
+sub _aggregate_tests {
+ my ( $harness, $aggregate, @tests ) = @_;
+ $aggregate->start();
+ $harness->aggregate_tests( $aggregate, @tests );
+ $aggregate->stop();
+
+}
+
+sub runtests {
+ my @tests = @_;
+
+ # shield against -l
+ local ( $\, $, );
+
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ _aggregate( $harness, $aggregate, @tests );
+
+ $harness->formatter->summary($aggregate);
+
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+ my $failed = $aggregate->failed;
+
+ my @parsers = $aggregate->parsers;
+
+ my $num_bad = 0;
+ for my $parser (@parsers) {
+ $num_bad++ if $parser->has_problems;
}
- my $bonusmsg = '';
- $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
- " UNEXPECTEDLY SUCCEEDED)")
- if $totbonus;
- if ($tests_skipped) {
- $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '');
- if ($subtests_skipped) {
- $bonusmsg .= " and $subtests_skipped subtest"
- . ($subtests_skipped != 1 ? 's' : '');
- }
- $bonusmsg .= ' skipped';
+
+ die(sprintf(
+ "Failed %d/%d test programs. %d/%d subtests failed.\n",
+ $num_bad, scalar @parsers, $failed, $total
+ )
+ ) if $num_bad;
+
+ return $total && $total == $passed;
+}
+
+sub _canon {
+ my @list = sort { $a <=> $b } @_;
+ my @ranges = ();
+ my $count = scalar @list;
+ my $pos = 0;
+
+ while ( $pos < $count ) {
+ my $end = $pos + 1;
+ $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
+ push @ranges, ( $end == $pos + 1 )
+ ? $list[$pos]
+ : join( '-', $list[$pos], $list[ $end - 1 ] );
+ $pos = $end;
}
- elsif ($subtests_skipped) {
- $bonusmsg .= ", $subtests_skipped subtest"
- . ($subtests_skipped != 1 ? 's' : '')
- . " skipped";
+
+ return join( ' ', @ranges );
+}
+
+sub _new_harness {
+ my $sub_args = shift || {};
+
+ my ( @lib, @switches );
+ for my $opt (
+ split_shell( $Switches, $ENV{HARNESS_PERL_SWITCHES} ) )
+ {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, $1;
+ }
+ else {
+ push @switches, $opt;
+ }
}
- if ($bad == 0 && $totmax) {
- print "All tests successful$bonusmsg.\n";
- } elsif ($total==0){
- die "FAILED--no tests were run for some reason.\n";
- } elsif ($totmax==0) {
- my $blurb = $total==1 ? "script" : "scripts";
- die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
- } else {
- $pct = sprintf("%.2f", $good / $total * 100);
- my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
- $totmax - $totok, $totmax, 100*$totok/$totmax;
- # Create formats
- # First, figure out max length of test names
- my $failed_str = "Failed Test";
- my $middle_str = " Status Wstat Total Fail Failed ";
- my $list_str = "List of Failed";
- my $max_namelen = length($failed_str);
- my $script;
- foreach $script (keys %failedtests) {
- $max_namelen =
- (length $failedtests{$script}->{name} > $max_namelen) ?
- length $failedtests{$script}->{name} : $max_namelen;
- }
- my $list_len = $columns - length($middle_str) - $max_namelen;
- if ($list_len < length($list_str)) {
- $list_len = length($list_str);
- $max_namelen = $columns - length($middle_str) - $list_len;
- if ($max_namelen < length($failed_str)) {
- $max_namelen = length($failed_str);
- $columns = $max_namelen + length($middle_str) + $list_len;
- }
- }
-
- my $fmt_top = "format STDOUT_TOP =\n"
- . sprintf("%-${max_namelen}s", $failed_str)
- . $middle_str
- . $list_str . "\n"
- . "-" x $columns
- . "\n.\n";
- my $fmt = "format STDOUT =\n"
- . "@" . "<" 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";
-
- eval $fmt_top;
- die $@ if $@;
- eval $fmt;
- die $@ if $@;
-
- # Now write to formats
- for $script (sort keys %failedtests) {
- $curtest = $failedtests{$script};
- write;
- }
- if ($bad) {
- $bonusmsg =~ s/^,\s*//;
- print "$bonusmsg.\n" if $bonusmsg;
- die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
- }
+
+ # Do things the old way on VMS...
+ push @lib, _filtered_inc() if IS_VMS;
+
+ # If $Verbose isn't numeric default to 1. This helps core.
+ my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
+
+ my $args = {
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ color => $Color,
+ verbosity => $verbosity,
+ };
+
+ $args->{stdout} = $sub_args->{out}
+ if exists $sub_args->{out};
+
+ if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
+ for my $opt ( split /:/, $env_opt ) {
+ if ( $opt =~ /^j(\d*)$/ ) {
+ $args->{jobs} = $1 || 9;
+ }
+ elsif ( $opt eq 'f' ) {
+ $args->{fork} = 1;
+ }
+ elsif ( $opt eq 'c' ) {
+ $args->{color} = 1;
+ }
+ else {
+ die "Unknown HARNESS_OPTIONS item: $opt\n";
+ }
+ }
}
- printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
- return ($bad == 0 && $totmax) ;
+ return TAP::Harness->new($args);
}
-my $tried_devel_corestack;
-sub corestatus {
- my($st) = @_;
+# Get the parts of @INC which are changed from the stock list AND
+# preserve reordering of stock directories.
+sub _filtered_inc {
+ my @inc = grep { !ref } @INC; #28567
- eval {require 'wait.ph'};
- my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200;
+ if (IS_VMS) {
- eval { require Devel::CoreStack; $have_devel_corestack++ }
- unless $tried_devel_corestack++;
+ # VMS has a 255-byte limit on the length of %ENV entries, so
+ # toss the ones that involve perl_root, the install location
+ @inc = grep !/perl_root/i, @inc;
- $ret;
-}
+ }
+ elsif (IS_WIN32) {
+
+ # Lose any trailing backslashes in the Win32 paths
+ s/[\\\/+]$// foreach @inc;
+ }
+
+ my @default_inc = _default_inc();
-sub canonfailed ($@) {
- my($max,$skipped,@failed) = @_;
+ my @new_inc;
my %seen;
- @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
- my $failed = @failed;
- my @result = ();
- my @canon = ();
- my $min;
- 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 = "@canon";
- } else {
- push @result, "FAILED test $last\n";
- $canon = $last;
+ for my $dir (@inc) {
+ next if $seen{$dir}++;
+
+ if ( $dir eq ( $default_inc[0] || '' ) ) {
+ shift @default_inc;
+ }
+ else {
+ push @new_inc, $dir;
+ }
+
+ shift @default_inc while @default_inc and $seen{ $default_inc[0] };
}
- push @result, "\tFailed $failed/$max tests, ";
- 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);
+ return @new_inc;
}
-1;
-__END__
+{
-=head1 NAME
+ # Cache this to avoid repeatedly shelling out to Perl.
+ my @inc;
-Test::Harness - run perl standard test scripts with statistics
+ sub _default_inc {
+ return @inc if @inc;
+ my $perl = $ENV{HARNESS_PERL} || $^X;
+ chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` );
+ return @inc;
+ }
+}
-=head1 SYNOPSIS
+sub _check_sequence {
+ my @list = @_;
+ my $prev;
+ while ( my $next = shift @list ) {
+ return if defined $prev && $next <= $prev;
+ $prev = $next;
+ }
-use Test::Harness;
+ return 1;
+}
-runtests(@tests);
+sub execute_tests {
+ my %args = @_;
+
+ my $harness = _new_harness( \%args );
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ my %tot = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ bad => 0,
+ good => 0,
+ files => 0,
+ tests => 0,
+ sub_skipped => 0,
+ todo => 0,
+ skipped => 0,
+ bench => undef,
+ );
+
+ # Install a callback so we get to see any plans the
+ # harness executes.
+ $harness->callback(
+ made_parser => sub {
+ my $parser = shift;
+ $parser->callback(
+ plan => sub {
+ my $plan = shift;
+ if ( $plan->directive eq 'SKIP' ) {
+ $tot{skipped}++;
+ }
+ }
+ );
+ }
+ );
+
+ _aggregate( $harness, $aggregate, @{ $args{tests} } );
+
+ $tot{bench} = $aggregate->elapsed;
+ my @tests = $aggregate->descriptions;
+
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = scalar @tests;
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test (@tests) {
+ my ($parser) = $aggregate->parsers($test);
+
+ my @failed = $parser->failed;
+
+ my $wstat = $parser->wait;
+ my $estat = $parser->exit;
+ my $planned = $parser->tests_planned;
+ my @errors = $parser->parse_errors;
+ my $passed = $parser->passed;
+ my $actual_passed = $parser->actual_passed;
+
+ my $ok_seq = _check_sequence( $parser->actual_passed );
+
+ # Duplicate exit, wait status semantics of old version
+ $estat ||= '' unless $wstat;
+ $wstat ||= '';
+
+ $tot{max} += ( $planned || 0 );
+ $tot{bonus} += $parser->todo_passed;
+ $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
+ $tot{sub_skipped} += $parser->skipped;
+ $tot{todo} += $parser->todo;
+
+ if ( @failed || $estat || @errors ) {
+ $tot{bad}++;
+
+ my $huh_planned = $planned ? undef : '??';
+ my $huh_errors = $ok_seq ? undef : '??';
+
+ $failedtests{$test} = {
+ 'canon' => $huh_planned
+ || $huh_errors
+ || _canon(@failed)
+ || '??',
+ 'estat' => $estat,
+ 'failed' => $huh_planned
+ || $huh_errors
+ || scalar @failed,
+ 'max' => $huh_planned || $planned,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ else {
+ $tot{good}++;
+ }
+
+ my @todo = $parser->todo_passed;
+ if (@todo) {
+ $todo_passed{$test} = {
+ 'canon' => _canon(@todo),
+ 'estat' => $estat,
+ 'failed' => scalar @todo,
+ 'max' => scalar $parser->todo,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ }
-=head1 DESCRIPTION
+ return ( \%tot, \%failedtests, \%todo_passed );
+}
-(By using the L<Test> module, you can write test scripts without
-knowing the exact output this module expects. However, if you need to
-know the specifics, read on!)
+=head2 execute_tests( tests => \@test_files, out => \*FH )
-Perl test scripts print to standard output C<"ok N"> for each single
-test, where C<N> is an increasing sequence of integers. The first line
-output by a standard test script is C<"1..M"> with C<M> being the
-number of tests that should be run within the test
-script. Test::Harness::runtests(@tests) runs all the testscripts
-named as arguments and checks standard output for the expected
-C<"ok N"> strings.
+Runs all the given C<@test_files> (just like C<runtests()>) but
+doesn't generate the final report. During testing, progress
+information will be written to the currently selected output
+filehandle (usually C<STDOUT>), or to the filehandle given by the
+C<out> parameter. The I<out> is optional.
-After all tests have been performed, runtests() prints some
-performance statistics that are computed by the Benchmark module.
+Returns a list of two values, C<$total> and C<$failed>, describing the
+results. C<$total> is a hash ref summary of all the tests run. Its
+keys and values are this:
-=head2 The test script output
+ bonus Number of individual todo tests unexpectedly passed
+ 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
-Any output from the testscript to standard error is ignored and
-bypassed, thus will be seen by the user. Lines written to standard
-output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
-runtests(). All other lines are discarded.
+ files Number of test files ran
+ good Number of test files passed
+ bad Number of test files failed
+ tests Number of test files originally given
+ skipped Number of test files skipped
-It is tolerated if the test numbers after C<ok> are omitted. In this
-case Test::Harness maintains temporarily its own counter until the
-script supplies test numbers again. So the following test script
+If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
+got a successful test.
- print <<END;
- 1..6
- not ok
- ok
- not ok
- ok
- ok
- END
+C<$failed> is a hash ref of all the test scripts that failed. Each key
+is the name of a test script, each value is another hash representing
+how that script failed. Its keys are these:
-will generate
+ name Name of the test which failed
+ estat Script's exit value
+ wstat Script's wait status
+ max Number of individual tests
+ failed Number which failed
+ canon List of tests which failed (as string).
- FAILED tests 1, 3, 6
- Failed 3/6 tests, 50.00% okay
+C<$failed> should be empty if everything passed.
-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.
+=cut
-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>.
+1;
+__END__
-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. In no other circumstance is anything
-allowed to follow C<ok> or C<ok NUMBER>. If the whole testscript
-succeeds, the count of skipped tests is included in the generated
-output.
+=head1 EXPORT
-C<Test::Harness> reports the text after C< # Skip\S*\s+> 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:
+C<&runtests> is exported by C<Test::Harness> by default.
- 1..0 # Skipped: no leverage found
+C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
+exported upon request.
-As an emergency measure, a test script can decide that further tests
-are useless (e.g. missing dependencies) and testing should stop
-immediately. In that case the test script prints the magic words
+=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
- Bail out!
+C<Test::Harness> sets these before executing the individual tests.
-to standard output. Any message after these words will be displayed by
-C<Test::Harness> as the reason why testing is stopped.
+=over 4
-=head1 EXPORT
+=item C<HARNESS_ACTIVE>
-C<&runtests> is exported by Test::Harness per default.
+This is set to a true value. It allows the tests to determine if they
+are being executed through the harness or by any other means.
-=head1 DIAGNOSTICS
+=item C<HARNESS_VERSION>
+
+This is the version of C<Test::Harness>.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
=over 4
-=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
+=item C<HARNESS_TIMER>
-If all tests are successful some statistics about the performance are
-printed.
+Setting this to true will make the harness display the number of
+milliseconds each test took. You can also use F<prove>'s C<--timer>
+switch.
-=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
+=item C<HARNESS_VERBOSE>
-For any single script that has failing subtests statistics like the
-above are printed.
+If true, C<Test::Harness> will output the verbose results of running
+its tests. Setting C<$Test::Harness::verbose> will override this,
+or you can use the C<-v> switch in the F<prove> utility.
-=item C<Test returned status %d (wstat %d)>
+=item C<HARNESS_OPTIONS>
-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.
+Provide additional options to the harness. Currently supported options are:
-=item C<Failed 1 test, %.2f%% okay. %s>
+=over
-=item C<Failed %d/%d tests, %.2f%% okay. %s>
+=item C<< j<n> >>
-If not all tests were successful, the script dies with one of the
-above messages.
+Run <n> (default 9) parallel jobs.
-=item C<FAILED--Further testing stopped%s>
+=item C<< f >>
-If a single subtest decides that further testing will not make sense,
-the script dies with this message.
+Use forked parallelism.
=back
-=head1 ENVIRONMENT
+Multiple options may be separated by colons:
-Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status
-of child processes.
+ HARNESS_OPTIONS=j9:f make test
-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).
+=back
-Setting C<HARNESS_COMPILE_TEST> to a true value will make harness attempt
-to compile the test using C<perlcc> before running it.
+=head1 Taint Mode
-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
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
- LEAKED FILES: scr.tmp 0 my.db
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> C<Test::Harness> (actually
+L<TAP::Parser::Source::Perl>) passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even in taint mode.
-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.
+=head1 SEE ALSO
-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.
+L<TAP::Harness>
-If C<HARNESS_COLUMNS> is set, then 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.
+=head1 BUGS
-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.
+Please report any bugs or feature requests to
+C<bug-test-harness at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
+notified, and then you'll automatically be notified of progress on your bug
+as I make changes.
-=head1 SEE ALSO
+=head1 AUTHORS
-L<Test> for writing test scripts and also L<Benchmark> for the
-underlying timing routines.
+Andy Armstrong C<< <andy@hexten.net> >>
-=head1 AUTHORS
+L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
+module is based) has this attribution:
-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. Numerous anonymous contributors
-exist. Current maintainer is Andreas Koenig.
+ Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+ sure is, that it was inspired by Larry Wall's F<TEST> script that came
+ with perl distributions for ages. Numerous anonymous contributors
+ exist. Andreas Koenig held the torch for many years, and then
+ Michael G Schwern.
-=head1 BUGS
+=head1 LICENCE AND COPYRIGHT
-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.
+Copyright (c) 2007-2008, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
-=cut