From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 5 Mar 2011 12:19:53 +0000 (+0000)
Subject: Add warning_like() in test.pl to replace some uses of ReTest.pl's must_warn().
X-Git-Tag: accepted/trunk/20130322.191538~5155
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=4d18b3536a6ea65f1042a9b0bb074065af24e3d7;p=platform%2Fupstream%2Fperl.git

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
--- 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
--- 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
--- 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.