_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 {
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 {
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