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.

diff --git a/t/test.pl b/t/test.pl
index e55105c..34150aa 100644 (file)
--- 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