In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3fbaac97953bf3ca27149a4c9bd6c9893141d568?hp=3dfaac447d030f911d146c3ae56b9dba63ce9dd4>
- Log ----------------------------------------------------------------- commit 3fbaac97953bf3ca27149a4c9bd6c9893141d568 Author: Nicholas Clark <[email protected]> Date: Sat Mar 12 15:09:47 2011 +0100 In test.pl, refactor the implementation of warning_{is,like} and warnings_like. Break out the code to capture warnings from the code to analyse them. Implement tests directly in warning_{is,like}, rather than implementing them as a call to warning_like. Remove the C<use warnings "all">, as it is lexically scoped, and won't apply to the scope of the subroutine being called. Previously all 3 would erroneously pass if the expectation was for 1 warning, there were more than 1 warnings, but the first warning matched the expected warning. ----------------------------------------------------------------------- Summary of changes: t/test.pl | 56 ++++++++++++++++++++++++++++++++++++++++++-------------- 1 files changed, 42 insertions(+), 14 deletions(-) diff --git a/t/test.pl b/t/test.pl index e55105c..34150aa 100644 --- a/t/test.pl +++ b/t/test.pl @@ -1095,26 +1095,44 @@ WHOA _ok( !$diag, _where(), $name ); } -# This will generate a variable number of tests if passed an array of 2 or more -# tests. Use done_testing() instead of a fixed plan. -sub warnings_like { - my ($code, $expect, $name) = @_; +sub capture_warnings { + my $code = shift; + my @w; local $SIG {__WARN__} = sub {push @w, join "", @_}; - { - use warnings 'all'; - &$code; - } + &$code; + return @w; +} + +# This will generate a variable number of tests. +# Use done_testing() instead of a fixed plan. +sub warnings_like { + my ($code, $expect, $name) = @_; local $Level = $Level + 1; - cmp_ok(scalar @w, '==', scalar @$expect, $name) if @$expect != 1; - while (my ($i, $e) = each @$expect) { + my @w = capture_warnings($code); + + cmp_ok(scalar @w, '==', scalar @$expect, $name); + foreach my $e (@$expect) { if (ref $e) { - like($w[$i], $e, $name); + like(shift @w, $e, $name); } else { - is($w[$i], $e, $name); + is(shift @w, $e, $name); } } + if (@w) { + diag("Saw these additional warnings:"); + diag($_) foreach @w; + } +} + +sub _fail_excess_warnings { + my($expect, $got, $name) = @_; + local $Level = $Level + 1; + # This will fail, and produce diagnostics + is($expect, scalar @$got, $name); + diag("Saw these warnings:"); + diag($_) foreach @$got; } sub warning_is { @@ -1122,7 +1140,12 @@ sub warning_is { die sprintf "Expect must be a string or undef, not a %s reference", ref $expect if ref $expect; local $Level = $Level + 1; - warnings_like($code, defined $expect? [$expect] : [], $name); + my @w = capture_warnings($code); + if (@w > 1) { + _fail_excess_warnings(0 + defined $expect, \@w, $name); + } else { + is($w[0], $expect, $name); + } } sub warning_like { @@ -1130,7 +1153,12 @@ sub warning_like { die sprintf "Expect must be a regexp object" unless ref $expect eq 'Regexp'; local $Level = $Level + 1; - warnings_like($code, [$expect], $name); + my @w = capture_warnings($code); + if (@w > 1) { + _fail_excess_warnings(0 + defined $expect, \@w, $name); + } else { + like($w[0], $expect, $name); + } } # Set a watchdog to timeout the entire test file -- Perl5 Master Repository
