In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3857d07c85882fa81d5e5c1ce2867e8c957747d0?hp=82336099d393c4ac04507e58e4402ba9c413f791>
- Log ----------------------------------------------------------------- commit 3857d07c85882fa81d5e5c1ce2867e8c957747d0 Author: Nicholas Clark <[email protected]> Date: Fri Feb 4 16:02:38 2011 +0000 In B's OptreeCheck, always report inconsistent errors as a failed test. Previously there were 3 different options, and the default was to print a diagnostic (which obviously can get missed). Remove the options - tests are tests. As this means that most calls to checkOptree() now make two tests rather than one, update many of the test scripts' plans. M ext/B/t/OptreeCheck.pm M ext/B/t/f_map.t M ext/B/t/f_sort.t M ext/B/t/optree_check.t M ext/B/t/optree_concise.t M ext/B/t/optree_constants.t M ext/B/t/optree_misc.t M ext/B/t/optree_samples.t M ext/B/t/optree_sort.t M ext/B/t/optree_specials.t M ext/B/t/optree_varinit.t commit 3f47291432d23a4da5e85270f0a5e356ca6994ff Author: Nicholas Clark <[email protected]> Date: Fri Feb 4 15:32:28 2011 +0000 In B's OptreeCheck, implement proper qr// matching for regexps. Hence we can now do string matching on strings, rather than treating everything as a regexp. M ext/B/t/OptreeCheck.pm M ext/B/t/optree_concise.t commit 25b57a7e3aeaed75d57ab52d2271a61cbb3f222a Author: Nicholas Clark <[email protected]> Date: Fri Feb 4 15:08:28 2011 +0000 In B's OptreeCheck, inline diag_or_fail() into its only caller. $tc->{goterrs} is not referenced after this function, so no need to re-assign to it. M ext/B/t/OptreeCheck.pm ----------------------------------------------------------------------- Summary of changes: ext/B/t/OptreeCheck.pm | 89 ++++++++++++++----------------------------- ext/B/t/f_map.t | 2 +- ext/B/t/f_sort.t | 2 +- ext/B/t/optree_check.t | 2 +- ext/B/t/optree_concise.t | 4 +- ext/B/t/optree_constants.t | 2 +- ext/B/t/optree_misc.t | 4 +- ext/B/t/optree_samples.t | 2 +- ext/B/t/optree_sort.t | 2 +- ext/B/t/optree_specials.t | 2 +- ext/B/t/optree_varinit.t | 2 +- 11 files changed, 41 insertions(+), 72 deletions(-) diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm index 164f561..4bbe32b 100644 --- a/ext/B/t/OptreeCheck.pm +++ b/ext/B/t/OptreeCheck.pm @@ -51,7 +51,8 @@ various modes. prog => 'sort @a', # run in subprocess, aka -MO=Concise bcopts => '-exec', # $opt or \@opts, passed to BC::compile - errs => 'Useless variable "@main::a" .*' # str, regex, [str+] [regex+], + errs => 'Name "main::a" used only once: possible typo at -e line 1.', + # str, regex, [str+] [regex+], # various test options # errs => '.*', # match against any emitted errs, -w warnings @@ -262,17 +263,6 @@ checkErrs() is a getRendering helper that verifies that expected errs against those found when rendering the code on the platform. It is run after rendering, and before mkCheckRex. -Errors can be reported 3 different ways; diag, fail, print. - - diag - uses test.pl _diag() - fail - causes double-testing - print-.no # in front of the output (may mess up test harnesses) - -The 3 ways are selectable at runtimve via cmdline-arg: -report={diag,fail,print}. - - - =cut use Config; @@ -311,10 +301,6 @@ our %gOpts = # values are replaced at runtime !! help => [0, 'provides help and exits', 0], testmode => [qw/ native cross both /], - # reporting mode for rendering errs - report => [qw/ diag fail print /], - errcont => [1, 'if 1, tests match even if report is fail', 0], - # fixup for VMS, cygwin, which don't have stderr b4 stdout rxnoorder => [1, 'if 1, dont req match on -e lines, and -banner',0], strip => [1, 'if 1, catch errs and remove from renderings',0], @@ -452,19 +438,8 @@ sub newTestCases { $tc->{$k} = $gOpts{$k} unless defined $tc->{$k}; } } - # transform errs to self-hash for efficient set-math if ($tc->{errs}) { - if (not ref $tc->{errs}) { - $tc->{errs} = { $tc->{errs} => 1}; - } - elsif (ref $tc->{errs} eq 'ARRAY') { - my %errs; - @errs{@{$tc->{errs}}} = (1) x @{$tc->{errs}}; - $tc->{errs} = \%errs; - } - elsif (ref $tc->{errs} eq 'Regexp') { - warn "regexp err matching not yet implemented"; - } + $tc->{errs} = [$tc->{errs}] unless ref $tc->{errs} eq 'ARRAY'; } return $tc; } @@ -559,43 +534,37 @@ sub checkErrs { # check rendering errs against expected errors, reduce and report my $tc = shift; - # check for agreement, by hash (order less important) - my (%goterrs, @got); - $tc->{goterrs} ||= []; - @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}}; - - foreach my $k (keys %{$tc->{errs}}) { - if (@got = grep /^$k$/, keys %goterrs) { - delete $tc->{errs}{$k}; - delete $goterrs{$_} foreach @got; + # check for agreement (order not important) + my (%goterrs, @missed); + @goterrs{@{$tc->{goterrs}}} = (1) x scalar @{$tc->{goterrs}} + if $tc->{goterrs}; + + foreach my $want (@{$tc->{errs}}) { + if (ref $want) { + my $seen; + foreach my $k (keys %goterrs) { + next unless $k =~ $want; + delete $goterrs{$k}; + ++$seen; + } + push @missed, $want unless $seen; + } else { + push @missed, $want unless defined delete $goterrs{$want}; } } - $tc->{goterrs} = \%goterrs; - - # relook at altered - if (%{$tc->{errs}} or %{$tc->{goterrs}}) { - $tc->diag_or_fail(); - } - fail("FORCED: $tc->{name}:\n") if $gOpts{fail}; # silly ? -} -sub diag_or_fail { - # help checkErrs - my $tc = shift; - - my @lines; - push @lines, "got unexpected:", sort keys %{$tc->{goterrs}} if %{$tc->{goterrs}}; - push @lines, "missed expected:", sort keys %{$tc->{errs}} if %{$tc->{errs}}; - - if (@lines) { - unshift @lines, $tc->{name}; - my $report = join("\n", @lines); + @missed = sort @missed; + my @got = sort keys %goterrs; - if ($gOpts{report} eq 'diag') { _diag ($report) } - elsif ($gOpts{report} eq 'fail') { fail ($report) } - else { print ($report) } - next unless $gOpts{errcont}; # skip block + if (@{$tc->{errs}} + ? is(@missed + @got, 0, "Only got expected errors for $tc->{name}") + : is(scalar @got, 0, "Got no errors for $tc->{name}") # @missed must be 0 here. + ) { + _diag(join "\n", "got unexpected:", @got) if @got; + _diag(join "\n", "missed expected:", @missed) if @missed; } + + fail("FORCED: $tc->{name}:\n") if $gOpts{fail}; # silly ? } =head1 mkCheckRex ($tc) diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index 00bb31e..9f323b8 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -13,7 +13,7 @@ BEGIN { } } use OptreeCheck; -plan tests => 9; +plan tests => 18; =head1 f_map.t diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t index 1ebeb24..51f2aa5 100644 --- a/ext/B/t/f_sort.t +++ b/ext/B/t/f_sort.t @@ -13,7 +13,7 @@ BEGIN { } } use OptreeCheck; -plan tests => 20; +plan tests => 40; =head1 f_sort.t diff --git a/ext/B/t/optree_check.t b/ext/B/t/optree_check.t index 1c55fb6..bcbb554 100644 --- a/ext/B/t/optree_check.t +++ b/ext/B/t/optree_check.t @@ -26,7 +26,7 @@ cmdline args in 'standard' way across all clients of OptreeCheck. =cut -plan tests => 5 + 15 + 16 * $gOpts{selftest}; # pass()s + $#tests +plan tests => 5 + 15 + 12 + 16 * $gOpts{selftest}; # pass()s + $#tests pass("REGEX TEST HARNESS SELFTEST"); diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t index df4162a..aa28ebb 100644 --- a/ext/B/t/optree_concise.t +++ b/ext/B/t/optree_concise.t @@ -17,7 +17,7 @@ BEGIN { use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! use Config; -plan tests => 23; +plan tests => 41; $SIG{__WARN__} = sub { my $err = shift; @@ -274,7 +274,7 @@ checkOptree ( name => 'cmdline self-strict compile err using code', code => 'use strict; sort @a', bcopts => [qw/ -basic -concise -exec /], - errs => 'Global symbol "@a" requires explicit package name at .*? line 1.', + errs => qr/Global symbol "\@a" requires explicit package name at .*? line 1\./, note => 'this test relys on a kludge which copies $@ to rendering when empty', expect => 'Global symbol', expect_nt => 'Global symbol', diff --git a/ext/B/t/optree_constants.t b/ext/B/t/optree_constants.t index b90c874..7b1d267 100644 --- a/ext/B/t/optree_constants.t +++ b/ext/B/t/optree_constants.t @@ -16,7 +16,7 @@ BEGIN { use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! use Config; -plan tests => 30; +plan tests => 57; ################################# diff --git a/ext/B/t/optree_misc.t b/ext/B/t/optree_misc.t index a7bf436..4c3ea14 100644 --- a/ext/B/t/optree_misc.t +++ b/ext/B/t/optree_misc.t @@ -10,10 +10,10 @@ BEGIN { } use OptreeCheck; use Config; -plan tests => 3; +plan tests => 6; SKIP: { -skip "no perlio in this build", 2 unless $Config::Config{useperlio}; +skip "no perlio in this build", 4 unless $Config::Config{useperlio}; # The regression this is testing is that the first aelemfast, derived # from a lexical array, is supposed to be a BASEOP "<0>", while the diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 82f8817..3cc0f26 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -14,7 +14,7 @@ BEGIN { } use OptreeCheck; use Config; -plan tests => 20; +plan tests => 34; pass("GENERAL OPTREE EXAMPLES"); diff --git a/ext/B/t/optree_sort.t b/ext/B/t/optree_sort.t index 97d3d78..b602e43 100644 --- a/ext/B/t/optree_sort.t +++ b/ext/B/t/optree_sort.t @@ -14,7 +14,7 @@ BEGIN { } use OptreeCheck; use Config; -plan tests => 11; +plan tests => 21; pass("SORT OPTIMIZATION"); diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t index 5945f91..b8b9078 100644 --- a/ext/B/t/optree_specials.t +++ b/ext/B/t/optree_specials.t @@ -20,7 +20,7 @@ BEGIN { use OptreeCheck; # ALSO DOES @ARGV HANDLING !!!!!! use Config; -plan tests => 7 + ($] > 5.009 ? 1 : 0); +plan tests => 13 + ($] > 5.009 ? 2 : 0); require_ok("B::Concise"); diff --git a/ext/B/t/optree_varinit.t b/ext/B/t/optree_varinit.t index ca3ad23..e0a95b7 100644 --- a/ext/B/t/optree_varinit.t +++ b/ext/B/t/optree_varinit.t @@ -14,7 +14,7 @@ BEGIN { } use OptreeCheck; use Config; -plan tests => 22; +plan tests => 42; pass("OPTIMIZER TESTS - VAR INITIALIZATION"); -- Perl5 Master Repository
