From 3fbaac97953bf3ca27149a4c9bd6c9893141d568 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 12 Mar 2011 15:09:47 +0100
Subject: [PATCH] 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.
---
 t/test.pl | 56 ++++++++++++++++++++++++++++++++++++++++++--------------
 1 file 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
-- 
1.8.3.1