From: Jarkko Hietaniemi Date: Sat, 11 May 2002 19:35:54 +0000 (+0000) Subject: Upgrade to Test::Harness 2.21. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=308957f541b811baacac724110dfa4a630847c0e;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test::Harness 2.21. p4raw-id: //depot/perl@16546 --- diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 92ebf1d..fb2aa9a 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -1,5 +1,5 @@ # -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id: Harness.pm,v 1.22 2002/04/30 04:55:27 schwern Exp $ +# $Id: Harness.pm,v 1.28 2002/05/06 04:44:29 schwern Exp $ package Test::Harness; @@ -12,7 +12,7 @@ use Config; use strict; use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest - $Columns $verbose $switches + $Columns $verbose $switches $ML @ISA @EXPORT @EXPORT_OK ); @@ -22,7 +22,7 @@ use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest $Have_Devel_Corestack = 0; -$VERSION = '2.04'; +$VERSION = '2.21'; $ENV{HARNESS_ACTIVE} = 1; @@ -421,6 +421,7 @@ B Currently this function is still noisy. I'm working on it. =cut +#'# sub _run_all_tests { my(@tests) = @_; local($|) = 1; @@ -441,64 +442,49 @@ sub _run_all_tests { bench => 0, ); - local($ENV{'PERL5LIB'}) = $Strap->_INC2PERL5LIB; - my @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir; my $t_start = new Benchmark; my $width = _leader_width(@tests); foreach my $tfile (@tests) { - $Strap->_reset_file_state; 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); + # 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}, ml => $ml, ); - my($seen_header, $tests_seen) = (0,0); - while (<$fh>) { - print if $Verbose; - - $Strap->{line}++; - 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; - - 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; + my($estatus, $wstatus) = @results{qw(exit wait)}; if ($wstatus) { $failedtests{$tfile} = _dubious_return(\%test, \%tot, $estatus, $wstatus); $failedtests{$tfile}{name} = $tfile; } - elsif ($allok) { + elsif ($results{passing}) { if ($test{max} and $test{skipped} + $test{bonus}) { my @msg; push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}") @@ -561,8 +547,6 @@ sub _run_all_tests { } } - $tot{sub_skipped} += $test{skipped}; - if (defined $Files_In_Dir) { my @new_dir_files = _globdir $Files_In_Dir; if (@new_dir_files != @dir_files) { @@ -574,8 +558,6 @@ sub _run_all_tests { @dir_files = @new_dir_files; } } - - close $fh; } $tot{bench} = timediff(new Benchmark, $t_start); @@ -678,131 +660,70 @@ sub _show_results { } -sub _parse_header { - my($line, $test, $tot) = @_; +my %Handlers = (); +$Strap->{callback} = sub { + my($self, $line, $type, $totals) = @_; + print $line if $Verbose; - my $is_header = 0; + my $meth = $Handlers{$type}; + $meth->($self, $line, $type, $totals) if $meth; +}; - if( $Strap->_is_header($line) ) { - $is_header = 1; - $test->{max} = $Strap->{max}; - for ( keys %{$Strap->{todo}} ) { $test->{todo}{$_} = 1; } +$Handlers{header} = sub { + my($self, $line, $type, $totals) = @_; - $test->{skip_reason} = $Strap->{skip_all} - if not $test->{max} and defined $Strap->{skip_all}; + warn "Test header seen more than once!\n" if $self->{_seen_header}; - $test->{'next'} = 1 unless $test->{'next'}; + $self->{_seen_header}++; + warn "1..M can only appear at the beginning or end of tests\n" + if $totals->{seen} && + $totals->{max} < $totals->{seen}; +}; - $tot->{max} += $test->{max}; - } - else { - $is_header = 0; - } +$Handlers{test} = sub { + my($self, $line, $type, $totals) = @_; - return $is_header; -} - - -sub _open_test { - my($test) = shift; - - my $s = _set_switches($test); + my $curr = $totals->{seen}; + my $next = $self->{'next'}; + my $max = $totals->{max}; + my $detail = $totals->{details}[-1]; - my $perl = -x $^X ? $^X : $Config{perlpath}; + if( $detail->{ok} ) { + _print_ml("ok $curr/$max"); - # XXX This is WAY too core specific! - my $cmd = ($ENV{'HARNESS_COMPILE_TEST'}) - ? "./perl -I../lib ../utils/perlcc $test " - . "-r 2>> ./compilelog |" - : "$perl $s $test|"; - $cmd = "MCR $cmd" if $^O eq 'VMS'; - - if( open(PERL, $cmd) ) { - return \*PERL; + 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"); } -} + 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"; + } -sub _parse_test_line { - my($line, $test, $tot) = @_; - - my %result; - if ( $Strap->_is_test($line, \%result) ) { - $test->{'next'} ||= 1; - my $this = $test->{'next'}; - - my($not, $tnum) = (!$result{ok}, $result{number}); - - $this = $tnum if $tnum; - - my($type, $reason) = ($result{type}, $result{reason}); - - my($istodo, $isskip); - if( defined $type ) { - $istodo = 1 if $type eq 'todo'; - $isskip = 1 if $type eq 'skip'; - } - - $test->{todo}{$this} = 1 if $istodo; - if( $test->{todo}{$this} ) { - $tot->{todo}++; - $test->{bonus}++, $tot->{bonus}++ unless $not; - } +}; - if( $not && !$test->{todo}{$this} ) { - print "$test->{ml}NOK $this" if $test->{ml}; - push @{$test->{failed}}, $this; - } - else { - print "$test->{ml}ok $this/$test->{max}" if $test->{ml}; - $test->{ok}++; - $tot->{ok}++; - $test->{skipped}++ if $isskip; - - $reason = '[no reason given]' - if $isskip and not defined $reason; - 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; - } - } +$Handlers{bailout} = sub { + my($self, $line, $type, $totals) = @_; - if ($this > $test->{'next'}) { - print "Test output counter mismatch [test $this]\n"; + die "FAILED--Further testing stopped" . + ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n"); +}; - # Guard against resource starvation. - if( $this > 100000 ) { - print "Enourmous test number seen [test $this]\n"; - } - else { - 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; - } - else { - my $bail_reason; - if( $Strap->_is_bail_out($line, \$bail_reason) ) { # bail out! - die "FAILED--Further testing stopped" . - ($bail_reason ? ": $bail_reason\n" : ".\n"); - } - } +sub _print_ml { + print join '', $ML, @_ if $ML; } @@ -832,33 +753,6 @@ sub _bonusmsg { 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; - - my $s = $Switches; - $s .= $Strap->_switches($test); - - return $s; -} - - # Test program go boom. sub _dubious_return { my($test, $tot, $estatus, $wstatus) = @_; @@ -902,12 +796,6 @@ sub _dubious_return { } -sub _garbled_output { - my($gibberish) = shift; - warn "Confusing test output: '$gibberish'\n"; -} - - sub _create_fmts { my($failedtests) = @_; @@ -1068,7 +956,7 @@ and C<$?> are printed in a message similar to the above. If not all tests were successful, the script dies with one of the above messages. -=item C +=item C If a single subtest decides that further testing will not make sense, the script dies with this message. @@ -1179,6 +1067,7 @@ 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. +(Partially done with new skip test styles) Deal with VMS's "not \nok 4\n" mistake. diff --git a/lib/Test/Harness/Changes b/lib/Test/Harness/Changes index 7ba77b1..cfc1bff 100644 --- a/lib/Test/Harness/Changes +++ b/lib/Test/Harness/Changes @@ -1,5 +1,20 @@ Revision history for Perl extension Test::Harness +2.21 Mon May 6 00:43:22 EDT 2002 + - removed a bunch of dead code left over after 2.20's gutting. + - The fix for the $^X "bug" added in 2.02 has been removed. It + caused more trouble than the old bug (I'd never seen a problem + before anyway) + - 2.20 broke $verbose + +2.20 Sat May 4 22:31:20 EDT 2002 + * An almost complete conversion of the Test::Harness test parsing + to use Test::Harness::Straps. + +2.04 Tue Apr 30 00:54:49 EDT 2002 + * Changing the output format of skips + - Taking into account VMS's special exit codes in the tests. + 2.03 Thu Apr 25 01:01:34 EDT 2002 * $^X fix made safer. - Noise from loading wait.ph to analyze core files supressed diff --git a/lib/Test/Harness/Straps.pm b/lib/Test/Harness/Straps.pm index 7886984..73cc009 100644 --- a/lib/Test/Harness/Straps.pm +++ b/lib/Test/Harness/Straps.pm @@ -1,12 +1,12 @@ # -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id: Straps.pm,v 1.3 2002/04/30 04:55:27 schwern Exp $ +# $Id: Straps.pm,v 1.4 2002/05/05 02:32:54 schwern Exp $ package Test::Harness::Straps; use strict; use vars qw($VERSION); use Config; -$VERSION = '0.09'; +$VERSION = '0.10'; use Test::Harness::Assert; use Test::Harness::Iterator; @@ -137,11 +137,12 @@ sub _analyze_iterator { todo => 0, skip => 0, bonus => 0, - + details => [] ); - + # Set them up here so callbacks can have them. + $self->{totals}{$name} = \%totals; while( defined(my $line = $it->next) ) { $self->_analyze_line($line, \%totals); last if $self->{saw_bailout}; @@ -155,7 +156,6 @@ sub _analyze_iterator { $totals{max} == $totals{ok}); $totals{passing} = $passed ? 1 : 0; - $self->{totals}{$name} = \%totals; return %totals; } @@ -164,7 +164,7 @@ sub _analyze_line { my($self, $line, $totals) = @_; my %result = (); - + $self->{line}++; my $type; @@ -172,7 +172,7 @@ sub _analyze_line { $type = 'header'; $self->{saw_header}++; - + $totals->{max} += $self->{max}; } elsif( $self->_is_test($line, \%result) ) { @@ -633,8 +633,11 @@ sub _detailize { assert( !(grep !defined $details{$_}, keys %details), 'test contains the ok and actual_ok info' ); + # We don't want these to be undef because they are often + # checked and don't want the checker to have to deal with + # uninitialized vars. foreach my $piece (qw(name type reason)) { - $details{$piece} = $test->{$piece} if $test->{$piece}; + $details{$piece} = defined $test->{$piece} ? $test->{$piece} : ''; } return %details; diff --git a/lib/Test/Harness/t/strap-analyze.t b/lib/Test/Harness/t/strap-analyze.t index 5dc1f22..9636557 100644 --- a/lib/Test/Harness/t/strap-analyze.t +++ b/lib/Test/Harness/t/strap-analyze.t @@ -168,7 +168,7 @@ my %samples = ( ({ 'ok'=> 1, actual_ok => 1 }) x 2 ], }, - + simple => { passing => 1, @@ -177,12 +177,12 @@ my %samples = ( max => 5, seen => 5, - + 'ok' => 5, 'todo' => 0, 'skip' => 0, bonus => 0, - + details => [ ({ 'ok' => 1, actual_ok => 1 }) x 5 ] }, @@ -195,12 +195,12 @@ my %samples = ( max => 5, seen => 5, - + 'ok' => 3, 'todo' => 0, 'skip' => 0, bonus => 0, - + details => [ { 'ok' => 1, actual_ok => 1 }, { 'ok' => 0, actual_ok => 0 }, { 'ok' => 1, actual_ok => 1 }, @@ -222,7 +222,7 @@ my %samples = ( 'todo' => 0, 'skip' => 1, bonus => 0, - + details => [ { 'ok' => 1, actual_ok => 1 }, { 'ok' => 1, actual_ok => 1, type => 'skip', @@ -246,7 +246,7 @@ my %samples = ( 'todo' => 0, 'skip' => 0, bonus => 0, - + details => [], }, @@ -258,7 +258,7 @@ my %samples = ( max => 5, seen => 5, - + 'ok' => 5, 'todo' => 2, 'skip' => 0, @@ -370,27 +370,35 @@ my %samples = ( max => 2, seen => 4, - + 'ok' => 4, 'todo' => 0, 'skip' => 0, bonus => 0, - + details => [ { 'ok' => 1, actual_ok => 1 }, { 'ok' => 1, actual_ok => 1 }, ] }, ); - $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /^Enourmous test number/ || $_[0] =~ /^Can't detailize/ }; while( my($test, $expect) = each %samples ) { + for (0..$#{$expect->{details}}) { + $expect->{details}[$_]{type} = '' + unless exists $expect->{details}[$_]{type}; + $expect->{details}[$_]{name} = '' + unless exists $expect->{details}[$_]{name}; + $expect->{details}[$_]{reason} = '' + unless exists $expect->{details}[$_]{reason}; + } + my $strap = Test::Harness::Straps->new; my %results = $strap->analyze_file("$SAMPLE_TESTS/$test"); - + is_deeply($results{details}, $expect->{details}, "$test details" ); delete $expect->{details}; diff --git a/lib/Test/Harness/t/test-harness.t b/lib/Test/Harness/t/test-harness.t index ad948ac..4e416e0 100644 --- a/lib/Test/Harness/t/test-harness.t +++ b/lib/Test/Harness/t/test-harness.t @@ -366,7 +366,7 @@ my %samples = ( }, ); -plan tests => (keys(%samples) * 4) + 1; +plan tests => (keys(%samples) * 7) + 1; use Test::Harness; use_ok('Test::Harness'); @@ -377,29 +377,44 @@ tie *NULL, 'My::Dev::Null' or die $!; while (my($test, $expect) = each %samples) { # _run_all_tests() runs the tests but skips the formatting. my($totals, $failed); + my $warning; eval { select NULL; # _run_all_tests() isn't as quiet as it should be. + local $SIG{__WARN__} = sub { $warning .= join '', @_; }; ($totals, $failed) = Test::Harness::_run_all_tests("$SAMPLE_TESTS/$test"); }; select STDOUT; - unless( $@ ) { - is( Test::Harness::_all_ok($totals), $expect->{all_ok}, - "$test - all ok" ); - ok( defined $expect->{total}, "$test - has total" ); + SKIP: { + skip "special tests for bailout", 1 unless $test eq 'bailout'; + like( $@, '/Further testing stopped: GERONI/i' ); + } + + SKIP: { + skip "don't apply to a bailout", 5 if $test eq 'bailout'; + is( $@, '' ); + is( Test::Harness::_all_ok($totals), $expect->{all_ok}, + "$test - all ok" ); + ok( defined $expect->{total}, "$test - has total" ); is_deeply( {map { $_=>$totals->{$_} } keys %{$expect->{total}}}, $expect->{total}, - "$test - totals" ); + "$test - totals" ); is_deeply( {map { $_=>$failed->{"$SAMPLE_TESTS/$test"}{$_} } - keys %{$expect->{failed}}}, + keys %{$expect->{failed}}}, $expect->{failed}, - "$test - failed" ); + "$test - failed" ); } - else { # special case for bailout - is( $test, 'bailout' ); - like( $@, '/Further testing stopped: GERONI/i', $test ); - pass( 'skipping for bailout' ); - pass( 'skipping for bailout' ); + + SKIP: { + skip "special tests for bignum", 1 unless $test eq 'bignum'; + is( $warning, <