This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add warnings_like() in test.pl to replace must_warn() in ReTest.pl.
authorNicholas Clark <nick@ccl4.org>
Sat, 5 Mar 2011 13:03:03 +0000 (13:03 +0000)
committerNicholas Clark <nick@ccl4.org>
Sat, 5 Mar 2011 20:26:10 +0000 (20:26 +0000)
warnings_like() provides a subset of the functionality of the routine of the
same name in Test::Warn.

t/re/ReTest.pl
t/re/pat_advanced.t
t/test.pl

index fe92010..41a1d5f 100644 (file)
@@ -33,14 +33,4 @@ sub eval_ok ($;$) {
     }
 }
 
-sub must_warn {
-    my ($code, $pattern, $name) = @_;
-    Carp::confess("Bad pattern") unless $pattern;
-    my $w;
-    local $SIG {__WARN__} = sub {$w .= join "" => @_};
-    use warnings 'all';
-    ref $code ? &$code : eval $code;
-    like($w, qr/$pattern/, "Got warning /$pattern/");
-}
-
 1;
index 1a53780..c52c202 100644 (file)
@@ -24,9 +24,6 @@ BEGIN {
     do "re/ReTest.pl" or die $@;
 }
 
-
-plan tests => 1344;  # Update this when adding/deleting tests.
-
 run_tests() unless caller;
 
 #
@@ -184,12 +181,16 @@ sub run_tests {
        }
 
         # Now test multi-error regexes
-        must_warn 'qr/(?g-o)/',  '^Useless \(\?g\).*\nUseless \(\?-o\)';
-        must_warn 'qr/(?g-c)/',  '^Useless \(\?g\).*\nUseless \(\?-c\)';
-        # (?c) means (?g) error won't be thrown
-        must_warn 'qr/(?o-cg)/', '^Useless \(\?o\).*\nUseless \(\?-c\)';
-        must_warn 'qr/(?ogc)/',  '^Useless \(\?o\).*\nUseless \(\?g\).*\n' .
-                                  'Useless \(\?c\)';
+       foreach (['(?g-o)', qr/^Useless \(\?g\)/, qr/^Useless \(\?-o\)/],
+                ['(?g-c)', qr/^Useless \(\?g\)/, qr/^Useless \(\?-c\)/],
+                # (?c) means (?g) error won't be thrown
+                ['(?o-cg)', qr/^Useless \(\?o\)/, qr/^Useless \(\?-c\)/],
+                ['(?ogc)', qr/^Useless \(\?o\)/, qr/^Useless \(\?g\)/,
+                 qr/^Useless \(\?c\)/],
+               ) {
+           my ($re, @warnings) = @$_;
+           warnings_like(sub {eval "qr/$re/"}, \@warnings, "qr/$re/ warns");
+       }
     }
 
     {
@@ -2087,6 +2088,8 @@ sub run_tests {
 
     # !!! NOTE that tests that aren't at all likely to crash perl should go
     # a ways above, above these last ones.
+
+    done_testing();
 } # End of sub run_tests
 
 1;
index e3ecd38..0c4c3a7 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -1063,7 +1063,9 @@ WHOA
     _ok( !$diag, _where(), $name );
 }
 
-sub _warning {
+# 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) = @_;
     my @w;
     local $SIG {__WARN__} = sub {push @w, join "", @_};
@@ -1071,19 +1073,15 @@ sub _warning {
        use warnings 'all';
        &$code;
     }
-    local $Level = $Level + 2;
-    if(!defined $expect) {
-       is("@w", '', $name);
-    } elsif (@w == 1) {
-       if(ref $expect) {
-           like($w[0], $expect, $name);
+    local $Level = $Level + 1;
+
+    cmp_ok(scalar @w, '==', scalar @$expect, $name) if @$expect != 1;
+    while (my ($i, $e) = each @$expect) {
+       if (ref $e) {
+           like($w[$i], $e, $name);
        } else {
-           is($w[0], $expect, $name);
+           is($w[$i], $e, $name);
        }
-    } else {
-       # This will fail, generating diagnostics
-       cmp_ok(scalar @w, '==', 1, $name);
-       diag("Warning: $_") foreach @w;
     }
 }
 
@@ -1091,14 +1089,16 @@ sub warning_is {
     my ($code, $expect, $name) = @_;
     die sprintf "Expect must be a string or undef, not a %s reference", ref $expect
        if ref $expect;
-    _warning($code, $expect, $name);
+    local $Level = $Level + 1;
+    warnings_like($code, defined $expect? [$expect] : [], $name);
 }
 
 sub warning_like {
     my ($code, $expect, $name) = @_;
     die sprintf "Expect must be a regexp object"
        unless ref $expect eq 'Regexp';
-    _warning($code, $expect, $name);
+    local $Level = $Level + 1;
+    warnings_like($code, [$expect], $name);
 }
 
 # Set a watchdog to timeout the entire test file