eval { kill 0 * $unsafe };
SKIP: {
skip($^O) if $^O eq 'MSWin32' or $^O eq 'NetWare';
- like($@, '^Insecure');
+ like($@, qr/^Insecure/);
}
$x->close;
ok(!$?); # Calling the method worked
chop($unsafe = <$x>);
eval { kill 0 * $unsafe };
-unlike($@,'^Insecure');
+unlike($@,qr/^Insecure/);
$x->close;
TODO: {
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
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);' .
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;' .
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(
$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;
$end =~ s/<NEXT>/$next/;
-like $out, $end, 'OP_AND->op_other points correctly';
+like $out, qr/$end/, 'OP_AND->op_other points correctly';
__END__
}
else {
is($warn_msg, undef, "$desc - __WARN__ not called");
- unlike($@, 'pre-err', "$desc - \$@ modified");
+ unlike($@, qr/pre-err/, "$desc - \$@ modified");
}
like($@,
(
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';
"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';
$na = 0;
$na = eval { ~$aI };
-like($@, '');
+is($@, '');
bless \$x, OscalarI;
{
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
{
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;
print F chr(0x100);
close(F);
- like( $@, 'Wide character in print' );
+ like( $@, qr/Wide character in print/ );
undef $@;
open F, ">:utf8", $a_file;
print F chr(0x100);
close(F);
- like( $@, 'Wide character in print' );
+ like( $@, qr/Wide character in print/ );
}
{
$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";
$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";
}
$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";
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";
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
# 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";
}
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";
}
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 }
# 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//
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', '× in scalar context';
-like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
+like &mytimes, qr/^[\d.]+\z/, '× in scalar context';
+like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/,
'× in list context';
test_proto 'uc', 'aa', 'AA';
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' )};
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");
}
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");
}
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
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)");
}
}
*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");
}
# 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' ); };
$_ = 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 {
# 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]
{
{
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" );
}
# 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),
);
{ # 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/,
{ # 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>)}');
}
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");
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;
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 }
# 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]
{