Add warning_like() in test.pl to replace some uses of ReTest.pl's must_warn().

warning_like() provides a subset of the functionality of the routine of the
same name in Test::Warn. Remove the definition of must_warn() in t/re/subst.t,
which had been copied from t/re/ReTest.pl from when ReTest.pl and test.pl
clashed.

diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t
index 701d9f7..1a53780 100644 (file)
--- a/t/re/pat_advanced.t
+++ b/t/re/pat_advanced.t
@@ -179,8 +179,8 @@ sub run_tests {
     {
         # From Japhy
        foreach (qw(c g o)) {
-           must_warn "qr/(?$_)/",    qr/^Useless \(\?$_\)/;
-           must_warn "qr/(?-$_)/",   qr/^Useless \(\?-$_\)/;
+           warning_like(sub {'' =~ "(?$_)"},    qr/^Useless \(\?$_\)/);
+           warning_like(sub {'' =~ "(?-$_)"},   qr/^Useless \(\?-$_\)/);
        }
 
         # Now test multi-error regexes

diff --git a/t/re/subst.t b/t/re/subst.t
index 2a3e3fc..09c9a47 100644 (file)
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -9,21 +9,6 @@ BEGIN {
 require './test.pl';
 plan( tests => 176 );
 
-# Stolen from re/ReTest.pl. Can't just use the file since it doesn't support
-# like() and it conflicts with test.pl
-sub must_warn {
-    my ($code, $pattern, $name) = @_;
-    my $w;
-    local $SIG {__WARN__} = sub {$w .= join "" => @_};
-    use warnings 'all';
-    ref $code ? &$code : eval $code;
-    my $r = $w && $w =~ /$pattern/;
-    $w //= "UNDEF";
-    ok( $r, $name // "Got warning /$pattern/", $r ? undef :
-            "# expected: /$pattern/\n" .
-            "#   result: $w" );
-}
-
 $_ = 'david';
 $a = s/david/rules/r;
 ok( $_ eq 'david' && $a eq 'rules', 'non-destructive substitute' );
@@ -61,10 +46,14 @@ like( $@, qr{Using !~ with s///r doesn't make sense}, 's///r !~ operator gives e
         ok ( !defined $a && !defined $b, 's///r with undef input' );
 
         use warnings;
-        must_warn sub { $b = $a =~ s/left/right/r }, '^Use of uninitialized value', 's///r Uninitialized warning';
+        warning_like(sub { $b = $a =~ s/left/right/r },
+                    qr/^Use of uninitialized value/,
+                    's///r Uninitialized warning');
 
         $a = 'david';
-        must_warn 's/david/sucks/r; 1',    '^Useless use of non-destructive substitution', 's///r void context warning';
+        warning_like(sub {eval 's/david/sucks/r; 1'},
+                    qr/^Useless use of non-destructive substitution/,
+                    's///r void context warning');
 }
 
 $a = '';

diff --git a/t/test.pl b/t/test.pl
index a3bab73..e3ecd38 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -1063,7 +1063,7 @@ WHOA
     _ok( !$diag, _where(), $name );
 }
 
-sub warning_is {
+sub _warning {
     my ($code, $expect, $name) = @_;
     my @w;
     local $SIG {__WARN__} = sub {push @w, join "", @_};
@@ -1071,11 +1071,15 @@ sub warning_is {
        use warnings 'all';
        &$code;
     }
-    local $Level = $Level + 1;
+    local $Level = $Level + 2;
     if(!defined $expect) {
        is("@w", '', $name);
     } elsif (@w == 1) {
-       is($w[0], $expect, $name);
+       if(ref $expect) {
+           like($w[0], $expect, $name);
+       } else {
+           is($w[0], $expect, $name);
+       }
     } else {
        # This will fail, generating diagnostics
        cmp_ok(scalar @w, '==', 1, $name);
@@ -1083,6 +1087,20 @@ sub warning_is {
     }
 }
 
+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);
+}
+
+sub warning_like {
+    my ($code, $expect, $name) = @_;
+    die sprintf "Expect must be a regexp object"
+       unless ref $expect eq 'Regexp';
+    _warning($code, $expect, $name);
+}
+
 # Set a watchdog to timeout the entire test file
 # NOTE:  If the test file uses 'threads', then call the watchdog() function
 #        _AFTER_ the 'threads' module is loaded.