Make like() and unlike() in t/test.pl refuse non-qr// arguments

As I noted in v5.21.1-12-g826af13 we have subtle bugs in the test suite
because you can do e.g. like($@, '') now which'll be a passing test even
when we have an error, because $@ =~ // will be true.

I'm just changing t/test.pl to not accept non-Regexp arguments, and
fixing up a bunch of test failures that resulted from that. There might
still be more of these in tests that I'm just not running, I've also
changed some of these from $str =~ /foo/ to $str eq 'foo'
(i.e. s/like/is/) in cases where that appeared to work, but it might
break some systems.

Let's just find that out via the smokers.

diff --git a/dist/IO/t/io_taint.t b/dist/IO/t/io_taint.t
index 5740353..7c3ffe6 100644 (file)
--- a/dist/IO/t/io_taint.t
+++ b/dist/IO/t/io_taint.t
@@ -33,7 +33,7 @@ chop(my $unsafe = <$x>);
 eval { kill 0 * $unsafe };
 SKIP: {
   skip($^O) if $^O eq 'MSWin32' or $^O eq 'NetWare';
-  like($@, '^Insecure');
+  like($@, qr/^Insecure/);
 }
 $x->close;
 
@@ -44,7 +44,7 @@ $x->untaint;
 ok(!$?); # Calling the method worked
 chop($unsafe = <$x>);
 eval { kill 0 * $unsafe };
