From: Michael G. Schwern Date: Sun, 4 Feb 2001 08:01:20 +0000 (-0500) Subject: New improved test harness X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9c5c68c8d8cf29abcdb2ff421bcd6e5daedf49ec;p=p5sagit%2Fp5-mst-13.2.git New improved test harness Subject: Re: [PATCH Test::Harness] Third time's a charm? Message-Id: <20010204080120.G10493@blackrider.aocn.com> p4raw-id: //depot/perl@8691 --- diff --git a/MANIFEST b/MANIFEST index 7dd175f..72b1edd 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1477,6 +1477,18 @@ t/lib/ph.t See if h2ph works t/lib/posix.t See if POSIX works t/lib/safe1.t See if Safe works t/lib/safe2.t See if Safe works +t/lib/sample-tests/bailout Test data for Test::Harness +t/lib/sample-tests/combined Test data for Test::Harness +t/lib/sample-tests/descriptive Test data for Test::Harness +t/lib/sample-tests/duplicates Test data for Test::Harness +t/lib/sample-tests/header_at_end Test data for Test::Harness +t/lib/sample-tests/no_nums Test data for Test::Harness +t/lib/sample-tests/simple Test data for Test::Harness +t/lib/sample-tests/simple_fail Test data for Test::Harness +t/lib/sample-tests/skip Test data for Test::Harness +t/lib/sample-tests/skip_all Test data for Test::Harness +t/lib/sample-tests/todo Test data for Test::Harness +t/lib/sample-tests/with_comments Test data for Test::Harness t/lib/sdbm.t See if SDBM_File works t/lib/searchdict.t See if Search::Dict works t/lib/selectsaver.t See if SelectSaver works @@ -1502,6 +1514,7 @@ t/lib/st-utf8.t See if Storable works t/lib/symbol.t See if Symbol works t/lib/syslfs.t See if large files work for sysio t/lib/syslog.t See if Sys::Syslog works +t/lib/test-harness.t See if Test::Harness works t/lib/textfill.t See if Text::Wrap::fill works t/lib/texttabs.t See if Text::Tabs works t/lib/textwrap.t See if Text::Wrap::wrap works diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index ec6b958..332eed9 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -7,42 +7,66 @@ use Benchmark; use Config; use strict; -our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest, - $columns, @ISA, @EXPORT, @EXPORT_OK); -$have_devel_corestack = 0; +our($VERSION, $Verbose, $Switches, $Have_Devel_Corestack, $Curtest, + $Columns, $verbose, $switches, + @ISA, @EXPORT, @EXPORT_OK + ); -$VERSION = "1.1607"; +# Backwards compatibility for exportable variable names. +*verbose = \$Verbose; +*switches = \$Switches; + +$Have_Devel_Corestack = 0; + +$VERSION = "1.1702"; $ENV{HARNESS_ACTIVE} = 1; # Some experimental versions of OS/2 build have broken $? -my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE}; +my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE}; + +my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR}; -my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR}; -my $tests_skipped = 0; -my $subtests_skipped = 0; +@ISA = ('Exporter'); +@EXPORT = qw(&runtests); +@EXPORT_OK = qw($verbose $switches); -@ISA=('Exporter'); -@EXPORT= qw(&runtests); -@EXPORT_OK= qw($verbose $switches); +$Verbose = 0; +$Switches = "-w"; +$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; -$verbose = 0; -$switches = "-w"; -$columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f } sub runtests { my(@tests) = @_; + + my($tot, $failedtests) = _runtests(@tests); + _show_results($tot, $failedtests); + + return ($tot->{bad} == 0 && $tot->{max}) ; +} + + +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; + my(%failedtests); + + # Test-wide totals. + my(%tot) = ( + bonus => 0, + max => 0, + ok => 0, + files => 0, + bad => 0, + good => 0, + tests => scalar @tests, + sub_skipped => 0, + skipped => 0, + bench => 0 + ); # pass -I flags to children my $old5lib = $ENV{PERL5LIB}; @@ -53,7 +77,7 @@ sub runtests { my $new5lib; if ($^O eq 'VMS') { $new5lib = join($Config{path_sep}, grep {!/perl_root/i;} @INC); - $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g; + $Switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g; } else { $new5lib = join($Config{path_sep}, @INC); @@ -61,194 +85,128 @@ sub runtests { local($ENV{'PERL5LIB'}) = $new5lib; - my @dir_files = globdir $files_in_dir if defined $files_in_dir; + 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); + + foreach my $test (@tests) { + my $te = $test; + chop($te); # XXX chomp? + 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; + 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 $s = _set_switches($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'; - 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; + open(my $fh, $cmd) or print "can't run $test. $!\n"; + + # state of the current test. + my %test = ( + ok => 0, + next => 0, + max => 0, + failed => [], + todo => {}, + bonus => 0, + skipped => 0, + skip_reason => undef, + ml => $ml, + ); + + my($seen_header, $tests_seen) = (0,0); 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"); + if( _parse_header($_, \%test, \%tot) ) { + warn "Test header seen twice!\n" if $seen_header; + + $seen_header = 1; + + 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. } - 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); + + my($estatus, $wstatus) = _close_fh($fh); + 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) { + $failedtests{$test} = _dubious_return(\%test, \%tot, + $estatus, $wstatus); + } + elsif ($test{ok} == $test{max} && $test{next} == $test{max}+1) { + if ($test{max} and $test{skipped} + $test{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++; + 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"; - $tests_skipped++; + $tot{skipped}++; } - $good++; - } elsif ($max) { - if ($next <= $max) { - push @failed, $next..$max; + $tot{good}++; + } elsif ($test{max}) { + if ($test{next} <= $test{max}) { + push @{$test{failed}}, $test{next}..$test{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 => '', + if (@{$test{failed}}) { + my ($txt, $canon) = canonfailed($test{max},$test{skipped}, + @{$test{failed}}); + print "$test{ml}$txt"; + $failedtests{$test} = { canon => $canon, + max => $test{max}, + failed => scalar @{$test{failed}}, + name => $test, + percent => 100*(scalar @{$test{failed}})/$test{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 => '', + print "Don't know which tests failed: got $test{ok} ok, ". + "expected $test{max}\n"; + $failedtests{$test} = { canon => '??', + max => $test{max}, + failed => '??', + name => $test, + percent => undef, + estat => '', + wstat => '', }; } - $bad++; - } elsif ($next == 0) { + $tot{bad}++; + } elsif ($test{next} == 0) { print "FAILED before any test output arrived\n"; - $bad++; - $failedtests{$test} = { canon => '??', max => '??', - failed => '??', - name => $test, percent => undef, - estat => '', wstat => '', + $tot{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; + $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; @@ -259,7 +217,7 @@ sub runtests { } } } - my $t_total = timediff(new Benchmark, $t_start); + $tot{bench} = timediff(new Benchmark, $t_start); if ($^O eq 'VMS') { if (defined $old5lib) { @@ -268,97 +226,326 @@ sub runtests { delete $ENV{PERL5LIB}; } } - 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'; - } - elsif ($subtests_skipped) { - $bonusmsg .= ", $subtests_skipped subtest" - . ($subtests_skipped != 1 ? 's' : '') - . " skipped"; - } - if ($bad == 0 && $totmax) { + + return(\%tot, \%failedtests); +} + + +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 ($total==0){ + } elsif ($tot->{tests}==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"; + } elsif ($tot->{max} == 0) { + 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", $good / $total * 100); + $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 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"; + $tot->{max} - $tot->{ok}, $tot->{max}, + 100*$tot->{ok}/$tot->{max}; - eval $fmt_top; - die $@ if $@; - eval $fmt; - die $@ if $@; + my($fmt_top, $fmt) = _create_fmts($failedtests); # Now write to formats - for $script (sort keys %failedtests) { - $curtest = $failedtests{$script}; + for my $script (sort keys %$failedtests) { + $Curtest = $failedtests->{$script}; write; } - if ($bad) { + if ($tot->{bad}) { $bonusmsg =~ s/^,\s*//; print "$bonusmsg.\n" if $bonusmsg; - die "Failed $bad/$total test scripts, $pct% okay.$subpct\n"; + die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.". + "$subpct\n"; } } - printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop')); - return ($bad == 0 && $totmax) ; + printf("Files=%d, Tests=%d, %s\n", + $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop')); +} + + +sub _parse_header { + my($line, $test, $tot) = @_; + + my $is_header = 0; + + 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; } + + $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; + } + + return $is_header; } + +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*)/){ # test failed + $this = $1 if length $1 and $1 > 0; + print "$test->{ml}NOK $this" if $test->{ml}; + if (!$test->{todo}{$this}) { + push @{$test->{failed}}, $this; + } else { + $test->{ok}++; + $tot->{ok}++; + } + } + # "ok 23 # skip (you're not cleared for that)" + elsif ($line =~ /^ok\s*(\d*)\ * + (\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)? + /x) # test skipped + { + $this = $1 if length $1 and $1 > 0; + print "$test->{ml}ok $this/$test->{max}" if $test->{ml}; + $test->{ok}++; + $tot->{ok}++; + $test->{skipped}++ if defined $2; + my $reason; + $reason = 'unknown reason' if defined $2; + $reason = $3 if defined $3; + 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; + } + + 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 _bonusmsg { + my($tot) = @_; + + my $bonusmsg = ''; + $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : ''). + " UNEXPECTEDLY SUCCEEDED)") + if $tot->{bonus}; + + if ($tot->{skipped}) { + $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'; + } + elsif ($tot->{sub_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; + + 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"; + + return $s; +} + + +# Test program go boom. +sub _dubious_return { + my($test, $tot, $estatus, $wstatus) = @_; + my ($failed, $canon, $percent) = ('??', '??'); + + printf "$test->{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"; + } + } + + $tot->{bad}++; + + if ($test->{max}) { + 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! + } + else { + push @{$test->{failed}}, $test->{next}..$test->{max}; + $failed = @{$test->{failed}}; + (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}}); + $percent = 100*(scalar @{$test->{failed}})/$test->{max}; + print "DIED. ",$txt; + } + } + + return { canon => $canon, max => $test->{max} || '??', + failed => $failed, + name => $test, percent => $percent, + estat => $estatus, wstat => $wstatus, + }; +} + + +sub _garbled_output { + my($gibberish) = shift; + warn "Confusing test output: '$gibberish'\n"; +} + + +sub _create_fmts { + my($failedtests) = @_; + + my $failed_str = "Failed Test"; + my $middle_str = " Status Wstat Total Fail Failed "; + my $list_str = "List of Failed"; + + # Figure out our longest name string for formatting purposes. + my $max_namelen = length($failed_str); + foreach my $script (keys %$failedtests) { + my $namelen = length $failedtests->{$script}->{name}; + $max_namelen = $namelen if $namelen > $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 $@; + + return($fmt_top, $fmt); +} + + my $tried_devel_corestack; sub corestatus { my($st) = @_; @@ -366,7 +553,7 @@ sub corestatus { eval {require 'wait.ph'}; my $ret = defined &WCOREDUMP ? WCOREDUMP($st) : $st & 0200; - eval { require Devel::CoreStack; $have_devel_corestack++ } + eval { require Devel::CoreStack; $Have_Devel_Corestack++ } unless $tried_devel_corestack++; $ret; @@ -407,7 +594,9 @@ sub canonfailed ($@) { 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, " (-$skipped skipped test$ender: $good okay, ". + "$goodper%)" + if $skipped; push @result, "\n"; my $txt = join "", @result; ($txt, $canon); @@ -428,7 +617,7 @@ runtests(@tests); =head1 DESCRIPTION -(By using the L module, you can write test scripts without +(By using the 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!) @@ -445,14 +634,41 @@ performance statistics that are computed by the Benchmark module. =head2 The test script output +=over 4 + +=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). + +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 line output +by your test (again, it can be followed by further comments). But we +strongly encourage you to put it first. + +Under B circumstances should 1..M appear in the middle of your +output or more than once. + + +=item B<'ok', 'not ok'. Ok?> + 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 are interpreted as feedback for runtests(). All other lines are discarded. -It is tolerated if the test numbers after C are omitted. In this -case Test::Harness maintains temporarily its own counter until the -script supplies test numbers again. So the following test script +C indicates a failed test. C is a successful test. + + +=item B + +Perl normally expects the 'ok' or 'not ok' to be followed by a test +number. It is tolerated if the test numbers after '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 print < + 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>. +=item B + If the standard output line contains substring C< # Skip> (with variations in spacing and case) after C or C, it is -counted as a skipped test. In no other circumstance is anything -allowed to follow C or C. If the whole testscript -succeeds, the count of skipped tests is included in the generated -output. +counted as a skipped test. If the whole testscript succeeds, the +count of skipped tests is included in the generated output. C 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<1..0> line emitted if the test script is skipped completely: 1..0 # Skipped: no leverage found +=item B + 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 @@ -498,10 +721,25 @@ immediately. In that case the test script prints the magic words to standard output. Any message after these words will be displayed by C as the reason why testing is stopped. +=item B + +Additional comments may be put into the testing output on their own +lines. Comment lines should begin with a '#', Test::Harness will +ignore them. + + ok 1 + # Life is good, the sun is shining, RAM is cheap. + not ok 2 + # got 'Bush' expected 'Gore' + + =head1 EXPORT C<&runtests> is exported by Test::Harness per default. +C<$verbose> and C<$switches> are exported upon request. + + =head1 DIAGNOSTICS =over 4 @@ -518,8 +756,8 @@ above are printed. =item C -Scripts that return a non-zero exit status, both C<$? EE 8> and C<$?> are -printed in a message similar to the above. +Scripts that return a non-zero exit status, both C<$? EE 8> +and C<$?> are printed in a message similar to the above. =item C diff --git a/t/lib/sample-tests/bailout b/t/lib/sample-tests/bailout new file mode 100644 index 0000000..f67f673 --- /dev/null +++ b/t/lib/sample-tests/bailout @@ -0,0 +1,9 @@ +print <