1#!./perl 2# 3# This is a home for regular expression tests that don't fit into 4# the format supported by re/regexp.t. If you want to add a test 5# that does fit that format, add it to re/re_tests, not here. 6 7use strict; 8use warnings; 9use Config; 10use 5.010; 11 12 13sub run_tests; 14 15$| = 1; 16 17 18BEGIN { 19 chdir 't' if -d 't'; 20 @INC = ('../lib','.'); 21 require './test.pl'; 22} 23 24 25plan tests => 527; # Update this when adding/deleting tests. 26 27run_tests() unless caller; 28 29# test that runtime code without 'use re eval' is trapped 30 31sub norun { 32 like($@, qr/Eval-group not allowed at runtime/, @_); 33} 34 35# 36# Tests start here. 37# 38sub run_tests { 39 { 40 my $message = "Call code from qr //"; 41 local $_ = 'var="foo"'; 42 $a = qr/(?{++$b})/; 43 $b = 7; 44 ok(/$a$a/ && $b eq '9', $message); 45 46 my $c="$a"; 47 ok(/$a$a/ && $b eq '11', $message); 48 49 undef $@; 50 eval {/$c/}; 51 norun("$message norun 1"); 52 53 54 { 55 eval {/$a$c$a/}; 56 norun("$message norun 2"); 57 use re "eval"; 58 /$a$c$a/; 59 is($b, '14', $message); 60 } 61 62 our $lex_a = 43; 63 our $lex_b = 17; 64 our $lex_c = 27; 65 my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); 66 67 is($lex_res, 1, $message); 68 is($lex_a, 44, $message); 69 is($lex_c, 43, $message); 70 71 undef $@; 72 my $d = '(?{1})'; 73 my $match = eval { /$a$c$a$d/ }; 74 ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message); 75 is($b, '14', $message); 76 77 $lex_a = 2; 78 $lex_a = 43; 79 $lex_b = 17; 80 $lex_c = 27; 81 $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); 82 83 is($lex_res, 1, $message); 84 is($lex_a, 44, $message); 85 is($lex_c, 43, $message); 86 87 } 88 89 { 90 our $a = bless qr /foo/ => 'Foo'; 91 ok 'goodfood' =~ $a, "Reblessed qr // matches"; 92 is($a, '(?^:foo)', "Reblessed qr // stringifies"); 93 my $x = "\x{3fe}"; 94 my $z = my $y = "\317\276"; # Byte representation of $x 95 $a = qr /$x/; 96 ok $x =~ $a, "UTF-8 interpolation in qr //"; 97 ok "a$a" =~ $x, "Stringified qr // preserves UTF-8"; 98 ok "a$x" =~ /^a$a\z/, "Interpolated qr // preserves UTF-8"; 99 ok "a$x" =~ /^a(??{$a})\z/, 100 "Postponed interpolation of qr // preserves UTF-8"; 101 102 103 is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776"); 104 105 { 106 ok "$x$x" =~ /^$x(??{$x})\z/, 107 "Postponed UTF-8 string in UTF-8 re matches UTF-8"; 108 ok "$y$x" =~ /^$y(??{$x})\z/, 109 "Postponed UTF-8 string in non-UTF-8 re matches UTF-8"; 110 ok "$y$x" !~ /^$y(??{$y})\z/, 111 "Postponed non-UTF-8 string in non-UTF-8 re doesn't match UTF-8"; 112 ok "$x$x" !~ /^$x(??{$y})\z/, 113 "Postponed non-UTF-8 string in UTF-8 re doesn't match UTF-8"; 114 ok "$y$y" =~ /^$y(??{$y})\z/, 115 "Postponed non-UTF-8 string in non-UTF-8 re matches non-UTF8"; 116 ok "$x$y" =~ /^$x(??{$y})\z/, 117 "Postponed non-UTF-8 string in UTF-8 re matches non-UTF8"; 118 119 $y = $z; # Reset $y after upgrade. 120 ok "$x$y" !~ /^$x(??{$x})\z/, 121 "Postponed UTF-8 string in UTF-8 re doesn't match non-UTF-8"; 122 ok "$y$y" !~ /^$y(??{$x})\z/, 123 "Postponed UTF-8 string in non-UTF-8 re doesn't match non-UTF-8"; 124 } 125 } 126 127 128 { 129 # Test if $^N and $+ work in (?{}) 130 our @ctl_n = (); 131 our @plus = (); 132 our $nested_tags; 133 $nested_tags = qr{ 134 < 135 ((\w)+) 136 (?{ 137 push @ctl_n, (defined $^N ? $^N : "undef"); 138 push @plus, (defined $+ ? $+ : "undef"); 139 }) 140 > 141 (??{$nested_tags})* 142 </\s* \w+ \s*> 143 }x; 144 145 146 my $c = 0; 147 for my $test ( 148 # Test structure: 149 # [ Expected result, Regex, Expected value(s) of $^N, Expected value(s) of $+ ] 150 [ 1, qr#^$nested_tags$#, "bla blubb bla", "a b a" ], 151 [ 1, qr#^($nested_tags)$#, "bla blubb <bla><blubb></blubb></bla>", "a b a" ], 152 [ 1, qr#^(|)$nested_tags$#, "bla blubb bla", "a b a" ], 153 [ 1, qr#^(?:|)$nested_tags$#, "bla blubb bla", "a b a" ], 154 [ 1, qr#^<(bl|bla)>$nested_tags<(/\1)>$#, "blubb /bla", "b /bla" ], 155 [ 1, qr#(??{"(|)"})$nested_tags$#, "bla blubb bla", "a b a" ], 156 [ 1, qr#^(??{"(bla|)"})$nested_tags$#, "bla blubb bla", "a b a" ], 157 [ 1, qr#^(??{"(|)"})(??{$nested_tags})$#, "bla blubb undef", "a b undef" ], 158 [ 1, qr#^(??{"(?:|)"})$nested_tags$#, "bla blubb bla", "a b a" ], 159 [ 1, qr#^((??{"(?:bla|)"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], 160 [ 1, qr#^((??{"(?!)?"}))((??{$nested_tags}))$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], 161 [ 1, qr#^((??{"(?:|<(/?bla)>)"}))((??{$nested_tags}))\1$#, "bla blubb <bla><blubb></blubb></bla>", "a b <bla><blubb></blubb></bla>" ], 162 [ 0, qr#^((??{"(?!)"}))?((??{$nested_tags}))(?!)$#, "bla blubb undef", "a b undef" ], 163 164 ) { #"#silence vim highlighting 165 $c++; 166 @ctl_n = (); 167 @plus = (); 168 my $match = (("<bla><blubb></blubb></bla>" =~ $test->[1]) ? 1 : 0); 169 push @ctl_n, (defined $^N ? $^N : "undef"); 170 push @plus, (defined $+ ? $+ : "undef"); 171 ok($test->[0] == $match, "match $c"); 172 if ($test->[0] != $match) { 173 # unset @ctl_n and @plus 174 @ctl_n = @plus = (); 175 } 176 is("@ctl_n", $test->[2], "ctl_n $c"); 177 is("@plus", $test->[3], "plus $c"); 178 } 179 } 180 181 { 182 our $f; 183 local $f; 184 $f = sub { 185 defined $_[0] ? $_[0] : "undef"; 186 }; 187 188 like("123", qr/^(\d)(((??{1 + $^N})))+$/, 'Bug 56194'); 189 190 our @ctl_n; 191 our @plus; 192 193 my $re = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})#; 194 my $re2 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))*(?{$^N})(|a(b)c|def)(??{"$^R"})#; 195 my $re3 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})(|a(b)c|def)(??{"$^R"})#; 196 our $re5; 197 local $re5 = qr#(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})){2}(?{$^N})#; 198 my $re6 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; 199 my $re7 = qr#(??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1})#; 200 my $re8 = qr/(\d+)/; 201 my $c = 0; 202 for my $test ( 203 # Test structure: 204 # [ 205 # String to match 206 # Regex too match 207 # Expected values of $^N 208 # Expected values of $+ 209 # Expected values of $1, $2, $3, $4 and $5 210 # ] 211 [ 212 "1233", 213 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(??{$^N})$#, 214 "1 2 3 3", 215 "1 2 3 3", 216 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 217 ], 218 [ 219 "1233", 220 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$+})$#, 221 "1 2 3 3", 222 "1 2 3 3", 223 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 224 ], 225 [ 226 "1233", 227 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$+})$#, 228 "1 2 3 3", 229 "1 2 3 3", 230 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 231 ], 232 [ 233 "1233", 234 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(abc|def|)?(??{$^N})$#, 235 "1 2 3 3", 236 "1 2 3 3", 237 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 238 ], 239 [ 240 "1233", 241 qr#^(1)((??{ push @ctl_n, $f->($^N); push @plus, $f->($+); $^N + 1}))+(|abc|def)?(??{$^N})$#, 242 "1 2 3 3", 243 "1 2 3 3", 244 "\$1 = 1, \$2 = 3, \$3 = undef, \$4 = undef, \$5 = undef", 245 ], 246 [ 247 "123abc3", 248 qr#^($re)(|a(b)c|def)(??{$^R})$#, 249 "1 2 3 abc", 250 "1 2 3 b", 251 "\$1 = 123, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", 252 ], 253 [ 254 "123abc3", 255 qr#^($re2)$#, 256 "1 2 3 123abc3", 257 "1 2 3 b", 258 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", 259 ], 260 [ 261 "123abc3", 262 qr#^($re3)$#, 263 "1 2 123abc3", 264 "1 2 b", 265 "\$1 = 123abc3, \$2 = 1, \$3 = 3, \$4 = abc, \$5 = b", 266 ], 267 [ 268 "123abc3", 269 qr#^(??{$re5})(|abc|def)(??{"$^R"})$#, 270 "1 2 abc", 271 "1 2 abc", 272 "\$1 = abc, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef", 273 ], 274 [ 275 "123abc3", 276 qr#^(??{$re5})(|a(b)c|def)(??{"$^R"})$#, 277 "1 2 abc", 278 "1 2 b", 279 "\$1 = abc, \$2 = b, \$3 = undef, \$4 = undef, \$5 = undef", 280 ], 281 [ 282 "1234", 283 qr#^((\d+)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1}))((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})))$#, 284 "1234 123 12 1 2 3 1234", 285 "1234 123 12 1 2 3 4", 286 "\$1 = 1234, \$2 = 1, \$3 = 2, \$4 = 3, \$5 = 4", 287 ], 288 [ 289 "1234556", 290 qr#^(\d+)($re6)($re6)($re6)$re6(($re6)$re6)$#, 291 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 56", 292 "1234556 123455 12345 1234 123 12 1 2 3 4 4 5 5", 293 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 56", 294 ], 295 [ 296 "12345562", 297 qr#^((??{$re8}))($re7)($re7)($re7)$re7($re7)($re7(\2))$#, 298 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 62", 299 "12345562 1234556 123455 12345 1234 123 12 1 2 3 4 4 5 2", 300 "\$1 = 1, \$2 = 2, \$3 = 3, \$4 = 4, \$5 = 5", 301 ], 302 ) { 303 $c++; 304 @ctl_n = (); 305 @plus = (); 306 undef $^R; 307 my $match = $test->[0] =~ $test->[1]; 308 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5)); 309 push @ctl_n, $f->($^N); 310 push @plus, $f->($+); 311 ok($match, "match $c; Bug 56194"); 312 if (not $match) { 313 # unset $str, @ctl_n and @plus 314 $str = ""; 315 @ctl_n = @plus = (); 316 } 317 is("@ctl_n", $test->[2], "ctl_n $c; Bug 56194"); 318 is("@plus", $test->[3], "plus $c; Bug 56194"); 319 is($str, $test->[4], "str $c; Bug 56194"); 320 } 321 322 { 323 @ctl_n = (); 324 @plus = (); 325 326 our $re4; 327 local $re4 = qr#(1)((??{push @ctl_n, $f->($^N); push @plus, $f->($+);$^N + 1})){2}(?{$^N})(|abc|def)(??{"$^R"})#; 328 undef $^R; 329 my $match = "123abc3" =~ m/^(??{$re4})$/; 330 my $str = join(", ", '$1 = '.$f->($1), '$2 = '.$f->($2), '$3 = '.$f->($3), '$4 = '.$f->($4),'$5 = '.$f->($5),'$^R = '.$f->($^R)); 331 push @ctl_n, $f->($^N); 332 push @plus, $f->($+); 333 ok($match, 'Bug 56194'); 334 if (not $match) { 335 # unset $str 336 @ctl_n = (); 337 @plus = (); 338 $str = ""; 339 } 340 is("@ctl_n", "1 2 undef", 'Bug 56194'); 341 is("@plus", "1 2 undef", 'Bug 56194'); 342 is($str, 343 "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = 3", 344 'Bug 56194 ($^R tweaked by 121070)'); 345 } 346 { 347 undef $^R; 348 "abcd"=~/(?<Char>.)(?&Char)(?{ 42 })/; 349 is("$^R", 42, 'Bug 121070 - use of (?&Char) should not clobber $^R'); 350 "abcd"=~/(?<Char>.)(?&Char)(?{ 42 })(?{ 43 })/; 351 is("$^R", 43, 'related to 121070 - use of (?&Char) should not clobber $^R'); 352 } 353 } 354 355 { 356 # re evals within \U, \Q etc shouldn't be seen by the lexer 357 local our $a = "i"; 358 local our $B = "J"; 359 ok('(?{1})' =~ /^\Q(?{1})\E$/, '\Q(?{1})\E'); 360 ok('(?{1})' =~ /^\Q(?{\E1\}\)$/, '\Q(?{\E1\}\)'); 361 eval {/^\U(??{"$a\Ea"})$/ }; norun('^\U(??{"$a\Ea"})$ norun'); 362 eval {/^\L(??{"$B\Ea"})$/ }; norun('^\L(??{"$B\Ea"})$ norun'); 363 use re 'eval'; 364 ok('Ia' =~ /^\U(??{"$a\Ea"})$/, '^\U(??{"$a\Ea"})$'); 365 ok('ja' =~ /^\L(??{"$B\Ea"})$/, '^\L(??{"$B\Ea"})$'); 366 } 367 368 { 369 # Comprehensive (hopefully) tests of closure behaviour: 370 # i.e. when do (?{}) blocks get (re)compiled, and what instances 371 # of lexical vars do they close over? 372 373 # if the pattern string gets utf8 upgraded while concatenating, 374 # make sure a literal code block is still detected (by still 375 # compiling in the absence of use re 'eval') 376 377 { 378 my $s1 = "\x{80}"; 379 my $s2 = "\x{100}"; 380 ok("\x{80}\x{100}" =~ /^$s1(?{1})$s2$/, "utf8 upgrade"); 381 } 382 383 my ($cr1, $cr2, $cr3, $cr4); 384 385 for my $x (qw(a b c)) { 386 my $bc = ($x ne 'a'); 387 my $c80 = chr(0x80); 388 389 # the most basic: literal code should be in same scope 390 # as the parent 391 392 ok("A$x" =~ /^A(??{$x})$/, "[$x] literal code"); 393 ok("\x{100}$x" =~ /^\x{100}(??{$x})$/, "[$x] literal code UTF8"); 394 395 # the "don't recompile if pattern unchanged" mechanism 396 # shouldn't apply to code blocks - recompile every time 397 # to pick up new instances of variables 398 399 my $code1 = 'B(??{$x})'; 400 my $code1u = $c80 . "\x{100}" . '(??{$x})'; 401 402 eval {/^A$code1$/}; 403 norun("[$x] unvarying runtime code AA norun"); 404 eval {/^A$code1u$/}; 405 norun("[$x] unvarying runtime code AU norun"); 406 eval {/^$c80\x{100}$code1$/}; 407 norun("[$x] unvarying runtime code UA norun"); 408 eval {/^$c80\x{101}$code1u$/}; 409 norun("[$x] unvarying runtime code UU norun"); 410 411 { 412 use re 'eval'; 413 ok("AB$x" =~ /^A$code1$/, "[$x] unvarying runtime code AA"); 414 ok("A$c80\x{100}$x" =~ /^A$code1u$/, 415 "[$x] unvarying runtime code AU"); 416 ok("$c80\x{100}B$x" =~ /^$c80\x{100}$code1$/, 417 "[$x] unvarying runtime code UA"); 418 ok("$c80\x{101}$c80\x{100}$x" =~ /^$c80\x{101}$code1u$/, 419 "[$x] unvarying runtime code UU"); 420 } 421 422 # mixed literal and run-time code blocks 423 424 my $code2 = 'B(??{$x})'; 425 my $code2u = $c80 . "\x{100}" . '(??{$x})'; 426 427 eval {/^A(??{$x})-$code2$/}; 428 norun("[$x] literal+runtime AA norun"); 429 eval {/^A(??{$x})-$code2u$/}; 430 norun("[$x] literal+runtime AU norun"); 431 eval {/^$c80\x{100}(??{$x})-$code2$/}; 432 norun("[$x] literal+runtime UA norun"); 433 eval {/^$c80\x{101}(??{$x})-$code2u$/}; 434 norun("[$x] literal+runtime UU norun"); 435 436 { 437 use re 'eval'; 438 ok("A$x-B$x" =~ /^A(??{$x})-$code2$/, 439 "[$x] literal+runtime AA"); 440 ok("A$x-$c80\x{100}$x" =~ /^A(??{$x})-$code2u$/, 441 "[$x] literal+runtime AU"); 442 ok("$c80\x{100}$x-B$x" =~ /^$c80\x{100}(??{$x})-$code2$/, 443 "[$x] literal+runtime UA"); 444 ok("$c80\x{101}$x-$c80\x{100}$x" 445 =~ /^$c80\x{101}(??{$x})-$code2u$/, 446 "[$x] literal+runtime UU"); 447 } 448 449 # literal qr code only created once, naked 450 451 $cr1 //= qr/^A(??{$x})$/; 452 ok("Aa" =~ $cr1, "[$x] literal qr once naked"); 453 454 # literal qr code only created once, embedded with text 455 456 $cr2 //= qr/B(??{$x})$/; 457 ok("ABa" =~ /^A$cr2/, "[$x] literal qr once embedded text"); 458 459 # literal qr code only created once, embedded with text + lit code 460 461 $cr3 //= qr/C(??{$x})$/; 462 ok("A$x-BCa" =~ /^A(??{$x})-B$cr3/, 463 "[$x] literal qr once embedded text + lit code"); 464 465 # literal qr code only created once, embedded with text + run code 466 467 $cr4 //= qr/C(??{$x})$/; 468 my $code3 = 'A(??{$x})'; 469 470 eval {/^$code3-B$cr4/}; 471 norun("[$x] literal qr once embedded text + run code norun"); 472 { 473 use re 'eval'; 474 ok("A$x-BCa" =~ /^$code3-B$cr4/, 475 "[$x] literal qr once embedded text + run code"); 476 } 477 478 # literal qr code, naked 479 480 my $r1 = qr/^A(??{$x})$/; 481 ok("A$x" =~ $r1, "[$x] literal qr naked"); 482 483 # literal qr code, embedded with text 484 485 my $r2 = qr/B(??{$x})$/; 486 ok("AB$x" =~ /^A$r2/, "[$x] literal qr embedded text"); 487 488 # literal qr code, embedded with text + lit code 489 490 my $r3 = qr/C(??{$x})$/; 491 ok("A$x-BC$x" =~ /^A(??{$x})-B$r3/, 492 "[$x] literal qr embedded text + lit code"); 493 494 # literal qr code, embedded with text + run code 495 496 my $r4 = qr/C(??{$x})$/; 497 my $code4 = '(??{$x})'; 498 499 eval {/^A$code4-B$r4/}; 500 norun("[$x] literal qr embedded text + run code"); 501 { 502 use re 'eval'; 503 ok("A$x-BC$x" =~ /^A$code4-B$r4/, 504 "[$x] literal qr embedded text + run code"); 505 } 506 507 # nested qr in different scopes 508 509 my $code5 = '(??{$x})'; 510 my $r5 = qr/C(??{$x})/; 511 512 my $r6; 513 eval {qr/$code5-C(??{$x})/}; norun("r6 norun"); 514 { 515 use re 'eval'; 516 $r6 = qr/$code5-C(??{$x})/; 517 } 518 519 my @rr5; 520 my @rr6; 521 522 for my $y (qw(d e f)) { 523 524 my $rr5 = qr/^A(??{"$x$y"})-$r5/; 525 push @rr5, $rr5; 526 ok("A$x$y-C$x" =~ $rr5, 527 "[$x-$y] literal qr + r5"); 528 529 my $rr6 = qr/^A(??{"$x$y"})-$r6/; 530 push @rr6, $rr6; 531 ok("A$x$y-$x-C$x" =~ $rr6, 532 "[$x-$y] literal qr + r6"); 533 } 534 535 for my $i (0,1,2) { 536 my $y = 'Y'; 537 my $yy = (qw(d e f))[$i]; 538 my $rr5 = $rr5[$i]; 539 ok("A$x$yy-C$x" =~ $rr5, "[$x-$yy] literal qr + r5, outside"); 540 ok("A$x$yy-C$x-D$x" =~ /$rr5-D(??{$x})$/, 541 "[$x-$yy] literal qr + r5 + lit, outside"); 542 543 544 my $rr6 = $rr6[$i]; 545 push @rr6, $rr6; 546 ok("A$x$yy-$x-C$x" =~ $rr6, 547 "[$x-$yy] literal qr + r6, outside"); 548 ok("A$x$yy-$x-C$x-D$x" =~ /$rr6-D(??{$x})/, 549 "[$x-$yy] literal qr + r6 +lit, outside"); 550 } 551 } 552 553 # recursive subs should get lexical from the correct pad depth 554 555 sub recurse { 556 my ($n) = @_; 557 return if $n > 2; 558 ok("A$n" =~ /^A(??{$n})$/, "recurse($n)"); 559 recurse($n+1); 560 } 561 recurse(0); 562 563 # for qr// containing run-time elements but with a compile-time 564 # code block, make sure the run-time bits are executed in the same 565 # pad they were compiled in 566 { 567 my $a = 'a'; # ensure outer and inner pads don't align 568 my $b = 'b'; 569 my $c = 'c'; 570 my $d = 'd'; 571 my $r = qr/^$b(??{$c})$d$/; 572 ok("bcd" =~ $r, "qr with run-time elements and code block"); 573 } 574 575 # check that cascaded embedded regexes all see their own lexical 576 # environment 577 578 { 579 my ($r1, $r2, $r3, $r4); 580 my ($x1, $x2, $x3, $x4) = (5,6,7,8); 581 { my $x1 = 1; $r1 = qr/A(??{$x1})/; } 582 { my $x2 = 2; $r2 = qr/$r1(??{$x2})/; } 583 { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; } 584 { my $x4 = 4; $r4 = qr/$r3(??{$x4})/; } 585 ok("A1234" =~ /^$r4$/, "cascaded qr"); 586 } 587 588 # and again, but in a loop, with no external references 589 # being maintained to the qr's 590 591 { 592 my $r = 'A'; 593 for my $x (1..4) { 594 $r = qr/$r(??{$x})/; 595 } 596 my $x = 5; 597 ok("A1234" =~ /^$r$/, "cascaded qr loop"); 598 } 599 600 601 # and again, but compiling the qrs in an eval so there 602 # aren't even refs to the qrs from any ops 603 604 { 605 my $r = 'A'; 606 for my $x (1..4) { 607 $r = eval q[ qr/$r(??{$x})/; ]; 608 } 609 my $x = 5; 610 ok("A1234" =~ /^$r$/, "cascaded qr loop"); 611 } 612 613 # have qrs with either literal code blocks or only embedded 614 # code blocks, but not both 615 616 { 617 my ($r1, $r2, $r3, $r4); 618 my ($x1, $x3) = (7,8); 619 { my $x1 = 1; $r1 = qr/A(??{$x1})/; } 620 { $r2 = qr/${r1}2/; } 621 { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; } 622 { $r4 = qr/${r3}4/; } 623 ok("A1234" =~ /^$r4$/, "cascaded qr mix 1"); 624 ok("A12345" =~ /^${r4}5$/, "cascaded qr mix 2"); 625 ok("A1234" =~ qr/^$r4$/ , "cascaded qr mix 3"); 626 ok("A12345" =~ qr/^${r4}5$/, "cascaded qr mix 4"); 627 } 628 629 # and make sure things are freed at the right time 630 631 SKIP: { 632 if ($Config{mad}) { 633 skip "MAD doesn't free eval CVs", 3; 634 } 635 636 { 637 sub Foo99::DESTROY { $Foo99::d++ } 638 $Foo99::d = 0; 639 my $r1; 640 { 641 my $x = bless [1], 'Foo99'; 642 $r1 = eval 'qr/(??{$x->[0]})/'; 643 } 644 my $r2 = eval 'qr/a$r1/'; 645 my $x = 2; 646 ok(eval '"a1" =~ qr/^$r2$/', "match while in scope"); 647 # make sure PL_reg_curpm isn't holding on to anything 648 "a" =~ /a(?{1})/; 649 is($Foo99::d, 0, "before scope exit"); 650 } 651 ::is($Foo99::d, 1, "after scope exit"); 652 } 653 654 # forward declared subs should Do The Right Thing with any anon CVs 655 # within them (i.e. pad_fixup_inner_anons() should work) 656 657 sub forward; 658 sub forward { 659 my $x = "a"; 660 my $A = "A"; 661 ok("Aa" =~ qr/^A(??{$x})$/, "forward qr compiletime"); 662 ok("Aa" =~ qr/^$A(??{$x})$/, "forward qr runtime"); 663 } 664 forward; 665 } 666 667 # test that run-time embedded code, when re-fed into toker, 668 # does all the right escapes 669 670 { 671 my $enc = eval 'use Encode; find_encoding("ascii")'; 672 673 my $x = 0; 674 my $y = 'bad'; 675 676 # note that most of the strings below are single-quoted, and the 677 # things within them, like '$y', *aren't* intended to interpolate 678 679 my $s1 = 680 'a\\$y(?# (??{BEGIN{$x=1} "X1"})b(?# \Ux2\E)c\'d\\\\e\\\\Uf\\\\E'; 681 682 ok(q{a$ybc'd\e\Uf\E} =~ /^$s1$/, "reparse"); 683 is($x, 0, "reparse no BEGIN"); 684 685 my $s2 = 'g\\$y# (??{{BEGIN{$x=2} "X3"}) \Ux3\E' . "\nh"; 686 687 ok(q{a$ybc'd\\e\\Uf\\Eg$yh} =~ /^$s1$s2$/x, "reparse /x"); 688 is($x, 0, "reparse /x no BEGIN"); 689 690 my $b = '\\'; 691 my $q = '\''; 692 693 # non-ascii in string as "<0xNNN>" 694 sub esc_str { 695 my $s = shift; 696 $s =~ s{(.)}{ 697 my $c = ord($1); 698 ($c< 32 || $c > 127) ? sprintf("<0x%x>", $c) : $1; 699 }ge; 700 $s; 701 } 702 sub fmt { sprintf "hairy backslashes %s [%s] =~ /^%s/", 703 $_[0], esc_str($_[1]), esc_str($_[2]); 704 } 705 706 707 for my $u ( 708 [ '', '', 'blank ' ], 709 [ "\x{100}", '\x{100}', 'single' ], 710 [ "\x{100}", "\x{100}", 'double' ]) 711 { 712 for my $pair ( 713 [ "$b", "$b$b" ], 714 [ "$q", "$q" ], 715 [ "$b$q", "$b$b$b$q" ], 716 [ "$b$b$q", "$b$b$b$b$q" ], 717 [ "$b$b$b$q", "$b$b$b$b$b$b$q" ], 718 [ "$b$b$b$b$q","$b$b$b$b$b$b$b$b$q" ], 719 ) { 720 my ($s, $r) = @$pair; 721 $s = "9$s"; 722 my $ss = "$u->[0]$s"; 723 724 my $c = '9' . $r; 725 my $cc = "$u->[1]$c"; 726 727 ok($ss =~ /^$cc/, fmt("plain $u->[2]", $ss, $cc)); 728 729 no strict; 730 my $chr41 = "\x41"; 731 $ss = "$u->[0]\t${q}$chr41${b}x42$s"; 732 $nine = $nine = "bad"; 733 for my $use_qr ('', 'qr') { 734 $c = qq[(??{my \$z='{';] 735 . qq[$use_qr"$b${b}t$b$q$b${b}x41$b$b$b${b}x42"] 736 . qq[. \$nine})]; 737 # (??{ qr/str/ }) goes through one less interpolation 738 # stage than (??{ qq/str/ }) 739 $c =~ s{\\\\}{\\}g if ($use_qr eq 'qr'); 740 $c .= $r; 741 $cc = "$u->[1]$c"; 742 my $nine = 9; 743 744 eval {/^$cc/}; norun(fmt("code norun $u->[2]", $ss, $cc)); 745 { 746 use re 'eval'; 747 ok($ss =~ /^$cc/, fmt("code $u->[2]", $ss, $cc)); 748 } 749 750 { 751 # Poor man's "use encoding 'ascii'". 752 # This causes a different code path in S_const_str() 753 # to be used 754 local ${^ENCODING} = $enc; 755 use re 'eval'; 756 ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc)); 757 } 758 } 759 } 760 } 761 762 my $code1u = "(??{qw(\x{100})})"; 763 eval {/^$code1u$/}; norun("reparse embeded unicode norun"); 764 { 765 use re 'eval'; 766 ok("\x{100}" =~ /^$code1u$/, "reparse embeded unicode"); 767 } 768 } 769 770 # a non-pattern literal won't get code blocks parsed at compile time; 771 # but they must get parsed later on if 'use re eval' is in scope 772 # also check that unbalanced {}'s are parsed ok 773 774 { 775 eval q["a{" =~ '^(??{"a{"})$']; 776 norun("non-pattern literal code norun"); 777 eval {/^${\'(??{"a{"})'}$/}; 778 norun("runtime code with unbalanced {} norun"); 779 780 use re 'eval'; 781 ok("a{" =~ '^a(??{"{"})$', "non-pattern literal code"); 782 ok("a{" =~ /^a${\'(??{"{"})'}$/, "runtime code with unbalanced {}"); 783 } 784 785 # make sure warnings come from the right place 786 787 { 788 use warnings; 789 my ($s, $t, $w); 790 local $SIG{__WARN__} = sub { $w .= "@_" }; 791 792 $w = ''; $s = 's'; 793 my $r = qr/(?{$t=$s+1})/; 794 "a" =~ /a$r/; 795 like($w, qr/pat_re_eval/, "warning main file"); 796 797 # do it in an eval to get predictable line numbers 798 eval q[ 799 800 $r = qr/(?{$t=$s+1})/; 801 ]; 802 $w = ''; $s = 's'; 803 "a" =~ /a$r/; 804 like($w, qr/ at \(eval \d+\) line 3/, "warning eval A"); 805 806 $w = ''; $s = 's'; 807 eval q[ 808 use re 'eval'; 809 my $c = '(?{$t=$s+1})'; 810 "a" =~ /a$c/; 811 1; 812 ]; 813 like($w, qr/ at \(eval \d+\) line 1/, "warning eval B"); 814 } 815 816 # jumbo test for: 817 # * recursion; 818 # * mixing all the different types of blocks (literal, qr/literal/, 819 # runtime); 820 # * backtracking (the Z+ alternation ensures CURLYX and full 821 # scope popping on backtracking) 822 823 { 824 sub recurse2 { 825 my ($depth)= @_; 826 return unless $depth; 827 my $s1 = '3-LMN'; 828 my $r1 = qr/(??{"$s1-$depth"})/; 829 830 my $s2 = '4-PQR'; 831 my $c1 = '(??{"$s2-$depth"})'; 832 use re 'eval'; 833 ok( "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>" 834 . "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>" 835 =~ 836 /^<(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1> 837 <(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>$/x, 838 "recurse2($depth)"); 839 recurse2($depth-1); 840 } 841 recurse2(5); 842 } 843 844 # nested (??{}) called from various levels of a recursive function 845 846 { 847 sub recurse3 { 848 my ($n) = @_; 849 return if $n > 3; 850 ok("A$n" =~ m{^A(??{ "0123" =~ /((??{$n}))/; $1 })$}, 851 "recurse3($n)"); 852 ok("A$n" !~ m{^A(??{ "0123" =~ /((??{$n}))/; "X" })$}, 853 "recurse3($n) nomatch"); 854 recurse3($n+1); 855 } 856 recurse3(0); 857 } 858 859 # nested (??{}) being invoked recursively via a function 860 861 { 862 my $s = ''; 863 our $recurse4; 864 my @alpha = qw(A B C D E); 865 $recurse4 = sub { 866 my ($n) = @_; 867 $s .= "(n=$n:"; 868 if ($n < 4) { 869 my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~ 870 m{^([A-Z]) 871 (??{ 872 $s .= "1=$1:"; 873 "$n-0123" =~ m{^(\d)-(((??{$recurse4->($n+1)})))}; 874 $s .= "i1=$1:<=[$2]"; 875 $3; # NB - not stringified 876 }) 877 $ 878 }x; 879 $s .= "1a=$1:"; 880 $s .= $m ? 'M' : '!M'; 881 } 882 my $ret = '.*?' . ($n-1); 883 $s .= "<=[$ret])"; 884 return $ret; 885 }; 886 $recurse4->(0); 887 my $exp = '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])' 888 . 'i1=3:<=[0123]1a=D:M<=[.*?2])i1=2:<=[012]1a=C:M<=[.*?1])' 889 . 'i1=1:<=[01]1a=B:M<=[.*?0])i1=0:<=[0]1a=A:M<=[.*?-1])'; 890 is($s, $exp, 'recurse4'); 891 } 892 893 # single (??{}) being invoked recursively via a function 894 895 { 896 my $s = ''; 897 our $recurse5; 898 my @alpha = qw(A B C D E); 899 $recurse5 = sub { 900 my ($n) = @_; 901 $s .= "(n=$n:"; 902 if ($n < 4) { 903 my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~ 904 m{^([A-Z]) 905 ((??{ 906 $s .= "1=$1:"; 907 $recurse5->($n+1); 908 })) 909 $ 910 }x; 911 $s .= "1a=$1:2=$2:"; 912 $s .= $m ? 'M' : '!M'; 913 } 914 my $ret = '.*?' . ($n-1); 915 $s .= "<=[$ret])"; 916 return $ret; 917 }; 918 $recurse5->(0); 919 my $exp = '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])' 920 . '1a=D:2=0123:M<=[.*?2])1a=C:2=012:M<=[.*?1])' 921 . '1a=B:2=01:M<=[.*?0])1a=A:2=0:M<=[.*?-1])'; 922 is($s, $exp, 'recurse5'); 923 } 924 925 926 # make sure that errors during compiling run-time code get trapped 927 928 { 929 use re 'eval'; 930 931 my $code = '(?{$x=})'; 932 eval { "a" =~ /^a$code/ }; 933 like($@, qr/syntax error at \(eval \d+\) line \d+/, 'syntax error'); 934 935 $code = '(?{BEGIN{die})'; 936 eval { "a" =~ /^a$code/ }; 937 like($@, 938 qr/BEGIN failed--compilation aborted at \(eval \d+\) line \d+/, 939 'syntax error'); 940 941 use utf8; 942 $code = '(?{Ｆｏｏ::$bar})'; 943 eval { "a" =~ /^a$code/ }; 944 like($@, qr/Bad name after Ｆｏｏ:: at \(eval \d+\) line \d+/, 'UTF8 sytax error'); 945 } 946 947 # make sure that 'use re eval' is propagated into compiling the 948 # pattern returned by (??{}) 949 950 { 951 use re 'eval'; 952 my $pat = 'B(??{1})C'; 953 my $A = 'A'; 954 # compile-time outer code-block 955 ok("AB1CD" =~ /^A(??{$pat})D$/, "re eval propagated compile-time"); 956 # run-time outer code-block 957 ok("AB1CD" =~ /^$A(??{$pat})D$/, "re eval propagated run-time"); 958 } 959 960 # returning a ref to something that had set magic but wasn't 961 # PERL_MAGIC_qr triggered a false positive assertion failure 962 # The test is not so much concerned with it not matching, 963 # as with not failing the assertion 964 965 { 966 ok("a" !~ /^(a)(??{ \$1 })/, '(??{ ref })'); 967 } 968 969 # make sure the uninit warning from returning an undef var 970 # sees the right var 971 972 { 973 my ($u1, $u2); 974 my $warn = ''; 975 local $SIG{__WARN__} = sub { $warn .= $_[0] }; 976 $u1 =~ /(??{$u2})/ or die; 977 like($warn, qr/value \$u1 in pattern match.*\n.*value at/, 'uninit'); 978 } 979 980 # test that code blocks are called in scalar context 981 982 { 983 my @a = (0); 984 ok("" =~ /^(?{@a})$/, '(?{}) in scalar context'); 985 is($^R, 1, '(?{}) in scalar context: $^R'); 986 ok("1" =~ /^(??{@a})$/, '(??{}) in scalar context'); 987 ok("foo" =~ /^(?(?{@a})foo|bar)$/, '(?(?{})|) in scalar context'); 988 } 989 990 # BEGIN in compiled blocks shouldn't mess with $1 et al 991 992 { 993 use re 'eval'; 994 my $code1 = '(B)(??{ BEGIN { "X" =~ /X/ } $1})(C)'; 995 ok("ABBCA" =~ /^(.)(??{$code1})\1$/, '(?{}) BEGIN and $1'); 996 my $code2 = '(B)(??{ BEGIN { "X" =~ /X/ } $1 =~ /(.)/ ? $1 : ""})(C)'; 997 ok("ABBCA" =~ /^(.)(??{$code2})\1$/, '(?{}) BEGIN and $1 mark 2'); 998 } 999 1000 # check that the optimiser is applied to code blocks: see if aelem has 1001 # been converted to aelemfast 1002 1003 { 1004 my $out; 1005 for my $prog ( 1006 '/(?{$a[0]})/', 1007 'q() =~ qr/(?{$a[0]})/', 1008 'use re q(eval); q() =~ q{(?{$a[0]})}', 1009 'use re q(eval); $c = q{(?{$a[0]})}; /$c/', 1010 'use re q(eval); $c = q{(?{$a[0]})}; /(?{1;})$c/', 1011 ) { 1012 $out = runperl(switches => ["-Dt"], prog => $prog, stderr => 1); 1013 like($out, qr/aelemfast|Recompile perl with -DDEBUGGING/, 1014 "optimise: '$prog'"); 1015 } 1016 } 1017 1018 # [perl #115080] 1019 # Ensure that ?pat? matches exactly once, even when the run-time 1020 # pattern changes, and even when the presence of run-time (?{}) affects 1021 # how and when patterns are recompiled 1022 1023 { 1024 my $m; 1025 1026 $m = ''; 1027 for (qw(a a a)) { 1028 $m .= $_ if m?$_?; 1029 } 1030 is($m, 'a', '?pat? with a,a,a'); 1031 1032 $m = ''; 1033 for (qw(a b c)) { 1034 $m .= $_ if m?$_?; 1035 } 1036 is($m, 'a', '?pat? with a,b,c'); 1037 1038 use re 'eval'; 1039 1040 $m = ''; 1041 for (qw(a a a)) { 1042 my $e = qq[(??{"$_"})]; 1043 $m .= $_ if m?$e?; 1044 } 1045 is($m, 'a', '?pat? with (??{a,a,a})'); 1046 1047 $m = ''; 1048 for (qw(a b c)) { 1049 my $e = qq[(??{"$_"})]; 1050 $m .= $_ if m?$e?; 1051 } 1052 is($m, 'a', '?pat? with (??{a,b,c})'); 1053 } 1054 1055 { 1056 # this code won't actually fail, but it used to fail valgrind, 1057 # so its here just to make sure valgrind doesn't fail again 1058 # While examining the ops of the secret anon sub wrapped around 1059 # the qr//, the pad of the sub was in scope, so cSVOPo_sv 1060 # got the const from the wrong pad. By having lots of $s's 1061 # (aka gvsv(*s), this forces the targs of the consts which have 1062 # been moved to the pad, to have high indices. 1063 1064 sub { 1065 local our $s = "abc"; 1066 my $qr = qr/^(?{1})$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s/; 1067 }->(); 1068 pass("cSVOPo_sv"); 1069 } 1070 1071 # [perl #115004] 1072 # code blocks in qr objects that are interpolated in arrays need 1073 # handling the same as if they were interpolated from scalar vars 1074 # (before this code would need 'use re "eval"') 1075 1076 { 1077 use Tie::Array; 1078 1079 use vars '@global'; 1080 local @global; 1081 my @array; 1082 my @refs = (0, \@array, 2); 1083 my @tied; 1084 tie @tied, 'Tie::StdArray'; 1085 { 1086 my $bb = 'B'; 1087 my $dd = 'D'; 1088 @array = ('A', qr/(??{$bb})/, 'C', qr/(??{$dd})/, 'E'); 1089 @tied = @array; 1090 @global = @array; 1091 } 1092 my $bb = 'X'; 1093 my $dd = 'Y'; 1094 ok("A B C D E=" =~ /@array/, 'bare interpolated array match'); 1095 ok("A B C D E=" =~ qr/@array/, 'qr bare interpolated array match'); 1096 ok("A B C D E=" =~ /@global/, 'bare interpolated global array match'); 1097 ok("A B C D E=" =~ qr/@global/, 1098 'qr bare interpolated global array match'); 1099 ok("A B C D E=" =~ /@{$refs[1]}/, 'bare interpolated ref array match'); 1100 ok("A B C D E=" =~ qr/@{$refs[1]}/, 1101 'qr bare interpolated ref array match'); 1102 ok("A B C D E=" =~ /@tied/, 'bare interpolated tied array match'); 1103 ok("A B C D E=" =~ qr/@tied/, 'qr bare interpolated tied array match'); 1104 ok("aA B C D E=" =~ /^a@array=$/, 'interpolated array match'); 1105 ok("aA B C D E=" =~ qr/^a@array=$/, 'qr interpolated array match'); 1106 ok("aA B C D E=" =~ /^a@global=$/, 'interpolated global array match'); 1107 ok("aA B C D E=" =~ qr/^a@global=$/, 1108 'qr interpolated global array match'); 1109 ok("aA B C D E=" =~ /^a@{$refs[1]}=$/, 'interpolated ref array match'); 1110 ok("aA B C D E=" =~ qr/^a@{$refs[1]}=$/, 1111 'qr interpolated ref array match'); 1112 ok("aA B C D E=" =~ /^a@tied=$/, 'interpolated tied array match'); 1113 ok("aA B C D E=" =~ qr/^a@tied=$/, 'qr interpolated tied array match'); 1114 1115 { 1116 local $" = '-'; 1117 ok("aA-B-C-D-E=" =~ /^a@{array}=$/, 1118 'interpolated array match with local sep'); 1119 ok("aA-B-C-D-E=" =~ qr/^a@{array}=$/, 1120 'qr interpolated array match with local sep'); 1121 ok("aA-B-C-D-E=" =~ /^a@{global}=$/, 1122 'interpolated global array match with local sep'); 1123 ok("aA-B-C-D-E=" =~ qr/^a@{global}=$/, 1124 'qr interpolated global array match with local sep'); 1125 ok("aA-B-C-D-E=" =~ /^a@{tied}=$/, 1126 'interpolated tied array match with local sep'); 1127 ok("aA-B-C-D-E=" =~ qr/^a@{tied}=$/, 1128 'qr interpolated tied array match with local sep'); 1129 } 1130 1131 # but don't handle the array ourselves in the presence of \Q etc 1132 1133 @array = ('A', '(?{})'); 1134 @global = @array; 1135 @tied = @array; 1136 ok("aA (?{})=" =~ /^a\Q@{array}\E=$/, 1137 'interpolated array match with \Q'); 1138 ok("aA (?{})=" =~ qr/^a\Q@{array}\E=$/, 1139 'qr interpolated array match with \Q'); 1140 ok("aA (?{})=" =~ /^a\Q@{global}\E=$/, 1141 'interpolated global array match with \Q'); 1142 ok("aA (?{})=" =~ qr/^a\Q@{global}\E=$/, 1143 'qr interpolated global array match with \Q'); 1144 ok("aA (?{})=" =~ /^a\Q@{$refs[1]}\E=$/, 1145 'interpolated ref array match with \Q'); 1146 ok("aA (?{})=" =~ qr/^a\Q@{$refs[1]}\E=$/, 1147 'qr interpolated ref array match with \Q'); 1148 ok("aA (?{})=" =~ /^a\Q@{tied}\E=$/, 1149 'interpolated tied array match with \Q'); 1150 ok("aA (?{})=" =~ qr/^a\Q@{tied}\E=$/, 1151 'qr interpolated tied array match with \Q'); 1152 1153 # and check it works with an empty array 1154 1155 @array = (); 1156 @global = (); 1157 @tied = (); 1158 ok("a=" =~ /^a@array=$/, 'empty array match'); 1159 ok("a=" =~ qr/^a@array=$/, 'qr empty array match'); 1160 ok("a=" =~ /^a@global=$/, 'empty global array match'); 1161 ok("a=" =~ qr/^a@global=$/, 'qr empty global array match'); 1162 ok("a=" =~ /^a@tied=$/, 'empty tied array match'); 1163 ok("a=" =~ qr/^a@tied=$/, 'qr empty tied array match'); 1164 ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q'); 1165 ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q'); 1166 ok("a=" =~ qr/^a\Q@{global}\E=$/, 1167 'qr empty global array match with \Q'); 1168 ok("a=" =~ /^a\Q@{tied}\E=$/, 'empty tied array match with \Q'); 1169 ok("a=" =~ qr/^a\Q@{tied}\E=$/, 'qr empty tied array match with \Q'); 1170 1171 # NB: these below are empty patterns, so they happen to use the 1172 # successful match from the line above 1173 1174 ok("a=" =~ /@array/, 'empty array pattern'); 1175 ok("a=" =~ qr/@array/, 'qr empty array pattern'); 1176 ok("a=" =~ /@global/, 'empty global array pattern'); 1177 ok("a=" =~ qr/@global/, 'qr empty global array pattern'); 1178 ok("a=" =~ /@tied/, 'empty tied pattern'); 1179 ok("a=" =~ qr/@tied/, 'qr empty tied pattern'); 1180 ok("a=" =~ /\Q@array\E/, 'empty array pattern with \Q'); 1181 ok("a=" =~ qr/\Q@array\E/, 'qr empty array pattern with \Q'); 1182 ok("a=" =~ /\Q@global\E/, 'empty global array pattern with \Q'); 1183 ok("a=" =~ qr/\Q@global\E/, 'qr empty global array pattern with \Q'); 1184 ok("a=" =~ /\Q@tied\E/, 'empty tied pattern with \Q'); 1185 ok("a=" =~ qr/\Q@tied\E/, 'qr empty tied pattern with \Q'); 1186 ok("a=" =~ //, 'completely empty pattern'); 1187 ok("a=" =~ qr//, 'qr completely empty pattern'); 1188 } 1189 1190 { 1191 { package o; use overload '""'=>sub { "abc" } } 1192 my $x = bless [],"o"; 1193 my $y = \$x; 1194 (my $y_addr = "$y") =~ y/()//d; # REF(0x7fcb9c02) -> REF0x7fcb9c02 1195 # $y_addr =~ $y should be true, as should $y_addr =~ /(??{$y})/ 1196 "abc$y_addr" =~ /(??{$x})(??{$y})/; 1197 is "$&", "abc$y_addr", 1198 '(??{$x}) does not leak cached qr to (??{\$x}) (match)'; 1199 is scalar "abcabc" =~ /(??{$x})(??{$y})/, "", 1200 '(??{$x}) does not leak cached qr to (??{\$x}) (no match)'; 1201 } 1202 1203 { 1204 sub ReEvalTieTest::TIESCALAR {bless[], "ReEvalTieTest"} 1205 sub ReEvalTieTest::STORE{} 1206 sub ReEvalTieTest::FETCH { "$1" } 1207 tie my $t, "ReEvalTieTest"; 1208 $t = bless [], "o"; 1209 "aab" =~ /(a)((??{"b" =~ m|(.)|; $t}))/; 1210 is "[$1 $2]", "[a b]", 1211 '(??{$tied_former_overload}) sees the right $1 in FETCH'; 1212 } 1213 1214 { 1215 my @matchsticks; 1216 my $ref = bless \my $o, "o"; 1217 my $foo = sub { push @matchsticks, scalar "abc" =~ /(??{$ref})/ }; 1218 &$foo; 1219 bless \$o; 1220 () = "$ref"; # flush AMAGIC flag on main 1221 &$foo; 1222 is "@matchsticks", "1 ", 'qr magic is not cached on refs'; 1223 } 1224 1225 { 1226 my ($foo, $bar) = ("foo"x1000, "bar"x1000); 1227 "$foo$bar" =~ /(??{".*"})/; 1228 is "$&", "foo"x1000 . "bar"x1000, 1229 'padtmp swiping does not affect "$a$b" =~ /(??{})/' 1230 } 1231 1232} # End of sub run_tests 1233 12341; 1235