-unlike($@,'^Insecure');
+unlike($@,qr/^Insecure/);
 $x->close;
 
 TODO: {

diff --git a/dist/threads/t/err.t b/dist/threads/t/err.t
index f5e0a19..b708823 100644 (file)
--- a/dist/threads/t/err.t
+++ b/dist/threads/t/err.t
@@ -28,7 +28,7 @@ my $result = $thr->join();
 ok(! defined($result), 'thread died');
 
 # Check error
-like($thr->error(), q/Can't locate object method/, 'thread error');
+like($thr->error(), qr/^Can't locate object method/s, 'thread error');
 
 
 # Create a thread that 'die's with an object

diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t
index 6acad2f..2879e2b 100644 (file)
--- a/dist/threads/t/exit.t
+++ b/dist/threads/t/exit.t
@@ -121,7 +121,7 @@ my $out = run_perl(prog => 'use threads 1.92;' .
     local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS';
     is($?>>8, 99, "exit(status) in thread");
 }
-like($out, '1 finished and unjoined', "exit(status) in thread");
+like($out, qr/1 finished and unjoined/, "exit(status) in thread");
 
 
 $out = run_perl(prog => 'use threads 1.92 qw(exit thread_only);' .
@@ -138,7 +138,7 @@ $out = run_perl(prog => 'use threads 1.92 qw(exit thread_only);' .
     local $TODO = 'VMS exit semantics not like POSIX exit semantics' if $^O eq 'VMS';
     is($?>>8, 99, "set_thread_exit_only(0)");
 }
-like($out, '1 finished and unjoined', "set_thread_exit_only(0)");
+like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)");
 
 
 run_perl(prog => 'use threads 1.92;' .

diff --git a/ext/B/t/concise.t b/ext/B/t/concise.t
index d43bd97..9a1d1db 100644 (file)
--- a/ext/B/t/concise.t
+++ b/ext/B/t/concise.t
@@ -457,14 +457,14 @@ $out =
  runperl(
   switches => ["-MO=Concise,-nobanner,foo"], prog=>'sub foo{}', stderr => 1
  );
-unlike $out, 'main::foo', '-nobanner';
+unlike $out, qr/main::foo/, '-nobanner';
 
 # glob
 $out =
  runperl(
   switches => ["-MO=Concise"], prog=>'glob(q{.})', stderr => 1
  );
-like $out, '\*<none>::', 'glob(q{.})';
+like $out, qr/\*<none>::/, 'glob(q{.})';
 
 # Test op_other in -debug
 $out = runperl(
@@ -486,7 +486,7 @@ EOF
 
 $end =~ s/\r\n/\n/g;
 
-like $out, $end, 'OP_AND has op_other';
+like $out, qr/$end/, 'OP_AND has op_other';
 
 # like(..) above doesn't fill in $1
 $out =~ $end;
@@ -502,6 +502,6 @@ EOF
 
 $end =~ s/<NEXT>/$next/;
 
-like $out, $end, 'OP_AND->op_other points correctly';
+like $out, qr/$end/, 'OP_AND->op_other points correctly';
 
 __END__

diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index 54f45ec..9ab633d 100644 (file)
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -279,7 +279,7 @@ for my $fn_type (0..2) { #   0:eval_pv   1:eval_sv   2:call_sv
            }
            else {
                is($warn_msg, undef, "$desc - __WARN__ not called");
-               unlike($@, 'pre-err', "$desc - \$@ modified");
+               unlike($@, qr/pre-err/, "$desc - \$@ modified");
            }
            like($@,
                (

diff --git a/lib/charnames.t b/lib/charnames.t
index 5629f3a..bd0c21e 100644 (file)
--- a/lib/charnames.t
+++ b/lib/charnames.t
@@ -41,7 +41,7 @@ use charnames ":full";
 1
 EOE
 
-    like($@, "above 0xFF", "Verify get warning for \\N{above ff} under 'use bytes' with :full");
+    like($@, qr/above 0xFF/, "Verify get warning for \\N{above ff} under 'use bytes' with :full");
     ok(! defined $res, "... and result is undefined");
 
     $res = eval <<'EOE';
@@ -49,7 +49,7 @@ use charnames 'cyrillic';
 "Here: \N{Be}!";
 1
 EOE
-    like($@, "CYRILLIC CAPITAL LETTER BE.*above 0xFF", "Verify get warning under 'use bytes' with explicit script");
+    like($@, qr/CYRILLIC CAPITAL LETTER BE.*above 0xFF/, "Verify get warning under 'use bytes' with explicit script");
     ok(! defined $res, "... and result is undefined");
 
     $res = eval <<'EOE';

diff --git a/lib/overload.t b/lib/overload.t
index 7efd992..d89ec2a 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -305,7 +305,7 @@ is($na, '_!_xx_!_');
 $na = 0;
 
 $na = eval { ~$aI };
-like($@, '');
+is($@, '');
 
 bless \$x, OscalarI;
 

diff --git a/lib/perl5db.t b/lib/perl5db.t
index bd5615a..0b77731 100644 (file)
--- a/lib/perl5db.t
+++ b/lib/perl5db.t
@@ -92,21 +92,21 @@ EOF
 {
     local $ENV{PERLDB_OPTS} = "ReadLine=0 NonStop=1";
     my $output = runperl(switches => [ '-d' ], stderr => 1, progfile => '../lib/perl5db/t/rt-66110');
-    like($output, "All tests successful.", "[perl #66110]");
+    like($output, qr/\bAll tests successful\.$/, "[perl #66110]");
 }
 # [ perl #116769] Frame=2
 {
     local $ENV{PERLDB_OPTS} = "frame=2 nonstop";
     my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
     is( $?, 0, '[perl #116769] frame=2 does not crash debugger, exit == 0' );
-    like( $output, 'success' , '[perl #116769] code is run' );
+    is( $output, 'success' , '[perl #116769] code is run' );
 }
 # [ perl #116771] autotrace
 {
     local $ENV{PERLDB_OPTS} = "autotrace nonstop";
     my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
     is( $?, 0, '[perl #116771] autotrace does not crash debugger, exit == 0' );
-    like( $output, 'success' , '[perl #116771] code is run' );
+    is( $output, 'success' , '[perl #116771] code is run' );
 }
 # [ perl #41461] Frame=2 noTTY
 {
@@ -114,7 +114,7 @@ EOF
     rc('');
     my $output = runperl( switches => [ '-d' ], prog => 'print q{success}' );
     is( $?, 0, '[perl #41461] frame=2 noTTY does not crash debugger, exit == 0' );
-    like( $output, 'success' , '[perl #41461] code is run' );
+    is( $output, 'success' , '[perl #41461] code is run' );
 }
 
 package DebugWrap;

diff --git a/t/io/utf8.t b/t/io/utf8.t
index acce07e..4f96dcc 100644 (file)
--- a/t/io/utf8.t
+++ b/t/io/utf8.t
@@ -223,7 +223,7 @@ is($failed, undef);
     print F chr(0x100);
     close(F);
 
-    like( $@, 'Wide character in print' );
+    like( $@, qr/Wide character in print/ );
 
     undef $@;
     open F, ">:utf8", $a_file;
@@ -257,7 +257,7 @@ is($failed, undef);
     print F chr(0x100);
     close(F);
 
-    like( $@, 'Wide character in print' );
+    like( $@, qr/Wide character in print/ );
 }
 
 {

diff --git a/t/op/attrproto.t b/t/op/attrproto.t
index 13ce107..8e69e33 100644 (file)
--- a/t/op/attrproto.t
+++ b/t/op/attrproto.t
@@ -21,11 +21,11 @@ $SIG{__WARN__} = sub { push @warnings, shift;};
 $ret = eval 'package Q; sub A(bar) : prototype(bad) : dummy1 {} prototype \&A;';
 is $ret, "bad", "Prototype is set to \"bad\"";
 is $attrs, "dummy1", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
-like shift @warnings, "Illegal character in prototype for Q::A : bar",
+like shift @warnings, qr/Illegal character in prototype for Q::A : bar/,
     "First warning is bad prototype - bar";
-like shift @warnings, "Illegal character in prototype for Q::A : bad",
+like shift @warnings, qr/Illegal character in prototype for Q::A : bad/,
     "Second warning is bad prototype - bad";
-like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A',
+like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::A/,
     "Third warning is Prototype overridden";
 is @warnings, 0, "No more warnings";
 
@@ -35,7 +35,7 @@ is @warnings, 0, "No more warnings";
     $ret = eval 'package Q; sub B(bar) : prototype(bad) dummy2 {4} prototype \&B;';
     is $ret, "bad", "Prototype is set to \"bad\"";
     is $attrs, "dummy2", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
-    like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B',
+    like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(bad\)\' in Q::B/,
         "First warning is Prototype overridden";
     is @warnings, 0, "No more warnings";
 }
@@ -44,13 +44,13 @@ is @warnings, 0, "No more warnings";
 $ret = eval 'package Q; sub B(ignored) : prototype(baz) : dummy3; prototype \&B;';
 is $ret, "bad", "Declaring with prototype(..) after definition doesn't change the prototype";
 is $attrs, "dummy3", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
-like shift @warnings, "Illegal character in prototype for Q::B : ignored",
+like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/,
     "Shifting off warning for the 'ignored' prototype";
-like shift @warnings, "Illegal character in prototype for Q::B : baz",
+like shift @warnings, qr/Illegal character in prototype for Q::B : baz/,
     "Attempting to redeclare triggers Illegal character warning";
-like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B',
+like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/,
     "Shifting off Prototype overridden warning";
-like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)',
+like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/,
     "Attempting to redeclare triggers prototype mismatch warning against first prototype";
 is @warnings, 0, "No more warnings";
 
@@ -59,22 +59,22 @@ $ret = eval 'package Q; sub B(ignored) : prototype(baz) dummy4 {5}; prototype \&
 is $ret, "baz", "Redefining with prototype(..) changes the prototype";
 is $attrs, "dummy4", "MODIFY_CODE_ATTRIBUTES called, but not for prototype(..)";
 is &Q::B, 5, "Function successfully redefined";
-like shift @warnings, "Illegal character in prototype for Q::B : ignored",
+like shift @warnings, qr/Illegal character in prototype for Q::B : ignored/,
     "Attempting to redeclare triggers Illegal character warning";
-like shift @warnings, "Illegal character in prototype for Q::B : baz",
+like shift @warnings, qr/Illegal character in prototype for Q::B : baz/,
     "Attempting to redeclare triggers Illegal character warning";
-like shift @warnings, 'Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B',
+like shift @warnings, qr/Prototype \'ignored\' overridden by attribute \'prototype\(baz\)\' in Q::B/,
     "Shifting off Prototype overridden warning";
-like shift @warnings, 'Prototype mismatch: sub Q::B \(bad\) vs \(baz\)',
+like shift @warnings, qr/Prototype mismatch: sub Q::B \(bad\) vs \(baz\)/,
     "Attempting to redeclare triggers prototype mismatch warning";
-like shift @warnings, 'Subroutine B redefined',
+like shift @warnings, qr/Subroutine B redefined/,
     "Only other warning is subroutine redefinition";
 is @warnings, 0, "No more warnings";
 
 # Multiple prototype declarations only takes the last one
 $ret = eval 'package Q; sub dummy6 : prototype($$) : prototype($$$) {}; prototype \&dummy6;';
 is $ret, "\$\$\$", "Last prototype declared wins";
-like shift @warnings, 'Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub',
+like shift @warnings, qr/Attribute prototype\(\$\$\$\) discards earlier prototype attribute in same sub/,
     "Multiple prototype declarations warns";
 is @warnings, 0, "No more warnings";
 
@@ -82,20 +82,20 @@ is @warnings, 0, "No more warnings";
 eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(new)";';
 $ret = prototype \&Q::B;
 is $ret, "new", "use attributes also sets the prototype";
-like shift @warnings, 'Prototype mismatch: sub Q::B \(baz\) vs \(new\)',
+like shift @warnings, qr/Prototype mismatch: sub Q::B \(baz\) vs \(new\)/,
     "Prototype mismatch warning triggered";
 is @warnings, 0, "No more warnings";
 
 eval 'package Q; use attributes __PACKAGE__, \&B, "prototype(\$\$~";';
 $ret = prototype \&Q::B;
 is $ret, "new", "A malformed prototype doesn't reset it";
-like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked";
+like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked";
 is @warnings, 0, "Malformed prototype isn't just a warning";
 
 eval 'use attributes __PACKAGE__, \&foo, "prototype($$\x{100}";';
 $ret = prototype \&Q::B;
 is $ret, "new", "A malformed prototype doesn't reset it";
-like $@, "Unterminated attribute parameter in attribute list", "Malformed prototype croaked";
+like $@, qr/Unterminated attribute parameter in attribute list/, "Malformed prototype croaked";
 is @warnings, 0, "Malformed prototype isn't just a warning";
 
 # Anonymous subs (really just making sure they don't crash, since the prototypes
@@ -108,11 +108,11 @@ is @warnings, 0, "Malformed prototype isn't just a warning";
     # the name to '?' before calling the proto check, despite setting
     # it to the real name very shortly after.
     # In short - if this test breaks, just change the test.
-    like shift @warnings, 'Illegal character in prototype for \? : bar',
+    like shift @warnings, qr/Illegal character in prototype for \? : bar/,
         "(anon) bar triggers illegal proto warnings";
-    like shift @warnings, "Illegal character in prototype for Q::__ANON__ : baz",
+    like shift @warnings, qr/Illegal character in prototype for Q::__ANON__ : baz/,
         "(anon) baz triggers illegal proto warnings";
-    like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__',
+    like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in Q::__ANON__/,
         "(anon) overridden warning triggered in anonymous sub";
     is @warnings, 0, "No more warnings";
 }
@@ -123,11 +123,11 @@ is @warnings, 0, "Malformed prototype isn't just a warning";
     no warnings "experimental::lexical_subs";
     $ret = eval 'my sub foo(bar) : prototype(baz) {}; prototype \&foo;';
     is $ret, "baz", "my sub foo honors the prototype attribute";
-    like shift @warnings, 'Illegal character in prototype for foo : bar',
+    like shift @warnings, qr/Illegal character in prototype for foo : bar/,
         "(lexical) bar triggers illegal proto warnings";
-    like shift @warnings, "Illegal character in prototype for foo : baz",
+    like shift @warnings, qr/Illegal character in prototype for foo : baz/,
         "(lexical) baz triggers illegal proto warnings";
-    like shift @warnings, 'Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo',
+    like shift @warnings, qr/Prototype \'bar\' overridden by attribute \'prototype\(baz\)\' in foo/,
         "(lexical) overridden warning triggered in anonymous sub";
     is @warnings, 0, "No more warnings";
 }

diff --git a/t/op/attrs.t b/t/op/attrs.t
index ec6768e..5e97691 100644 (file)
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -84,10 +84,10 @@ eval 'my A $x : plugh;';
 is $@, '';
 
 eval 'package Cat; my Cat @socks;';
-like $@, '';
+is $@, '';
 
 eval 'my Cat %nap;';
-like $@, '';
+is $@, '';
 
 sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
 sub X::foo { 1 }

diff --git a/t/op/bop.t b/t/op/bop.t
index fa08e98..09ae479 100644 (file)
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -353,7 +353,7 @@ is($a, "\xFF", "~ works with utf-8");
 # This would cause a segfault without malloc wrap
 SKIP: {
   skip "No malloc wrap checks" unless $Config::Config{usemallocwrap};
-  like( runperl(prog => 'eval q($#a>>=1); print 1'), "^1\n?" );
+  like( runperl(prog => 'eval q($#a>>=1); print 1'), qr/^1\n?/ );
 }
 
 # [perl #37616] Bug in &= (string) and/or m//

diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index addc4bb..aef3260 100644 (file)
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -882,13 +882,13 @@ $tests += 3;
 
 test_proto 'time';
 $tests += 2;
-like &mytime, '^\d+\z', '&time in scalar context';
-like join('-', &mytime), '^\d+\z', '&time in list context';
+like &mytime, qr/^\d+\z/, '&time in scalar context';
+like join('-', &mytime), qr/^\d+\z/, '&time in list context';
 
 test_proto 'times';
 $tests += 2;
-like &mytimes, '^[\d.]+\z', '&times in scalar context';
-like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
+like &mytimes, qr/^[\d.]+\z/, '&times in scalar context';
+like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/,
    '&times in list context';
 
 test_proto 'uc', 'aa', 'AA';

diff --git a/t/op/die.t b/t/op/die.t
index 8faef6a..c98b8ff 100644 (file)
--- a/t/op/die.t
+++ b/t/op/die.t
@@ -15,8 +15,8 @@ eval {
     die if $@;
 };
 
-like($@, '^Horribly', 'die with no args propagates $@');
-like($@, 'propagated', '... and appends a phrase');
+like($@, qr/^Horribly/, 'die with no args propagates $@');
+like($@, qr/\.{3}propagated at/, '... and appends a phrase');
 
 {
     local $SIG{__DIE__} = sub { is( $_[0], "[\000]\n", 'Embedded null passed to signal handler' )};

diff --git a/t/op/each.t b/t/op/each.t
index 4cfc03a..3fc9451 100644 (file)
--- a/t/op/each.t
+++ b/t/op/each.t
@@ -196,7 +196,7 @@ for my $k (qw(each keys values)) {
     isnt($v1,$v2,"if(%foo) didnt mess with each (value)");
     is($rest,3,"Got the expect number of keys");
     my $hsv=1 && %foo;
-    like($hsv,'/',"Got bucket stats from %foo in scalar assignment context");
+    like($hsv,qr[/],"Got bucket stats from %foo in scalar assignment context");
     my @arr=%foo&&%foo;
     is(@arr,10,"Got expected number of elements in list context");
 }    
@@ -215,7 +215,7 @@ for my $k (qw(each keys values)) {
     isnt($v1,$v2,"if(%foo) didnt mess with each (value)");
     is($rest,3,"Got the expect number of keys");
     my $hsv=1 && %foo;
-    like($hsv,'/',"Got bucket stats from %foo in scalar assignment context");
+    like($hsv,qr[/],"Got bucket stats from %foo in scalar assignment context");
     my @arr=%foo&&%foo;
     is(@arr,10,"Got expected number of elements in list context");
 }    

diff --git a/t/op/local.t b/t/op/local.t
index 03a8310..7ff21ab 100644 (file)
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -779,7 +779,7 @@ is($@, "");
 like( runperl(stderr => 1,
               prog => 'use constant foo => q(a);' .
                       'index(q(a), foo);' .
-                      'local *g=${::}{foo};print q(ok);'), "ok", "[perl #52740]");
+                      'local *g=${::}{foo};print q(ok);'), qr/^ok$/, "[perl #52740]");
 
 # related to perl #112966
 # Magic should not cause elements not to be deleted after scope unwinding

diff --git a/t/op/magic.t b/t/op/magic.t
index da3420c..015d41b 100644 (file)
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -429,8 +429,9 @@ EOP
     chomp(my $argv0 = $maybe_ps->("ps h $$"));
     chomp(my $prctl = $maybe_ps->("ps hc $$"));
 
-    like($argv0, $name, "Set process name through argv[0] ($argv0)");
-    like($prctl, substr($name, 0, 15), "Set process name through prctl() ($prctl)");
+    like($argv0, qr/$name/, "Set process name through argv[0] ($argv0)");
+    my $name_substr = substr($name, 0, 15);
+    like($prctl, qr/$name_substr/, "Set process name through prctl() ($prctl)");
   }
 }
 

diff --git a/t/op/method.t b/t/op/method.t
index 0f53c3a..648f003 100644 (file)
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -404,7 +404,7 @@ is $kalled, 1, 'calling a class method via a magic variable';
 
     *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD };
 
-    like(NulTest->${ \"nul\0test" }, "nul\0test", "AUTOLOAD is nul-clean");
+    like(NulTest->${ \"nul\0test" }, qr/nul\0test/, "AUTOLOAD is nul-clean");
 }
 
 

diff --git a/t/op/pack.t b/t/op/pack.t
index 99cb533..357f15b 100644 (file)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -1275,7 +1275,7 @@ SKIP: {
   # comma warning only once
   @warning = ();
   $x = pack( 'C(C,C)C,C', 65..71  );
-  like( scalar @warning, 1 );
+  cmp_ok( scalar(@warning), '==', 1 );
 
   # forbidden code in []
   eval { my $x = pack( 'A[@4]', 'XXXX' ); };

diff --git a/t/op/qr.t b/t/op/qr.t
index ac017eb..dc49f1e 100644 (file)
--- a/t/op/qr.t
+++ b/t/op/qr.t
@@ -89,12 +89,12 @@ is ref \$t2, 'main', 'regexp assignment is not maledictory';
     $_ = 1.1;
     $_ = ${qr//};
     is 0+$_, 0, 'double upgraded to regexp';
-    like $w, 'numeric', 'produces non-numeric warning';
+    like $w, qr/numeric/, 'produces non-numeric warning';
     undef $w;
     $_ = 1;
     $_ = ${qr//};
     is 0+$_, 0, 'int upgraded to regexp';
-    like $w, 'numeric', 'likewise produces non-numeric warning';
+    like $w, qr/numeric/, 'likewise produces non-numeric warning';
 }
 
 sub {

diff --git a/t/op/readline.t b/t/op/readline.t
index 1cfd78c..99ff63c 100644 (file)
--- a/t/op/readline.t
+++ b/t/op/readline.t
@@ -12,7 +12,7 @@ plan tests => 30;
 # TARG. Test that we respect SvREADONLY.
 use constant roref => \2;
 eval { for (roref) { $_ = <FH> } };
-like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+like($@, qr/Modification of a read-only value attempted/, '[perl #19566]');
 
 # [perl #21628]
 {

diff --git a/t/op/ref.t b/t/op/ref.t
index a6564ce..244dbd8 100644 (file)
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -617,7 +617,7 @@ is ( (sub {"bar"})[0]->(), "bar", 'code deref from list slice w/ ->' );
 {
     local $@;
     eval { ()[0]{foo} };
-    like ( "$@", "Can't use an undefined value as a HASH reference",
+    like ( "$@", qr/Can't use an undefined value as a HASH reference/,
            "deref of undef from list slice fails" );
 }
 

diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t
index 0a60f7b..28197c1 100644 (file)
--- a/t/op/sprintf2.t
+++ b/t/op/sprintf2.t
@@ -49,7 +49,7 @@ for my $i (1, 3, 5, 10) {
 # Used to mangle PL_sv_undef
 fresh_perl_like(
     'print sprintf "xxx%n\n"; print undef',
-    'Modification of a read-only value attempted at - line 1\.',
+    qr/Modification of a read-only value attempted at - line 1\./,
     { switches => [ '-w' ] },
     q(%n should not be able to modify read-only constants),
 );

diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t
index 75c5744..e39e36c 100644 (file)
--- a/t/re/pat_advanced.t
+++ b/t/re/pat_advanced.t
@@ -2191,7 +2191,7 @@ EOP
     {   # This was failing unless an explicit /d was added
         my $p = qr/[\xE0_]/i;
         utf8::upgrade($p);
-        like("\xC0", $p, "Verify \"\\xC0\" =~ /[\\xE0_]/i; pattern in utf8");
+        like("\xC0", qr/$p/, "Verify \"\\xC0\" =~ /[\\xE0_]/i; pattern in utf8");
     }
 
     ok "x" =~ /\A(?>(?:(?:)A|B|C?x))\z/,
@@ -2432,7 +2432,7 @@ EOP
     { # Regexp:Grammars was broken:
   # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2013-06/msg01290.html
         fresh_perl_like('use warnings; "abc" =~ qr{(?&foo){0}abc(?<foo>)}',
-                        'Quantifier unexpected on zero-length expression',
+                        qr/Quantifier unexpected on zero-length expression/,
                         {},
                         'No segfault on qr{(?&foo){0}abc(?<foo>)}');
     }

diff --git a/t/re/reg_fold.t b/t/re/reg_fold.t
index 5da8cd2..3e98866 100644 (file)
--- a/t/re/reg_fold.t
+++ b/t/re/reg_fold.t
@@ -155,7 +155,7 @@ for my $i (0 .. 255) {
 
 push @tests, qq[like chr(0x0430), qr/[=\x{0410}-\x{0411}]/i, 'Bug #71752 Unicode /i char in a range'];
 push @tests, qq[like 'a', qr/\\p{Upper}/i, "'a' =~ /\\\\p{Upper}/i"];
-push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); like $c, $p, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); $c =~ $p'];
+push @tests, q[my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); like $c, qr/$p/, 'Bug #78994: my $c = "\x{212A}"; my $p = qr/(?:^[K_]+$)/i; utf8::upgrade($p); $c =~ $p'];
 
 use charnames ":full";
 my $e_grave = latin1_to_native("\xE8");

diff --git a/t/test.pl b/t/test.pl
index 2b56623..342cfdc 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -420,6 +420,14 @@ sub unlike ($$@) { like_yn (1,@_) }; # 1 for un-
 
 sub like_yn ($$$@) {
     my ($flip, undef, $expected, $name, @mess) = @_;
+
+    # We just accept like(..., qr/.../), not like(..., '...'), and
+    # definitely not like(..., '/.../') like
+    # Test::Builder::maybe_regex() does.
+    unless (re::is_regexp($expected)) {
+       die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string";
+    }
+
     my $pass;
     $pass = $_[1] =~ /$expected/ if !$flip;
     $pass = $_[1] !~ /$expected/ if $flip;

diff --git a/t/uni/attrs.t b/t/uni/attrs.t
index 3ea2f68..be064b9 100644 (file)
--- a/t/uni/attrs.t
+++ b/t/uni/attrs.t
@@ -61,10 +61,10 @@ eval 'my A $x : plǖgh;';
 is $@, '';
 
 eval 'package Càt; my Càt @socks;';
-like $@, '';
+is $@, '';
 
 eval 'my Càt %nap;';
-like $@, '';
+is $@, '';
 
 sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
 sub X::ᕘ { 1 }

diff --git a/t/uni/readline.t b/t/uni/readline.t
index a83558e..f865bc0 100644 (file)
--- a/t/uni/readline.t
+++ b/t/uni/readline.t
@@ -15,7 +15,7 @@ use open qw( :utf8 :std );
 # TARG. Test that we respect SvREADONLY.
 use constant roref=>\2;
 eval { for (roref) { $_ = <Fʜ> } };
-like($@, 'Modification of a read-only value attempted', '[perl #19566]');
+like($@, qr/Modification of a read-only value attempted/, '[perl #19566]');
 
 # [perl #21628]
 {