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; 9no warnings 'experimental::vlb'; 10use 5.010; 11 12sub run_tests; 13 14$| = 1; 15 16 17BEGIN { 18 chdir 't' if -d 't'; 19 require Config; import Config; 20 require './test.pl'; require './charset_tools.pl'; 21 require './loc_tools.pl'; 22 set_up_inc('../lib', '.', '../ext/re'); 23} 24 25skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader; 26skip_all_without_unicode_tables(); 27 28plan tests => 873; # Update this when adding/deleting tests. 29 30run_tests() unless caller; 31 32# 33# Tests start here. 34# 35sub run_tests { 36 my $sharp_s = uni_to_native("\xdf"); 37 38 { 39 my $x = "abc\ndef\n"; 40 (my $x_pretty = $x) =~ s/\n/\\n/g; 41 42 ok $x =~ /^abc/, qq ["$x_pretty" =~ /^abc/]; 43 ok $x !~ /^def/, qq ["$x_pretty" !~ /^def/]; 44 45 # used to be a test for $* 46 ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m]; 47 48 ok(!($x =~ /^xxx/), qq ["$x_pretty" =~ /^xxx/]); 49 ok(!($x !~ /^abc/), qq ["$x_pretty" !~ /^abc/]); 50 51 ok $x =~ /def/, qq ["$x_pretty" =~ /def/]; 52 ok(!($x !~ /def/), qq ["$x_pretty" !~ /def/]); 53 54 ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/]; 55 ok(!($x =~ /.def/), qq ["$x_pretty" =~ /.def/]); 56 57 ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/]; 58 ok(!($x !~ /\ndef/), qq ["$x_pretty" !~ /\\ndef/]); 59 } 60 61 { 62 $_ = '123'; 63 ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/]; 64 } 65 66 { 67 $_ = 'aaabbbccc'; 68 ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc', 69 qq [\$_ = '$_'; /(a*b*)(c*)/]; 70 ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/]; 71 unlike($_, qr/a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]); 72 73 $_ = 'aaabccc'; 74 ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; 75 ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; 76 77 $_ = 'aaaccc'; 78 ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; 79 unlike($_, qr/a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]); 80 81 $_ = 'abcdef'; 82 ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/]; 83 ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/]; 84 ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|]; 85 ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/]; 86 } 87 88 { 89 # used to be a test for $* 90 ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m]; 91 } 92 93 { 94 our %XXX = map {($_ => $_)} 123, 234, 345; 95 96 our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3'); 97 while ($_ = shift(@XXX)) { 98 my $e = index ($_, 'not') >= 0 ? '' : 1; 99 my $r = m?(.*)?; 100 is($r, $e, "?(.*)?"); 101 /not/ && reset; 102 if (/not ok 2/) { 103 if ($^O eq 'VMS') { 104 $_ = shift(@XXX); 105 } 106 else { 107 reset 'X'; 108 } 109 } 110 } 111 112 SKIP: { 113 if ($^O eq 'VMS') { 114 skip "Reset 'X'", 1; 115 } 116 ok !keys %XXX, "%XXX is empty"; 117 } 118 119 } 120 121 { 122 my $message = "Test empty pattern"; 123 my $xyz = 'xyz'; 124 my $cde = 'cde'; 125 126 $cde =~ /[^ab]*/; 127 $xyz =~ //; 128 is($&, $xyz, $message); 129 130 my $foo = '[^ab]*'; 131 $cde =~ /$foo/; 132 $xyz =~ //; 133 is($&, $xyz, $message); 134 135 $cde =~ /$foo/; 136 my $null; 137 no warnings 'uninitialized'; 138 $xyz =~ /$null/; 139 is($&, $xyz, $message); 140 141 $null = ""; 142 $xyz =~ /$null/; 143 is($&, $xyz, $message); 144 145 # each entry: regexp, match string, $&, //o match success 146 my @tests = 147 ( 148 [ "", "xy", "x", 1 ], 149 [ "y", "yz", "y", !1 ], 150 ); 151 for my $test (@tests) { 152 my ($re, $str, $matched, $omatch) = @$test; 153 $xyz =~ /x/o; 154 ok($str =~ /$re/, "$str matches /$re/"); 155 is($&, $matched, "on $matched"); 156 $xyz =~ /x/o; 157 is($str =~ /$re/o, $omatch, "$str matches /$re/o (or not)"); 158 } 159 } 160 161 { 162 my $message = q !Check $`, $&, $'!; 163 $_ = 'abcdefghi'; 164 /def/; # optimized up to cmd 165 is("$`:$&:$'", 'abc:def:ghi', $message); 166 167 no warnings 'void'; 168 /cde/ + 0; # optimized only to spat 169 is("$`:$&:$'", 'ab:cde:fghi', $message); 170 171 /[d][e][f]/; # not optimized 172 is("$`:$&:$'", 'abc:def:ghi', $message); 173 } 174 175 { 176 $_ = 'now is the {time for all} good men to come to.'; 177 / \{([^}]*)}/; 178 is($1, 'time for all', "Match braces"); 179 } 180 181 { 182 my $message = "{N,M} quantifier"; 183 $_ = 'xxx {3,4} yyy zzz'; 184 ok(/( {3,4})/, $message); 185 is($1, ' ', $message); 186 unlike($_, qr/( {4,})/, $message); 187 ok(/( {2,3}.)/, $message); 188 is($1, ' y', $message); 189 ok(/(y{2,3}.)/, $message); 190 is($1, 'yyy ', $message); 191 unlike($_, qr/x {3,4}/, $message); 192 unlike($_, qr/^xxx {3,4}/, $message); 193 } 194 195 { 196 my $message = "Test /g"; 197 local $" = ":"; 198 $_ = "now is the time for all good men to come to."; 199 my @words = /(\w+)/g; 200 my $exp = "now:is:the:time:for:all:good:men:to:come:to"; 201 202 is("@words", $exp, $message); 203 204 @words = (); 205 while (/\w+/g) { 206 push (@words, $&); 207 } 208 is("@words", $exp, $message); 209 210 @words = (); 211 pos = 0; 212 while (/to/g) { 213 push(@words, $&); 214 } 215 is("@words", "to:to", $message); 216 217 pos $_ = 0; 218 @words = /to/g; 219 is("@words", "to:to", $message); 220 } 221 222 { 223 $_ = "abcdefghi"; 224 225 my $pat1 = 'def'; 226 my $pat2 = '^def'; 227 my $pat3 = '.def.'; 228 my $pat4 = 'abc'; 229 my $pat5 = '^abc'; 230 my $pat6 = 'abc$'; 231 my $pat7 = 'ghi'; 232 my $pat8 = '\w*ghi'; 233 my $pat9 = 'ghi$'; 234 235 my $t1 = my $t2 = my $t3 = my $t4 = my $t5 = 236 my $t6 = my $t7 = my $t8 = my $t9 = 0; 237 238 for my $iter (1 .. 5) { 239 $t1++ if /$pat1/o; 240 $t2++ if /$pat2/o; 241 $t3++ if /$pat3/o; 242 $t4++ if /$pat4/o; 243 $t5++ if /$pat5/o; 244 $t6++ if /$pat6/o; 245 $t7++ if /$pat7/o; 246 $t8++ if /$pat8/o; 247 $t9++ if /$pat9/o; 248 } 249 my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; 250 is($x, '505550555', "Test /o"); 251 } 252 253 { 254 my $xyz = 'xyz'; 255 ok "abc" =~ /^abc$|$xyz/, "| after \$"; 256 257 # perl 4.009 says "unmatched ()" 258 my $message = '$ inside ()'; 259 260 my $result; 261 eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; 262 is($@, "", $message); 263 is($result, "abc:bc", $message); 264 } 265 266 { 267 my $message = "Scalar /g"; 268 $_ = "abcfooabcbar"; 269 270 ok( /abc/g && $` eq "", $message); 271 ok( /abc/g && $` eq "abcfoo", $message); 272 ok(!/abc/g, $message); 273 274 $message = "Scalar /gi"; 275 pos = 0; 276 ok( /ABC/gi && $` eq "", $message); 277 ok( /ABC/gi && $` eq "abcfoo", $message); 278 ok(!/ABC/gi, $message); 279 280 $message = "Scalar /g"; 281 pos = 0; 282 ok( /abc/g && $' eq "fooabcbar", $message); 283 ok( /abc/g && $' eq "bar", $message); 284 285 $_ .= ''; 286 my @x = /abc/g; 287 is(@x, 2, "/g reset after assignment"); 288 } 289 290 { 291 my $message = '/g, \G and pos'; 292 $_ = "abdc"; 293 pos $_ = 2; 294 /\Gc/gc; 295 is(pos $_, 2, $message); 296 /\Gc/g; 297 is(pos $_, undef, $message); 298 } 299 300 { 301 my $message = '(?{ })'; 302 our $out = 1; 303 'abc' =~ m'a(?{ $out = 2 })b'; 304 is($out, 2, $message); 305 306 $out = 1; 307 'abc' =~ m'a(?{ $out = 3 })c'; 308 is($out, 1, $message); 309 } 310 311 { 312 $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; 313 my @out = /(?<!foo)bar./g; 314 is("@out", 'bar2 barf', "Negative lookbehind"); 315 } 316 317 { 318 my $message = "REG_INFTY tests"; 319 # Tests which depend on REG_INFTY 320 321 # Defaults assumed if this fails 322 eval { require Config; }; 323 $::reg_infty = $Config::Config{reg_infty} // 65535; 324 $::reg_infty_m = $::reg_infty - 1; 325 $::reg_infty_p = $::reg_infty + 1; 326 $::reg_infty_m = $::reg_infty_m; # Suppress warning. 327 328 # As well as failing if the pattern matches do unexpected things, the 329 # next three tests will fail if you should have picked up a lower-than- 330 # default value for $reg_infty from Config.pm, but have not. 331 332 is(eval q{('aaa' =~ /(a{1,$::reg_infty_m})/)[0]}, 'aaa', $message); 333 is($@, '', $message); 334 is(eval q{('a' x $::reg_infty_m) =~ /a{$::reg_infty_m}/}, 1, $message); 335 is($@, '', $message); 336 isnt(q{('a' x ($::reg_infty_m - 1)) !~ /a{$::reg_infty_m}/}, 1, $message); 337 is($@, '', $message); 338 339 eval "'aaa' =~ /a{1,$::reg_infty}/"; 340 like($@, qr/^\QQuantifier in {,} bigger than/, $message); 341 eval "'aaa' =~ /a{1,$::reg_infty_p}/"; 342 like($@, qr/^\QQuantifier in {,} bigger than/, $message); 343 344 # It should be 'a' x 2147483647, but that exhausts memory on 345 # reasonably sized modern machines 346 like('a' x $::reg_infty_p, qr/a{1,}/, 347 "{1,} matches more times than REG_INFTY"); 348 } 349 350 { 351 # Poke a couple more parse failures 352 my $context = 'x' x 256; 353 eval qq("${context}y" =~ /(?<=$context)y/); 354 ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit"; 355 } 356 357 { 358 # Long Monsters 359 for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory 360 my $a = 'a' x $l; 361 my $message = "Long monster, length = $l"; 362 like("ba$a=", qr/a$a=/, $message); 363 unlike("b$a=", qr/a$a=/, $message); 364 like("b$a=", qr/ba+=/, $message); 365 366 like("ba$a=", qr/b(?:a|b)+=/, $message); 367 } 368 } 369 370 { 371 # 20000 nodes, each taking 3 words per string, and 1 per branch 372 my $long_constant_len = join '|', 12120 .. 32645; 373 my $long_var_len = join '|', 8120 .. 28645; 374 my %ans = ( 'ax13876y25677lbc' => 1, 375 'ax13876y25677mcb' => 0, # not b. 376 'ax13876y35677nbc' => 0, # Num too big 377 'ax13876y25677y21378obc' => 1, 378 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] 379 'ax13876y25677y21378y21378kbc' => 1, 380 'ax13876y25677y21378y21378kcb' => 0, # Not b. 381 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs 382 ); 383 384 for (keys %ans) { 385 my $message = "20000 nodes, const-len '$_'"; 386 ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o), $message; 387 388 $message = "20000 nodes, var-len '$_'"; 389 ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o,), $message; 390 } 391 } 392 393 { 394 my $message = "Complicated backtracking"; 395 $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; 396 my $expect = "(bla()) ((l)u((e))) (l(e)e)"; 397 398 our $c; 399 sub matchit { 400 m/ 401 ( 402 \( 403 (?{ $c = 1 }) # Initialize 404 (?: 405 (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop 406 (?! 407 ) # Fail: will unwind one iteration back 408 ) 409 (?: 410 [^()]+ # Match a big chunk 411 (?= 412 [()] 413 ) # Do not try to match subchunks 414 | 415 \( 416 (?{ ++$c }) 417 | 418 \) 419 (?{ --$c }) 420 ) 421 )+ # This may not match with different subblocks 422 ) 423 (?(?{ $c != 0 }) 424 (?! 425 ) # Fail 426 ) # Otherwise the chunk 1 may succeed with $c>0 427 /xg; 428 } 429 430 my @ans = (); 431 my $res; 432 push @ans, $res while $res = matchit; 433 is("@ans", "1 1 1", $message); 434 435 @ans = matchit; 436 is("@ans", $expect, $message); 437 438 $message = "Recursion with (??{ })"; 439 our $matched; 440 $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; 441 442 @ans = my @ans1 = (); 443 push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g; 444 445 is("@ans", "1 1 1", $message); 446 is("@ans1", $expect, $message); 447 448 @ans = m/$matched/g; 449 is("@ans", $expect, $message); 450 451 } 452 453 { 454 ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/'; 455 } 456 457 { 458 my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad 459 is("@ans", 'a/ b', "Stack may be bad"); 460 } 461 462 { 463 my $message = "Eval-group not allowed at runtime"; 464 my $code = '{$blah = 45}'; 465 our $blah = 12; 466 eval { /(?$code)/ }; 467 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); 468 469 $blah = 12; 470 my $res = eval { "xx" =~ /(?$code)/o }; 471 { 472 no warnings 'uninitialized'; 473 chomp $@; my $message = "$message '$@', '$res', '$blah'"; 474 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); 475 } 476 477 $code = '=xx'; 478 $blah = 12; 479 $res = eval { "xx" =~ /(?$code)/o }; 480 { 481 no warnings 'uninitialized'; 482 my $message = "$message '$@', '$res', '$blah'"; 483 ok(!$@ && $res, $message); 484 } 485 486 $code = '{$blah = 45}'; 487 $blah = 12; 488 eval "/(?$code)/"; 489 is($blah, 45, $message); 490 491 $blah = 12; 492 /(?{$blah = 45})/; 493 is($blah, 45, $message); 494 } 495 496 { 497 my $message = "Pos checks"; 498 my $x = 'banana'; 499 $x =~ /.a/g; 500 is(pos $x, 2, $message); 501 502 $x =~ /.z/gc; 503 is(pos $x, 2, $message); 504 505 sub f { 506 my $p = $_[0]; 507 return $p; 508 } 509 510 $x =~ /.a/g; 511 is(f (pos $x), 4, $message); 512 } 513 514 { 515 my $message = 'Checking $^R'; 516 our $x = $^R = 67; 517 'foot' =~ /foo(?{$x = 12; 75})[t]/; 518 is($^R, 75, $message); 519 520 $x = $^R = 67; 521 'foot' =~ /foo(?{$x = 12; 75})[xy]/; 522 ok($^R eq '67' && $x eq '12', $message); 523 524 $x = $^R = 67; 525 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; 526 ok($^R eq '79' && $x eq '12', $message); 527 } 528 529 { 530 is(qr/\b\v$/i, '(?^i:\b\v$)', 'qr/\b\v$/i'); 531 is(qr/\b\v$/s, '(?^s:\b\v$)', 'qr/\b\v$/s'); 532 is(qr/\b\v$/m, '(?^m:\b\v$)', 'qr/\b\v$/m'); 533 is(qr/\b\v$/x, '(?^x:\b\v$)', 'qr/\b\v$/x'); 534 is(qr/\b\v$/xism, '(?^msix:\b\v$)', 'qr/\b\v$/xism'); 535 is(qr/\b\v$/, '(?^:\b\v$)', 'qr/\b\v$/'); 536 } 537 538 { # Test that charset modifier work, and are interpolated 539 is(qr/\b\v$/, '(?^:\b\v$)', 'Verify no locale, no unicode_strings gives default modifier'); 540 is(qr/(?l:\b\v$)/, '(?^:(?l:\b\v$))', 'Verify infix l modifier compiles'); 541 is(qr/(?u:\b\v$)/, '(?^:(?u:\b\v$))', 'Verify infix u modifier compiles'); 542 is(qr/(?l)\b\v$/, '(?^:(?l)\b\v$)', 'Verify (?l) compiles'); 543 is(qr/(?u)\b\v$/, '(?^:(?u)\b\v$)', 'Verify (?u) compiles'); 544 545 my $dual = qr/\b\v$/; 546 my $locale; 547 548 SKIP: { 549 skip 'Locales not available', 1 unless locales_enabled('LC_CTYPE'); 550 551 use locale; 552 $locale = qr/\b\v$/; 553 is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale'); 554 no locale; 555 } 556 557 use feature 'unicode_strings'; 558 my $unicode = qr/\b\v$/; 559 is($unicode, '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings'); 560 is(qr/abc$dual/, '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); 561 562 SKIP: { 563 skip 'Locales not available', 1 unless locales_enabled('LC_CTYPE'); 564 565 is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings'); 566 } 567 568 no feature 'unicode_strings'; 569 SKIP: { 570 skip 'Locales not available', 1 unless locales_enabled('LC_CTYPE'); 571 is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings'); 572 } 573 574 is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings'); 575 576 SKIP: { 577 skip 'Locales not available', 2 unless locales_enabled('LC_CTYPE'); 578 579 use locale; 580 is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); 581 is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale'); 582 } 583 } 584 585 { 586 my $message = "Look around"; 587 $_ = 'xabcx'; 588 foreach my $ans ('', 'c') { 589 ok(/(?<=(?=a)..)((?=c)|.)/g, $message); 590 is($1, $ans, $message); 591 } 592 } 593 594 { 595 my $message = "Empty clause"; 596 $_ = 'a'; 597 foreach my $ans ('', 'a', '') { 598 ok(/^|a|$/g, $message); 599 is($&, $ans, $message); 600 } 601 } 602 603 { 604 sub prefixify { 605 my $message = "Prefixify"; 606 { 607 my ($v, $a, $b, $res) = @_; 608 ok($v =~ s/\Q$a\E/$b/, $message); 609 is($v, $res, $message); 610 } 611 } 612 613 prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); 614 prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); 615 } 616 617 { 618 $_ = 'var="foo"'; 619 /(\")/; 620 ok $1 && /$1/, "Capture a quote"; 621 } 622 623 { 624 no warnings 'closure'; 625 my $message = '(?{ $var } refers to package vars'; 626 package aa; 627 our $c = 2; 628 $::c = 3; 629 '' =~ /(?{ $c = 4 })/; 630 main::is($c, 4, $message); 631 main::is($::c, 3, $message); 632 } 633 634 { 635 is(eval 'q(a:[b]:) =~ /[x[:foo:]]/', undef); 636 like ($@, qr/POSIX class \[:[^:]+:\] unknown in regex/, 637 'POSIX class [: :] must have valid name'); 638 639 for my $d (qw [= .]) { 640 is(eval "/[[${d}foo${d}]]/", undef); 641 like ($@, qr/\QPOSIX syntax [$d $d] is reserved for future extensions/, 642 "POSIX syntax [[$d $d]] is an error"); 643 } 644 } 645 646 { 647 # test if failure of patterns returns empty list 648 my $message = "Failed pattern returns empty list"; 649 $_ = 'aaa'; 650 @_ = /bbb/; 651 is("@_", "", $message); 652 653 @_ = /bbb/g; 654 is("@_", "", $message); 655 656 @_ = /(bbb)/; 657 is("@_", "", $message); 658 659 @_ = /(bbb)/g; 660 is("@_", "", $message); 661 } 662 663 { 664 my $message = '@- and @+ and @{^CAPTURE} tests'; 665 666 $_= "ace"; 667 /c(?=.$)/; 668 is($#{^CAPTURE}, -1, $message); 669 is($#+, 0, $message); 670 is($#-, 0, $message); 671 is($+ [0], 2, $message); 672 is($- [0], 1, $message); 673 ok(!defined $+ [1] && !defined $- [1] && 674 !defined $+ [2] && !defined $- [2], $message); 675 676 /a(c)(e)/; 677 is($#{^CAPTURE}, 1, $message); # one less than $#- 678 is($#+, 2, $message); 679 is($#-, 2, $message); 680 is($+ [0], 3, $message); 681 is($- [0], 0, $message); 682 is(${^CAPTURE}[0], "c", $message); 683 is($+ [1], 2, $message); 684 is($- [1], 1, $message); 685 is(${^CAPTURE}[1], "e", $message); 686 is($+ [2], 3, $message); 687 is($- [2], 2, $message); 688 ok(!defined $+ [3] && !defined $- [3] && 689 !defined ${^CAPTURE}[2] && !defined ${^CAPTURE}[3] && 690 !defined $+ [4] && !defined $- [4], $message); 691 692 # Exists has a special check for @-/@+ - bug 45147 693 ok(exists $-[0], $message); 694 ok(exists $+[0], $message); 695 ok(exists ${^CAPTURE}[0], $message); 696 ok(exists ${^CAPTURE}[1], $message); 697 ok(exists $-[2], $message); 698 ok(exists $+[2], $message); 699 ok(!exists ${^CAPTURE}[2], $message); 700 ok(!exists $-[3], $message); 701 ok(!exists $+[3], $message); 702 ok(exists ${^CAPTURE}[-1], $message); 703 ok(exists ${^CAPTURE}[-2], $message); 704 ok(exists $-[-1], $message); 705 ok(exists $+[-1], $message); 706 ok(exists $-[-3], $message); 707 ok(exists $+[-3], $message); 708 ok(!exists $-[-4], $message); 709 ok(!exists $+[-4], $message); 710 ok(!exists ${^CAPTURE}[-3], $message); 711 712 713 /.(c)(b)?(e)/; 714 is($#{^CAPTURE}, 2, $message); # one less than $#- 715 is($#+, 3, $message); 716 is($#-, 3, $message); 717 is(${^CAPTURE}[0], "c", $message); 718 is(${^CAPTURE}[2], "e", $message . "[$1 $3]"); 719 is($+ [1], 2, $message); 720 is($- [1], 1, $message); 721 is($+ [3], 3, $message); 722 is($- [3], 2, $message); 723 ok(!defined $+ [2] && !defined $- [2] && 724 !defined $+ [4] && !defined $- [4] && 725 !defined ${^CAPTURE}[1], $message); 726 727 /.(c)/; 728 is($#{^CAPTURE}, 0, $message); # one less than $#- 729 is($#+, 1, $message); 730 is($#-, 1, $message); 731 is(${^CAPTURE}[0], "c", $message); 732 is($+ [0], 2, $message); 733 is($- [0], 0, $message); 734 is($+ [1], 2, $message); 735 is($- [1], 1, $message); 736 ok(!defined $+ [2] && !defined $- [2] && 737 !defined $+ [3] && !defined $- [3] && 738 !defined ${^CAPTURE}[1], $message); 739 740 /.(c)(ba*)?/; 741 is($#{^CAPTURE}, 0, $message); # one less than $#- 742 is($#+, 2, $message); 743 is($#-, 1, $message); 744 745 # Check that values don’t stick 746 " "=~/()()()(.)(..)/; 747 my($m,$p,$q) = (\$-[5], \$+[5], \${^CAPTURE}[4]); 748 () = "$$_" for $m, $p, $q; # FETCH (or eqv.) 749 " " =~ /()/; 750 is $$m, undef, 'values do not stick to @- elements'; 751 is $$p, undef, 'values do not stick to @+ elements'; 752 is $$q, undef, 'values do not stick to @{^CAPTURE} elements'; 753 } 754 755 foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)', 756 '${^CAPTURE}[0] = 13', 757 '@- = qw (foo bar)', '$^N = 42') { 758 is(eval $_, undef); 759 like($@, qr/^Modification of a read-only value attempted/, 760 '$^N, @- and @+ are read-only'); 761 } 762 763 { 764 my $message = '\G testing'; 765 $_ = 'aaa'; 766 pos = 1; 767 my @a = /\Ga/g; 768 is("@a", "a a", $message); 769 770 my $str = 'abcde'; 771 pos $str = 2; 772 unlike($str, qr/^\G/, $message); 773 unlike($str, qr/^.\G/, $message); 774 like($str, qr/^..\G/, $message); 775 unlike($str, qr/^...\G/, $message); 776 ok($str =~ /\G../ && $& eq 'cd', $message); 777 ok($str =~ /.\G./ && $& eq 'bc', $message); 778 779 } 780 781 { 782 my $message = '\G and intuit and anchoring'; 783 $_ = "abcdef"; 784 pos = 0; 785 ok($_ =~ /\Gabc/, $message); 786 ok($_ =~ /^\Gabc/, $message); 787 788 pos = 3; 789 ok($_ =~ /\Gdef/, $message); 790 pos = 3; 791 ok($_ =~ /\Gdef$/, $message); 792 pos = 3; 793 ok($_ =~ /abc\Gdef$/, $message); 794 pos = 3; 795 ok($_ =~ /^abc\Gdef$/, $message); 796 pos = 3; 797 ok($_ =~ /c\Gd/, $message); 798 pos = 3; 799 ok($_ =~ /..\GX?def/, $message); 800 } 801 802 { 803 my $s = '123'; 804 pos($s) = 1; 805 my @a = $s =~ /(\d)\G/g; # this infinitely looped up till 5.19.1 806 is("@a", "1", '\G looping'); 807 } 808 809 810 { 811 my $message = 'pos inside (?{ })'; 812 my $str = 'abcde'; 813 our ($foo, $bar); 814 like($str, qr/b(?{$foo = $_; $bar = pos})c/, $message); 815 is($foo, $str, $message); 816 is($bar, 2, $message); 817 is(pos $str, undef, $message); 818 819 undef $foo; 820 undef $bar; 821 pos $str = undef; 822 ok($str =~ /b(?{$foo = $_; $bar = pos})c/g, $message); 823 is($foo, $str, $message); 824 is($bar, 2, $message); 825 is(pos $str, 3, $message); 826 827 $_ = $str; 828 undef $foo; 829 undef $bar; 830 like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message); 831 is($foo, $str, $message); 832 is($bar, 2, $message); 833 834 undef $foo; 835 undef $bar; 836 ok(/b(?{$foo = $_; $bar = pos})c/g, $message); 837 is($foo, $str, $message); 838 is($bar, 2, $message); 839 is(pos, 3, $message); 840 841 undef $foo; 842 undef $bar; 843 pos = undef; 844 1 while /b(?{$foo = $_; $bar = pos})c/g; 845 is($foo, $str, $message); 846 is($bar, 2, $message); 847 is(pos, undef, $message); 848 849 undef $foo; 850 undef $bar; 851 $_ = 'abcde|abcde'; 852 ok(s/b(?{$foo = $_; $bar = pos})c/x/g, $message); 853 is($foo, 'abcde|abcde', $message); 854 is($bar, 8, $message); 855 is($_, 'axde|axde', $message); 856 857 # List context: 858 $_ = 'abcde|abcde'; 859 our @res; 860 () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; 861 @res = map {defined $_ ? "'$_'" : 'undef'} @res; 862 is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message); 863 864 @res = (); 865 () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; 866 @res = map {defined $_ ? "'$_'" : 'undef'} @res; 867 is("@res", "'' 'ab' 'cde|abcde' " . 868 "'' 'abc' 'de|abcde' " . 869 "'abcd' 'e|' 'abcde' " . 870 "'abcde|' 'ab' 'cde' " . 871 "'abcde|' 'abc' 'de'", $message); 872 } 873 874 { 875 my $message = '\G anchor checks'; 876 my $foo = 'aabbccddeeffgg'; 877 pos ($foo) = 1; 878 879 ok($foo =~ /.\G(..)/g, $message); 880 is($1, 'ab', $message); 881 882 pos ($foo) += 1; 883 ok($foo =~ /.\G(..)/g, $message); 884 is($1, 'cc', $message); 885 886 pos ($foo) += 1; 887 ok($foo =~ /.\G(..)/g, $message); 888 is($1, 'de', $message); 889 890 ok($foo =~ /\Gef/g, $message); 891 892 undef pos $foo; 893 ok($foo =~ /\G(..)/g, $message); 894 is($1, 'aa', $message); 895 896 ok($foo =~ /\G(..)/g, $message); 897 is($1, 'bb', $message); 898 899 pos ($foo) = 5; 900 ok($foo =~ /\G(..)/g, $message); 901 is($1, 'cd', $message); 902 } 903 904 { 905 my $message = 'basic \G floating checks'; 906 my $foo = 'aabbccddeeffgg'; 907 pos ($foo) = 1; 908 909 ok($foo =~ /a+\G(..)/g, "$message: a+\\G"); 910 is($1, 'ab', "$message: ab"); 911 912 pos ($foo) += 1; 913 ok($foo =~ /b+\G(..)/g, "$message: b+\\G"); 914 is($1, 'cc', "$message: cc"); 915 916 pos ($foo) += 1; 917 ok($foo =~ /d+\G(..)/g, "$message: d+\\G"); 918 is($1, 'de', "$message: de"); 919 920 ok($foo =~ /\Gef/g, "$message: \\Gef"); 921 922 pos ($foo) = 1; 923 924 ok($foo =~ /(?=a+\G)(..)/g, "$message: (?a+\\G)"); 925 is($1, 'aa', "$message: aa"); 926 927 pos ($foo) = 2; 928 929 ok($foo =~ /a(?=a+\G)(..)/g, "$message: a(?=a+\\G)"); 930 is($1, 'ab', "$message: ab"); 931 932 } 933 934 { 935 $_ = '123x123'; 936 my @res = /(\d*|x)/g; 937 local $" = '|'; 938 is("@res", "123||x|123|", "0 match in alternation"); 939 } 940 941 { 942 my $message = "Match against temporaries (created via pp_helem())" . 943 " is safe"; 944 ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message); 945 is($1, "bar", $message); 946 } 947 948 { 949 my $message = 'package $i inside (?{ }), ' . 950 'saved substrings and changing $_'; 951 our @a = qw [foo bar]; 952 our @b = (); 953 s/(\w)(?{push @b, $1})/,$1,/g for @a; 954 is("@b", "f o o b a r", $message); 955 is("@a", ",f,,o,,o, ,b,,a,,r,", $message); 956 957 $message = 'lexical $i inside (?{ }), ' . 958 'saved substrings and changing $_'; 959 no warnings 'closure'; 960 my @c = qw [foo bar]; 961 my @d = (); 962 s/(\w)(?{push @d, $1})/,$1,/g for @c; 963 is("@d", "f o o b a r", $message); 964 is("@c", ",f,,o,,o, ,b,,a,,r,", $message); 965 } 966 967 { 968 my $message = 'Brackets'; 969 our $brackets; 970 $brackets = qr { 971 { (?> [^{}]+ | (??{ $brackets }) )* } 972 }x; 973 974 ok("{{}" =~ $brackets, $message); 975 is($&, "{}", $message); 976 ok("something { long { and } hairy" =~ $brackets, $message); 977 is($&, "{ and }", $message); 978 ok("something { long { and } hairy" =~ m/((??{ $brackets }))/, $message); 979 is($&, "{ and }", $message); 980 } 981 982 { 983 $_ = "a-a\nxbb"; 984 pos = 1; 985 ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg'); 986 } 987 988 { 989 my $message = '\G anchor checks'; 990 my $text = "aaXbXcc"; 991 pos ($text) = 0; 992 ok($text !~ /\GXb*X/g, $message); 993 } 994 995 { 996 $_ = "xA\n" x 500; 997 unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"'); 998 999 my $text = "abc dbf"; 1000 my @res = ($text =~ /.*?(b).*?\b/g); 1001 is("@res", "b b", '\b is not special'); 1002 } 1003 1004 { 1005 my $message = '\S, [\S], \s, [\s]'; 1006 my @a = map chr, 0 .. 255; 1007 my @b = grep m/\S/, @a; 1008 my @c = grep m/[^\s]/, @a; 1009 is("@b", "@c", $message); 1010 1011 @b = grep /\S/, @a; 1012 @c = grep /[\S]/, @a; 1013 is("@b", "@c", $message); 1014 1015 @b = grep /\s/, @a; 1016 @c = grep /[^\S]/, @a; 1017 is("@b", "@c", $message); 1018 1019 @b = grep /\s/, @a; 1020 @c = grep /[\s]/, @a; 1021 is("@b", "@c", $message); 1022 1023 # Test an inverted posix class with a char also in the class. 1024 my $nbsp = chr utf8::unicode_to_native(0xA0); 1025 my $non_s = chr utf8::unicode_to_native(0xA1); 1026 my $pat_string = "[^\\S ]"; 1027 unlike(" ", qr/$pat_string/, "Verify ' ' !~ /$pat_string/"); 1028 like("\t", qr/$pat_string/, "Verify '\\t =~ /$pat_string/"); 1029 unlike($nbsp, qr/$pat_string/, "Verify non-utf8-NBSP !~ /$pat_string/"); 1030 utf8::upgrade($nbsp); 1031 like($nbsp, qr/$pat_string/, "Verify utf8-NBSP =~ /$pat_string/"); 1032 unlike($non_s, qr/$pat_string/, "Verify non-utf8-inverted-bang !~ /$pat_string/"); 1033 utf8::upgrade($non_s); 1034 unlike($non_s, qr/$pat_string/, "Verify utf8-inverted-bang !~ /$pat_string/"); 1035 } 1036 { 1037 my $message = '\D, [\D], \d, [\d]'; 1038 my @a = map chr, 0 .. 255; 1039 my @b = grep /\D/, @a; 1040 my @c = grep /[^\d]/, @a; 1041 is("@b", "@c", $message); 1042 1043 @b = grep /\D/, @a; 1044 @c = grep /[\D]/, @a; 1045 is("@b", "@c", $message); 1046 1047 @b = grep /\d/, @a; 1048 @c = grep /[^\D]/, @a; 1049 is("@b", "@c", $message); 1050 1051 @b = grep /\d/, @a; 1052 @c = grep /[\d]/, @a; 1053 is("@b", "@c", $message); 1054 } 1055 { 1056 my $message = '\W, [\W], \w, [\w]'; 1057 my @a = map chr, 0 .. 255; 1058 my @b = grep /\W/, @a; 1059 my @c = grep /[^\w]/, @a; 1060 is("@b", "@c", $message); 1061 1062 @b = grep /\W/, @a; 1063 @c = grep /[\W]/, @a; 1064 is("@b", "@c", $message); 1065 1066 @b = grep /\w/, @a; 1067 @c = grep /[^\W]/, @a; 1068 is("@b", "@c", $message); 1069 1070 @b = grep /\w/, @a; 1071 @c = grep /[\w]/, @a; 1072 is("@b", "@c", $message); 1073 } 1074 1075 { 1076 # see if backtracking optimization works correctly 1077 my $message = 'Backtrack optimization'; 1078 like("\n\n", qr/\n $ \n/x, $message); 1079 like("\n\n", qr/\n* $ \n/x, $message); 1080 like("\n\n", qr/\n+ $ \n/x, $message); 1081 like("\n\n", qr/\n? $ \n/x, $message); 1082 like("\n\n", qr/\n*? $ \n/x, $message); 1083 like("\n\n", qr/\n+? $ \n/x, $message); 1084 like("\n\n", qr/\n?? $ \n/x, $message); 1085 unlike("\n\n", qr/\n*+ $ \n/x, $message); 1086 unlike("\n\n", qr/\n++ $ \n/x, $message); 1087 like("\n\n", qr/\n?+ $ \n/x, $message); 1088 } 1089 1090 { 1091 package S; 1092 use overload '""' => sub {'Object S'}; 1093 sub new {bless []} 1094 1095 my $message = "Ref stringification"; 1096 ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or diag($message); 1097 ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or diag($message); 1098 ::ok([] =~ /^ARRAY/, "Array ref stringification") or diag($message); 1099 ::ok({} =~ /^HASH/, "Hash ref stringification") or diag($message); 1100 ::ok('S' -> new =~ /^Object S/, "Object stringification") or diag($message); 1101 } 1102 1103 { 1104 my $message = "Test result of match used as match"; 1105 ok('a1b' =~ ('xyz' =~ /y/), $message); 1106 is($`, 'a', $message); 1107 ok('a1b' =~ ('xyz' =~ /t/), $message); 1108 is($`, 'a', $message); 1109 } 1110 1111 { 1112 my $message = '"1" is not \s'; 1113 warning_is(sub {unlike("1\n" x 102, qr/^\s*\n/m, $message)}, 1114 undef, "$message (did not warn)"); 1115 } 1116 1117 { 1118 my $message = '\s, [[:space:]] and [[:blank:]]'; 1119 my %space = (spc => " ", 1120 tab => "\t", 1121 cr => "\r", 1122 lf => "\n", 1123 ff => "\f", 1124 # There's no \v but the vertical tabulator seems miraculously 1125 # be 11 both in ASCII and EBCDIC. 1126 vt => chr(11), 1127 false => "space"); 1128 1129 my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space; 1130 my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space; 1131 my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space; 1132 1133 is("@space0", "cr ff lf spc tab vt", $message); 1134 is("@space1", "cr ff lf spc tab vt", $message); 1135 is("@space2", "spc tab", $message); 1136 } 1137 1138 { 1139 my $n= 50; 1140 # this must be a high number and go from 0 to N, as the bug we are looking for doesn't 1141 # seem to be predictable. Slight changes to the test make it fail earlier or later. 1142 foreach my $i (0 .. $n) 1143 { 1144 my $str= "\n" x $i; 1145 ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i"; 1146 } 1147 } 1148 { 1149 # we are actually testing that we dont die when executing these patterns 1150 use utf8; 1151 my $e = "Böck"; 1152 ok(utf8::is_utf8($e),"got a unicode string - rt75680"); 1153 1154 ok($e !~ m/.*?[x]$/, "unicode string against /.*?[x]\$/ - rt75680"); 1155 ok($e !~ m/.*?\p{Space}$/i, "unicode string against /.*?\\p{space}\$/i - rt75680"); 1156 ok($e !~ m/.*?[xyz]$/, "unicode string against /.*?[xyz]\$/ - rt75680"); 1157 ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/, "unicode string against big pattern - rt75680"); 1158 } 1159 { 1160 # we are actually testing that we dont die when executing these patterns 1161 my $e = "B" . uni_to_native("\x{f6}") . "ck"; 1162 ok(!utf8::is_utf8($e), "got a latin string - rt75680"); 1163 1164 ok($e !~ m/.*?[x]$/, "latin string against /.*?[x]\$/ - rt75680"); 1165 ok($e !~ m/.*?\p{Space}$/i, "latin string against /.*?\\p{space}\$/i - rt75680"); 1166 ok($e !~ m/.*?[xyz]$/,"latin string against /.*?[xyz]\$/ - rt75680"); 1167 ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/,"latin string against big pattern - rt75680"); 1168 } 1169 1170 { 1171 # 1172 # Tests for bug 77414. 1173 # 1174 1175 my $message = '\p property after empty * match'; 1176 { 1177 like("1", qr/\s*\pN/, $message); 1178 like("-", qr/\s*\p{Dash}/, $message); 1179 like(" ", qr/\w*\p{Blank}/, $message); 1180 } 1181 1182 like("1", qr/\s*\pN+/, $message); 1183 like("-", qr/\s*\p{Dash}{1}/, $message); 1184 like(" ", qr/\w*\p{Blank}{1,4}/, $message); 1185 1186 } 1187 1188 { # Some constructs with Latin1 characters cause a utf8 string not 1189 # to match itself in non-utf8 1190 my $c = uni_to_native("\xc0"); 1191 my $pattern = my $utf8_pattern = qr/(($c)+,?)/; 1192 utf8::upgrade($utf8_pattern); 1193 ok $c =~ $pattern, "\\xc0 =~ $pattern; Neither pattern nor target utf8"; 1194 ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8"; 1195 ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not"; 1196 ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not"; 1197 utf8::upgrade($c); 1198 ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not"; 1199 ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not"; 1200 ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8"; 1201 ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8"; 1202 } 1203 1204 { # Make sure can override the formatting 1205 use feature 'unicode_strings'; 1206 ok uni_to_native("\xc0") =~ /\w/, 'Under unicode_strings: "\xc0" =~ /\w/'; 1207 ok uni_to_native("\xc0") !~ /(?d:\w)/, 'Under unicode_strings: "\xc0" !~ /(?d:\w)/'; 1208 } 1209 1210 { 1211 my $str= "\x{100}"; 1212 chop $str; 1213 my $qr= qr/$str/; 1214 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212"); 1215 $str= ""; 1216 $qr= qr/$str/; 1217 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212"); 1218 1219 } 1220 1221 { 1222 local $::TODO = "[perl #38133]"; 1223 1224 "A" =~ /(((?:A))?)+/; 1225 my $first = $2; 1226 1227 "A" =~ /(((A))?)+/; 1228 my $second = $2; 1229 1230 is($first, $second); 1231 } 1232 1233 { 1234 # RT #3516: \G in a m//g expression causes problems 1235 my $count = 0; 1236 while ("abc" =~ m/(\G[ac])?/g) { 1237 last if $count++ > 10; 1238 } 1239 ok($count < 10, 'RT #3516 A'); 1240 1241 $count = 0; 1242 while ("abc" =~ m/(\G|.)[ac]/g) { 1243 last if $count++ > 10; 1244 } 1245 ok($count < 10, 'RT #3516 B'); 1246 1247 $count = 0; 1248 while ("abc" =~ m/(\G?[ac])?/g) { 1249 last if $count++ > 10; 1250 } 1251 ok($count < 10, 'RT #3516 C'); 1252 } 1253 { 1254 # RT #84294: Is this a bug in the simple Perl regex? 1255 # : Nested buffers and (?{...}) dont play nicely on partial matches 1256 our @got= (); 1257 ok("ab" =~ /((\w+)(?{ push @got, $2 })){2}/,"RT #84294: Pattern should match"); 1258 my $want= "'ab', 'a', 'b'"; 1259 my $got= join(", ", map { defined($_) ? "'$_'" : "undef" } @got); 1260 is($got,$want,'RT #84294: check that "ab" =~ /((\w+)(?{ push @got, $2 })){2}/ leaves @got in the correct state'); 1261 } 1262 1263 { 1264 # Suppress warnings, as the non-unicode one comes out even if turn off 1265 # warnings here (because the execution is done in another scope). 1266 local $SIG{__WARN__} = sub {}; 1267 my $str = "\x{110000}"; 1268 1269 unlike($str, qr/\p{ASCII_Hex_Digit=True}/, "Non-Unicode doesn't match \\p{AHEX=True}"); 1270 like($str, qr/\p{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\p{AHEX=False}"); 1271 like($str, qr/\P{ASCII_Hex_Digit=True}/, "Non-Unicode matches \\P{AHEX=True}"); 1272 unlike($str, qr/\P{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\P{AHEX=FALSE}"); 1273 } 1274 1275 { 1276 # Test that IDstart works, but because the author (khw) knows 1277 # regexes much better than the rest of the core, it is being done here 1278 # in the context of a regex which relies on buffer names beginng with 1279 # IDStarts. 1280 use utf8; 1281 my $str = "abc"; 1282 like($str, qr/(?<a>abc)/, "'a' is legal IDStart"); 1283 like($str, qr/(?<_>abc)/, "'_' is legal IDStart"); 1284 like($str, qr/(?<ß>abc)/, "U+00DF is legal IDStart"); 1285 like($str, qr/(?<ℕ>abc)/, "U+2115' is legal IDStart"); 1286 1287 # This test works on Unicode 6.0 in which U+2118 and U+212E are legal 1288 # IDStarts there, but are not Word characters, and therefore Perl 1289 # doesn't allow them to be IDStarts. But there is no guarantee that 1290 # Unicode won't change things around in the future so that at some 1291 # future Unicode revision these tests would need to be revised. 1292 foreach my $char ("%", "×", chr(0x2118), chr(0x212E)) { 1293 my $prog = <<"EOP"; 1294use utf8;; 1295"abc" =~ qr/(?<$char>abc)/; 1296EOP 1297 utf8::encode($prog); 1298 fresh_perl_like($prog, qr!Group name must start with a non-digit word character!, {}, 1299 sprintf("'U+%04X not legal IDFirst'", ord($char))); 1300 } 1301 } 1302 1303 { # [perl #101710] 1304 my $pat = "b"; 1305 utf8::upgrade($pat); 1306 like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string"); 1307 } 1308 1309 { # Crash with @a =~ // warning 1310 local $SIG{__WARN__} = sub { 1311 pass 'no crash for @a =~ // warning' 1312 }; 1313 eval ' sub { my @a =~ // } '; 1314 } 1315 1316 { # Concat overloading and qr// thingies 1317 my @refs; 1318 my $qr = qr//; 1319 package Cat { 1320 require overload; 1321 overload->import( 1322 '""' => sub { ${$_[0]} }, 1323 '.' => sub { 1324 push @refs, ref $_[1] if ref $_[1]; 1325 bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]" 1326 } 1327 ); 1328 } 1329 my $s = "foo"; 1330 my $o = bless \$s, Cat::; 1331 /$o$qr/; 1332 is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth'; 1333 } 1334 1335 { 1336 my $count=0; 1337 my $str="\n"; 1338 $count++ while $str=~/.*/g; 1339 is $count, 2, 'test that ANCH_MBOL works properly. We should get 2 from $count++ while "\n"=~/.*/g'; 1340 my $class_count= 0; 1341 $class_count++ while $str=~/[^\n]*/g; 1342 is $class_count, $count, 'while "\n"=~/.*/g and while "\n"=~/[^\n]*/g should behave the same'; 1343 my $anch_count= 0; 1344 $anch_count++ while $str=~/^.*/mg; 1345 is $anch_count, 1, 'while "\n"=~/^.*/mg should match only once'; 1346 } 1347 1348 { # [perl #111174] 1349 use re '/u'; 1350 my $A_grave = uni_to_native("\xc0"); 1351 like uni_to_native("\xe0"), qr/(?i:$A_grave)/, "(?i: shouldn't lose the passed in /u"; 1352 use re '/a'; 1353 unlike "\x{100}", qr/(?i:\w)/, "(?i: shouldn't lose the passed in /a"; 1354 use re '/aa'; 1355 unlike 'k', qr/(?i:\N{KELVIN SIGN})/, "(?i: shouldn't lose the passed in /aa"; 1356 unlike 'k', qr'(?i:\N{KELVIN SIGN})', "(?i: shouldn't lose the passed in /aa"; 1357 } 1358 1359 { 1360 # the test for whether the pattern should be re-compiled should 1361 # consider the UTF8ness of the previous and current pattern 1362 # string, as well as the physical bytes of the pattern string 1363 1364 for my $s (byte_utf8a_to_utf8n("\xc4\x80"), "\x{100}") { 1365 ok($s =~ /^$s$/, "re-compile check is UTF8-aware"); 1366 } 1367 } 1368 1369 # #113682 more overloading and qr// 1370 # when doing /foo$overloaded/, if $overloaded returns 1371 # a qr/(?{})/ via qr or "" overloading, then 'use re 'eval' 1372 # shouldn't be required. Via '.', it still is. 1373 { 1374 package Qr0; 1375 use overload 'qr' => sub { qr/(??{50})/ }; 1376 1377 package Qr1; 1378 use overload '""' => sub { qr/(??{51})/ }; 1379 1380 package Qr2; 1381 use overload '.' => sub { $_[1] . qr/(??{52})/ }; 1382 1383 package Qr3; 1384 use overload '""' => sub { qr/(??{7})/ }, 1385 '.' => sub { $_[1] . qr/(??{53})/ }; 1386 1387 package Qr_indirect; 1388 use overload '""' => sub { $_[0][0] }; 1389 1390 package main; 1391 1392 for my $i (0..3) { 1393 my $o = bless [], "Qr$i"; 1394 if ((0,0,1,1)[$i]) { 1395 eval { "A5$i" =~ /^A$o$/ }; 1396 like($@, qr/Eval-group not allowed/, "Qr$i"); 1397 eval { "5$i" =~ /$o/ }; 1398 like($@, ($i == 3 ? qr/^$/ : qr/no method found,/), 1399 "Qr$i bare"); 1400 { 1401 use re 'eval'; 1402 ok("A5$i" =~ /^A$o$/, "Qr$i - with use re eval"); 1403 eval { "5$i" =~ /$o/ }; 1404 like($@, ($i == 3 ? qr/^$/ : qr/no method found,/), 1405 "Qr$i bare - with use re eval"); 1406 } 1407 } 1408 else { 1409 ok("A5$i" =~ /^A$o$/, "Qr$i"); 1410 ok("5$i" =~ /$o/, "Qr$i bare"); 1411 } 1412 } 1413 1414 my $o = bless [ bless [], "Qr1" ], 'Qr_indirect'; 1415 ok("A51" =~ /^A$o/, "Qr_indirect"); 1416 ok("51" =~ /$o/, "Qr_indirect bare"); 1417 } 1418 1419 { # Various flags weren't being set when a [] is optimized into an 1420 # EXACTish node 1421 ok("\x{017F}\x{017F}" =~ qr/^[$sharp_s]?$/i, "[] to EXACTish optimization"); 1422 } 1423 1424 { 1425 for my $char (":", uni_to_native("\x{f7}"), "\x{2010}") { 1426 my $utf8_char = $char; 1427 utf8::upgrade($utf8_char); 1428 my $display = $char; 1429 $display = display($display); 1430 my $utf8_display = "utf8::upgrade(\"$display\")"; 1431 1432 like($char, qr/^$char?$/, "\"$display\" =~ /^$display?\$/"); 1433 like($char, qr/^$utf8_char?$/, "my \$p = \"$display\"; utf8::upgrade(\$p); \"$display\" =~ /^\$p?\$/"); 1434 like($utf8_char, qr/^$char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); \"\$c\" =~ /^$display?\$/"); 1435 like($utf8_char, qr/^$utf8_char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); my \$p = \"$display\"; utf8::upgrade(\$p); \"\$c\" =~ /^\$p?\$/"); 1436 } 1437 } 1438 1439 { 1440 # #116148: Pattern utf8ness sticks around globally 1441 # the utf8 in the first match was sticking around for the second 1442 # match 1443 1444 use feature 'unicode_strings'; 1445 1446 my $x = "\x{263a}"; 1447 $x =~ /$x/; 1448 1449 my $text = "Perl"; 1450 ok("Perl" =~ /P.*$/i, '#116148'); 1451 } 1452 1453 { # 118297: Mixing up- and down-graded strings in regex 1454 utf8::upgrade(my $u = "\x{e5}"); 1455 utf8::downgrade(my $d = "\x{e5}"); 1456 my $warned; 1457 local $SIG{__WARN__} = sub { $warned++ if $_[0] =~ /\AMalformed UTF-8/ }; 1458 my $re = qr/$u$d/; 1459 ok(!$warned, "no warnings when interpolating mixed up-/downgraded strings in pattern"); 1460 my $c = "\x{e5}\x{e5}"; 1461 utf8::downgrade($c); 1462 like($c, $re, "mixed up-/downgraded pattern matches downgraded string"); 1463 utf8::upgrade($c); 1464 like($c, $re, "mixed up-/downgraded pattern matches upgraded string"); 1465 } 1466 1467 { 1468 # if we have 87 capture buffers defined then \87 should refer to the 87th. 1469 # test that this is true for 1..100 1470 # Note that this test causes the engine to recurse at runtime, and 1471 # hence use a lot of C stack. 1472 1473 # Compiling for all 100 nested captures blows the stack under 1474 # clang and ASan; reduce. 1475 my $max_captures = $Config{ccflags} =~ /sanitize/ ? 20 : 100; 1476 1477 for my $i (1..100) { 1478 if ($i > $max_captures) { 1479 pass("skipping $i buffers under ASan aa"); 1480 pass("skipping $i buffers under ASan aba"); 1481 next; 1482 } 1483 my $capture= "a"; 1484 $capture= "($capture)" for 1 .. $i; 1485 for my $mid ("","b") { 1486 my $str= "a${mid}a"; 1487 my $backref= "\\$i"; 1488 eval { 1489 ok($str=~/$capture$mid$backref/,"\\$i works with $i buffers '$str'=~/...$mid$backref/"); 1490 1; 1491 } or do { 1492 is("$@","","\\$i works with $i buffers works with $i buffers '$str'=~/...$mid$backref/"); 1493 }; 1494 } 1495 } 1496 } 1497 1498 # this mixture of readonly (not COWable) and COWable strings 1499 # messed up the capture buffers under COW. The actual test results 1500 # are incidental; the issue is was an AddressSanitizer failure 1501 { 1502 my $c ='AB'; 1503 my $res = ''; 1504 for ($c, 'C', $c, 'DE') { 1505 ok(/(.)/, "COWable match"); 1506 $res .= $1; 1507 } 1508 is($res, "ACAD"); 1509 } 1510 1511 1512 { 1513 # RT #45667 1514 # /[#$x]/x didn't interpolate the var $x. 1515 my $b = 'cd'; 1516 my $s = 'abcd$%#&'; 1517 $s =~ s/[a#$b%]/X/g; 1518 is ($s, 'XbXX$XX&', 'RT #45667 without /x'); 1519 $s = 'abcd$%#&'; 1520 $s =~ s/[a#$b%]/X/gx; 1521 is ($s, 'XbXX$XX&', 'RT #45667 with /x'); 1522 } 1523 1524 { 1525 no warnings "uninitialized"; 1526 my @a; 1527 $a[1]++; 1528 /@a/; 1529 pass('no crash with /@a/ when array has nonexistent elems'); 1530 } 1531 1532 { 1533 is runperl(prog => 'delete $::{qq-\cR-}; //; print qq-ok\n-'), 1534 "ok\n", 1535 'deleting *^R does not result in crashes'; 1536 no warnings 'once'; 1537 *^R = *caretRglobwithnoscalar; 1538 "" =~ /(?{42})/; 1539 is $^R, 42, 'assigning to *^R does not result in a crash'; 1540 is runperl( 1541 stderr => 1, 1542 prog => 'eval q|' 1543 .' q-..- =~ /(??{undef *^R;q--})(?{42})/; ' 1544 .' print qq-$^R\n-' 1545 .'|' 1546 ), 1547 "42\n", 1548 'undefining *^R within (??{}) does not result in a crash'; 1549 } 1550 1551 SKIP: { # Test literal range end point special handling 1552 unless ($::IS_EBCDIC) { 1553 skip "Valid only for EBCDIC", 24; 1554 } 1555 1556 like("\x89", qr/[i-j]/, '"\x89" should match [i-j]'); 1557 unlike("\x8A", qr/[i-j]/, '"\x8A" shouldnt match [i-j]'); 1558 unlike("\x90", qr/[i-j]/, '"\x90" shouldnt match [i-j]'); 1559 like("\x91", qr/[i-j]/, '"\x91" should match [i-j]'); 1560 1561 like("\x89", qr/[i-\N{LATIN SMALL LETTER J}]/, '"\x89" should match [i-\N{LATIN SMALL LETTER J}]'); 1562 unlike("\x8A", qr/[i-\N{LATIN SMALL LETTER J}]/, '"\x8A" shouldnt match [i-\N{LATIN SMALL LETTER J}]'); 1563 unlike("\x90", qr/[i-\N{LATIN SMALL LETTER J}]/, '"\x90" shouldnt match [i-\N{LATIN SMALL LETTER J}]'); 1564 like("\x91", qr/[i-\N{LATIN SMALL LETTER J}]/, '"\x91" should match [i-\N{LATIN SMALL LETTER J}]'); 1565 1566 like("\x89", qr/[i-\N{U+6A}]/, '"\x89" should match [i-\N{U+6A}]'); 1567 unlike("\x8A", qr/[i-\N{U+6A}]/, '"\x8A" shouldnt match [i-\N{U+6A}]'); 1568 unlike("\x90", qr/[i-\N{U+6A}]/, '"\x90" shouldnt match [i-\N{U+6A}]'); 1569 like("\x91", qr/[i-\N{U+6A}]/, '"\x91" should match [i-\N{U+6A}]'); 1570 1571 like("\x89", qr/[\N{U+69}-\N{U+6A}]/, '"\x89" should match [\N{U+69}-\N{U+6A}]'); 1572 unlike("\x8A", qr/[\N{U+69}-\N{U+6A}]/, '"\x8A" shouldnt match [\N{U+69}-\N{U+6A}]'); 1573 unlike("\x90", qr/[\N{U+69}-\N{U+6A}]/, '"\x90" shouldnt match [\N{U+69}-\N{U+6A}]'); 1574 like("\x91", qr/[\N{U+69}-\N{U+6A}]/, '"\x91" should match [\N{U+69}-\N{U+6A}]'); 1575 1576 like("\x89", qr/[i-\x{91}]/, '"\x89" should match [i-\x{91}]'); 1577 like("\x8A", qr/[i-\x{91}]/, '"\x8A" should match [i-\x{91}]'); 1578 like("\x90", qr/[i-\x{91}]/, '"\x90" should match [i-\x{91}]'); 1579 like("\x91", qr/[i-\x{91}]/, '"\x91" should match [i-\x{91}]'); 1580 1581 # Need to use eval, because tries to compile on ASCII platforms even 1582 # though the tests are skipped, and fails because 0x89-j is an illegal 1583 # range there. 1584 like("\x89", eval 'qr/[\x{89}-j]/', '"\x89" should match [\x{89}-j]'); 1585 like("\x8A", eval 'qr/[\x{89}-j]/', '"\x8A" should match [\x{89}-j]'); 1586 like("\x90", eval 'qr/[\x{89}-j]/', '"\x90" should match [\x{89}-j]'); 1587 like("\x91", eval 'qr/[\x{89}-j]/', '"\x91" should match [\x{89}-j]'); 1588 } 1589 1590 # These are based on looking at the code in regcomp.c 1591 # We don't look for specific code, just the existence of an SSC 1592 foreach my $re (qw( qr/a?c/ 1593 qr/a?c/i 1594 qr/[ab]?c/ 1595 qr/\R?c/ 1596 qr/\d?c/d 1597 qr/\w?c/l 1598 qr/\s?c/a 1599 qr/[[:lower:]]?c/u 1600 )) { 1601 SKIP: { 1602 skip "no re-debug under miniperl" if is_miniperl; 1603 my $prog = <<"EOP"; 1604use re qw(Debug COMPILE); 1605$re; 1606EOP 1607 fresh_perl_like($prog, qr/synthetic stclass/, { stderr=>1 }, "$re generates a synthetic start class"); 1608 } 1609 } 1610 1611 { 1612 like "\x{AA}", qr/a?[\W_]/d, "\\W with /d synthetic start class works"; 1613 } 1614 1615 SKIP: { 1616 skip("Tests are ASCII-centric, some would fail on EBCDIC", 12) if $::IS_EBCDIC; 1617 1618 # Verify that the very last Latin-1 U+00FF 1619 # (LATIN SMALL LETTER Y WITH DIAERESIS) 1620 # and its UPPER counterpart (U+0178 which is pure Unicode), 1621 # and likewise for the very first pure Unicode 1622 # (LATIN CAPITAL LETTER A WITH MACRON) fold-match properly, 1623 # and there are no off-by-one logic errors in the transition zone. 1624 1625 ok("\xFF" =~ /\xFF/i, "Y WITH DIAERESIS l =~ l"); 1626 ok("\xFF" =~ /\x{178}/i, "Y WITH DIAERESIS l =~ u"); 1627 ok("\x{178}" =~ /\xFF/i, "Y WITH DIAERESIS u =~ l"); 1628 ok("\x{178}" =~ /\x{178}/i, "Y WITH DIAERESIS u =~ u"); 1629 1630 # U+00FF with U+05D0 (non-casing Hebrew letter). 1631 ok("\xFF\x{5D0}" =~ /\xFF\x{5D0}/i, "Y WITH DIAERESIS l =~ l"); 1632 ok("\xFF\x{5D0}" =~ /\x{178}\x{5D0}/i, "Y WITH DIAERESIS l =~ u"); 1633 ok("\x{178}\x{5D0}" =~ /\xFF\x{5D0}/i, "Y WITH DIAERESIS u =~ l"); 1634 ok("\x{178}\x{5D0}" =~ /\x{178}\x{5D0}/i, "Y WITH DIAERESIS u =~ u"); 1635 1636 # U+0100. 1637 ok("\x{100}" =~ /\x{100}/i, "A WITH MACRON u =~ u"); 1638 ok("\x{100}" =~ /\x{101}/i, "A WITH MACRON u =~ l"); 1639 ok("\x{101}" =~ /\x{100}/i, "A WITH MACRON l =~ u"); 1640 ok("\x{101}" =~ /\x{101}/i, "A WITH MACRON l =~ l"); 1641 } 1642 1643 { 1644 use utf8; 1645 ok("abc" =~ /a…b…c/x, "NEL is white-space under /x"); 1646 } 1647 1648 { 1649 ok('a(b)c' =~ qr(a\(b\)c), "'\\(' is a literal in qr(...)"); 1650 ok('a[b]c' =~ qr[a\[b\]c], "'\\[' is a literal in qr[...]"); 1651 ok('a{3}c' =~ qr{a\{3\}c}, # Only failed when { could be a meta 1652 "'\\{' is a literal in qr{...}, where it could be a quantifier"); 1653 1654 # This one is for completeness 1655 ok('a<b>c' =~ qr<a\<b\>c>, "'\\<' is a literal in qr<...>)"); 1656 } 1657 1658 { # Was getting optimized into EXACT (non-folding node) 1659 my $x = qr/[x]/i; 1660 utf8::upgrade($x); 1661 like("X", qr/$x/, "UTF-8 of /[x]/i matches upper case"); 1662 } 1663 1664SKIP: { # make sure we get an error when \p{} cannot load Unicode tables 1665 skip("Unicode tables always now loaded", 1); 1666 fresh_perl_like(<<' prog that cannot load uni tables', 1667 BEGIN { 1668 @INC = '../lib'; 1669 require utf8; require 'utf8_heavy.pl'; 1670 @INC = (); 1671 } 1672 $name = 'A B'; 1673 if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){ 1674 print "It's good! >$1< >$2<\n"; 1675 } else { 1676 print "It's not good...\n"; 1677 } 1678 prog that cannot load uni tables 1679 qr/^Can't locate unicore\/Heavy\.pl(?x: 1680 )|^Can't find Unicode property definition/, 1681 undef, 1682 '\p{} should not fail silently when uni tables evanesce'); 1683 } 1684 1685 { # Special handling of literal-ended ranges in [...] was breaking this 1686 use utf8; 1687 like("ÿ", qr/[ÿ-ÿ]/, "\"ÿ\" should match [ÿ-ÿ]"); 1688 } 1689 1690 { # [perl #123539] 1691 like("TffffffffffffTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff", qr/TffffffffffffTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff/il, ""); 1692 like("TffffffffffffT\x{100}TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff", qr/TffffffffffffT\x{100}TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff/il, ""); 1693 } 1694 1695 { # [perl #123604] 1696 my($s, $x, @x) = ('abc', 'a', 'd'); 1697 my $long = 'b' x 2000; 1698 my $eval = q{$s =~ m{$x[bbb]c} ? 1 : 0}; 1699 $eval =~ s{bbb}{$long}; 1700 my $match = eval $eval; 1701 ok(1, "did not crash"); 1702 ok($match, "[bbb...] resolved as character class, not subscript"); 1703 } 1704 1705 { # [perl #123755] 1706 for my $pat ('(??', '(?P', '(?i-') { 1707 eval qq{ qr/$pat/ }; 1708 ok(1, "qr/$pat/ did not crash"); 1709 eval qq{ qr/${pat}\x{123}/ }; 1710 my $e = $@; 1711 like($e, qr{\x{123}}, 1712 "qr/${pat}x/ shows x in error even if it's a wide character"); 1713 } 1714 } 1715 1716 { 1717 # Expect one of these sizes to cause overflow and wrap to negative 1718 for my $bits (32, 64) { 1719 my $wrapneg = 2 ** ($bits - 2) * 3; 1720 for my $sign ('', '-') { 1721 my $pat = sprintf "qr/(?%s%u)/", $sign, $wrapneg; 1722 eval $pat; 1723 ok(1, "big backref $pat did not crash"); 1724 } 1725 } 1726 } 1727 { 1728 # Test that we handle qr/\8888888/ and variants without an infinite loop, 1729 # we use a test within a test so we can todo it, and make sure we don't 1730 # infinite loop our tests. 1731 # NOTE - Do not put quotes in the code! 1732 # NOTE - We have to triple escape the backref in the pattern below. 1733 my $code=' 1734 BEGIN{require q(./test.pl);} 1735 watchdog(3); 1736 for my $len (1 .. 20) { 1737 my $eights= q(8) x $len; 1738 eval qq{ qr/\\\\$eights/ }; 1739 } 1740 print q(No infinite loop here!); 1741 '; 1742 fresh_perl_is($code, "No infinite loop here!", {}, 1743 "test that we handle things like m/\\888888888/ without infinite loops" ); 1744 } 1745 1746 { # Test that we handle some malformed UTF-8 without looping [perl 1747 # #123562] 1748 1749 my $code=' 1750 BEGIN{require q(./test.pl);} 1751 use Encode qw(_utf8_on); 1752 # \x80 and \x41 are continuation bytes in their respective 1753 # character sets 1754 my $malformed = (ord("A") == 65) ? "a\x80\n" : "a\x41\n"; 1755 utf8::downgrade($malformed); 1756 _utf8_on($malformed); 1757 watchdog(3); 1758 $malformed =~ /(\n\r|\r)$/; 1759 print q(No infinite loop here!); 1760 '; 1761 fresh_perl_like($code, qr/Malformed UTF-8 character/, {}, 1762 "test that we handle some UTF-8 malformations without looping" ); 1763 } 1764 1765 { 1766 # [perl #123843] hits SEGV trying to compile this pattern 1767 my $match; 1768 eval q{ ($match) = ("xxyxxyxy" =~ m{(x+(y(?1))*)}) }; 1769 ok(1, "compiled GOSUB in CURLYM ok"); 1770 is($match, 'xxyxxyx', "matched GOSUB in CURLYM"); 1771 } 1772 1773 { 1774 # [perl #123852] doesn't avoid all the capture-related work with 1775 # //n, leading to possible memory corruption 1776 eval q{ qr{()(?1)}n }; 1777 my $error = $@; 1778 ok(1, "qr{()(?1)}n didn't crash"); 1779 like($error, qr{Reference to nonexistent group}, 1780 'gave appropriate error for qr{()(?1)}n'); 1781 } 1782 1783 { 1784 # [perl #126406] panic with unmatchable quantifier 1785 my $code=' 1786 no warnings "regexp"; 1787 "" =~ m/(.0\N{6,0}0\N{6,0}000000000000000000000000000000000)/; 1788 '; 1789 fresh_perl_is($code, "", {}, 1790 "perl [#126406] panic"); 1791 } 1792 { 1793 my $bug="[perl #126182]"; # test for infinite pattern recursion 1794 for my $tuple ( 1795 [ 'q(a)=~/(.(?2))((?<=(?=(?1)).))/', "died", "look ahead left recursion fails fast" ], 1796 [ 'q(aa)=~/(?R)a/', "died", "left-recursion fails fast", ], 1797 [ 'q(bbaa)=~/(?&x)(?(DEFINE)(?<x>(?&y)*a)(?<y>(?&x)*b))/', 1798 "died", "inter-cyclic optional left recursion dies" ], 1799 [ 'q(abc) =~ /a((?1)?)c/', "died", "optional left recursion dies" ], 1800 [ 'q(abc) =~ /a((?1)??)c/', "died", "min mod left recursion dies" ], 1801 [ 'q(abc) =~ /a((?1)*)c/', "died", "* left recursion dies" ], 1802 [ 'q(abc) =~ /a((?1)+)c/', "died", "+ left recursion dies" ], 1803 [ 'q(abc) =~ /a((?1){0,3})c/', "died", "{0,3} left recursion fails fast" ], 1804 1805 [ 'q(aaabbb)=~/a(?R)?b/', "matched", "optional self recursion works" ], 1806 [ '"((5maa-maa)(maa-3maa))" =~ /(\\\\((?:[^()]++|(?0))*+\\\\))/', "matched", 1807 "recursion and possessive captures", "((5maa-maa)(maa-3maa))"], 1808 [ '"((5maa-maa)(maa-3maa))" =~ /(\\\\((?:[^()]++|(?1))*+\\\\))/', "matched", 1809 "recursion and possessive captures", "((5maa-maa)(maa-3maa))"], 1810 [ '"((5maa-maa)(maa-3maa))" =~ /(\\\\((?:[^()]+|(?0))*\\\\))/', "matched", 1811 "recursion and possessive captures", "((5maa-maa)(maa-3maa))"], 1812 [ '"((5maa-maa)(maa-3maa))" =~ /(\\\\((?:[^()]+|(?1))*\\\\))/', "matched", 1813 "recursion and possessive captures", "((5maa-maa)(maa-3maa))"], 1814 ) { 1815 my ($expr, $expect, $test_name, $cap1)= @$tuple; 1816 # avoid quotes in this code! 1817 my $code=' 1818 BEGIN{require q(./test.pl);} 1819 watchdog(3); 1820 my $status= eval(q{ !(' . $expr . ') ? q(failed) : ' . 1821 ($cap1 ? '($1 ne q['.$cap1.']) ? qq(badmatch:$1) : ' : '') . 1822 ' q(matched) }) 1823 || ( ( $@ =~ /Infinite recursion/ ) ? qq(died) : q(strange-death) ); 1824 print $status; 1825 '; 1826 fresh_perl_is($code, $expect, {}, "$bug - $test_name" ); 1827 } 1828 } 1829 { 1830 fresh_perl_is(' 1831 BEGIN{require q(test.pl);} 1832 watchdog(3); 1833 $SIG{ALRM} = sub {print "Timeout\n"; exit(1)}; 1834 alarm 1; 1835 $_ = "a" x 1000 . "b" x 1000 . "c" x 1000; 1836 /.*a.*b.*c.*[de]/; 1837 ',"Timeout",{},"Test Perl 73464") 1838 } 1839 1840 { # [perl #128686], crashed the the interpreter 1841 my $AE = chr utf8::unicode_to_native(0xC6); 1842 my $ae = chr utf8::unicode_to_native(0xE6); 1843 my $re = qr/[$ae\s]/i; 1844 ok($AE !~ $re, '/[\xE6\s]/i doesn\'t match \xC6 when not in UTF-8'); 1845 utf8::upgrade $AE; 1846 ok($AE =~ $re, '/[\xE6\s]/i matches \xC6 when in UTF-8'); 1847 } 1848 1849 { 1850 is(0+("\n" =~ m'\n'), 1, q|m'\n' should interpolate escapes|); 1851 } 1852 1853 { 1854 my $str = "a\xB6"; 1855 ok( $str =~ m{^(a|a\x{b6})$}, "fix [perl #129950] - latin1 case" ); 1856 utf8::upgrade($str); 1857 ok( $str =~ m{^(a|a\x{b6})$}, "fix [perl #129950] - utf8 case" ); 1858 } 1859 { 1860 my $got= run_perl( switches => [ '-l' ], prog => <<'EOF_CODE' ); 1861 my $died= !eval { 1862 $_=qq(ab); 1863 print; 1864 my $p=qr/(?{ s!!x! })/; 1865 /$p/; 1866 print; 1867 /a/; 1868 /$p/; 1869 print; 1870 /b/; 1871 /$p/; 1872 print; 1873 //; 1874 1; 1875 }; 1876 $error = $died ? ($@ || qq(Zombie)) : qq(none); 1877 print $died ? qq(died) : qq(lived); 1878 print qq(Error: $@); 1879EOF_CODE 1880 my @got= split /\n/, $got; 1881 is($got[0],"ab","empty pattern in regex codeblock: got expected start string"); 1882 is($got[1],"xab", 1883 "empty pattern in regex codeblock: first subst with no last-match worked right"); 1884 is($got[2],"xxb","empty pattern in regex codeblock: second subst worked right"); 1885 is($got[3],"xxx","empty pattern in regex codeblock: third subst worked right"); 1886 is($got[4],"died","empty pattern in regex codeblock: died as expected"); 1887 like($got[5],qr/Error: Infinite recursion via empty pattern/, 1888 "empty pattern in regex codeblock: produced the right exception message" ); 1889 } 1890 1891 # This test is based on the one directly above, which happened to 1892 # leak. Repeat the test, but stripped down to the bare essentials 1893 # of the leak, which is to die while executing a regex which is 1894 # already the current regex, thus causing the saved outer set of 1895 # capture offsets to leak. The test itself doesn't do anything 1896 # except sit around hoping not to be triggered by ASan 1897 { 1898 eval { 1899 my $s = "abcd"; 1900 $s =~ m{([abcd]) (?{ die if $1 eq 'd'; })}gx; 1901 $s =~ //g; 1902 $s =~ //g; 1903 $s =~ //g; 1904 }; 1905 pass("call to current regex doesn't leak"); 1906 } 1907 1908 1909 1910 { 1911 # [perl #130495] /x comment skipping stopped a byte short, leading 1912 # to assertion failure or 'malformed utf-8 character" warning 1913 fresh_perl_is( 1914 "use utf8; m{a#\x{124}}x", '', {wide_chars => 1}, 1915 '[perl #130495] utf-8 character at end of /x comment should not misparse', 1916 ); 1917 } 1918 { 1919 # [perl #130522] causes out-of-bounds read detected by clang with 1920 # address=sanitized when length of the STCLASS string is greater than 1921 # length of target string. 1922 my $re = qr{(?=\0z)\0?z?$}i; 1923 my($yes, $no) = (1, ""); 1924 for my $test ( 1925 [ $no, undef, '<undef>' ], 1926 [ $no, '', '' ], 1927 [ $no, "\0", '\0' ], 1928 [ $yes, "\0z", '\0z' ], 1929 [ $no, "\0z\0", '\0z\0' ], 1930 [ $yes, "\0z\n", '\0z\n' ], 1931 ) { 1932 my($result, $target, $disp) = @$test; 1933 no warnings qw/uninitialized/; 1934 is($target =~ $re, $result, "[perl #130522] with target '$disp'"); 1935 } 1936 } 1937 { 1938 # [perl #129377] backref to an unmatched capture should not cause 1939 # reading before start of string. 1940 SKIP: { 1941 skip "no re-debug under miniperl" if is_miniperl; 1942 my $prog = <<'EOP'; 1943use re qw(Debug EXECUTE); 1944"x" =~ m{ () y | () \1 }x; 1945EOP 1946 fresh_perl_like($prog, qr{ 1947 \A (?! .* ^ \s+ - ) 1948 }msx, { stderr => 1 }, "Offsets in debug output are not negative"); 1949 } 1950 } 1951 { 1952 # buffer overflow 1953 1954 # This test also used to leak - fixed by the commit which added 1955 # this line. 1956 1957 fresh_perl_is("BEGIN{\$^H=0x200000}\ns/[(?{//xx", 1958 "Unmatched [ in regex; marked by <-- HERE in m/[ <-- HERE (?{/ at (eval 1) line 1.\n", 1959 {}, "buffer overflow for regexp component"); 1960 } 1961 { 1962 # [perl #129281] buffer write overflow, detected by ASAN, valgrind 1963 fresh_perl_is('/0(?0)|^*0(?0)|^*(^*())0|/', '', {}, "don't bump whilem_c too much"); 1964 } 1965 { 1966 # RT #131893 - fails with ASAN -fsanitize=undefined 1967 fresh_perl_is('qr/0(0?(0||00*))|/', '', {}, "integer overflow during compilation"); 1968 } 1969 1970 { 1971 # RT #131575 intuit skipping back from the end to find the highest 1972 # possible start point, was potentially hopping back beyond pos() 1973 # and crashing by calling fbm_instr with a negative length 1974 1975 my $text = "=t=\x{5000}"; 1976 pos($text) = 3; 1977 ok(scalar($text !~ m{(~*=[a-z]=)}g), "RT #131575"); 1978 } 1979 { 1980 fresh_perl_is('"AA" =~ m/AA{1,0}/','',{},"handle OPFAIL insert properly"); 1981 } 1982 { 1983 fresh_perl_is('$_="0\x{1000000}";/^000?\0000/','',{},"dont throw assert errors trying to fbm past end of string"); 1984 } 1985 { # [perl $132227] 1986 fresh_perl_is("('0ba' . ('ss' x 300)) =~ m/0B\\N{U+41}" . $sharp_s x 150 . '/i and print "1\n"', 1,{},"Use of sharp s under /di that changes to /ui"); 1987 1988 # A variation, but as far as khw knows not part of 132227 1989 fresh_perl_is("'0bssa' =~ m/0B" . $sharp_s . "\\N{U+41}" . '/i and print "1\n"', 1,{},"Use of sharp s under /di that changes to /ui"); 1990 } 1991 { # [perl $132164] 1992 fresh_perl_is('m m0*0+\Rm', "",{},"Undefined behavior in address sanitizer"); 1993 } 1994 { # [perl #133642] 1995 fresh_perl_is('no warnings "experimental::vlb"; 1996 m/((?<=(0?)))/', "",{},"Was getting 'Double free'"); 1997 } 1998 { # [perl #133782] 1999 # this would panic on DEBUGGING builds 2000 fresh_perl_is(<<'CODE', "ok\nok\n",{}, 'Bad length magic was left on $^R'); 2001while( "\N{U+100}bc" =~ /(..?)(?{$^N})/g ) { 2002 print "ok\n" if length($^R)==length("$^R"); 2003} 2004CODE 2005 } 2006 { # [perl #133871], ASAN/valgrind out-of-bounds access 2007 fresh_perl_like('qr/(?|(())|())|//', qr/syntax error/, {}, "[perl #133871]"); 2008 } 2009 { # [perl #133871], ASAN/valgrind out-of-bounds access 2010 fresh_perl_like('qr/\p{nv:NAnq}/', qr/Can't find Unicode property definition/, {}, "GH #17367"); 2011 } 2012 { # GH #17370, ASAN/valgrind out-of-bounds access 2013 fresh_perl_like('qr/\p{nv:qnan}/', qr/Can't find Unicode property definition/, {}, "GH #17370"); 2014 } 2015 2016 { # [perl #133921], segfault 2017 fresh_perl_is('qr0||ß+p00000F00000ù\Q00000ÿ00000x00000x0c0e0\Qx0\Qx0\x{0c!}\;\;î0\x�ÿÿÿþ���ù\Q`\Qx`�{0c!}e;���ù\ò`\Qm`\x{0c!}\;\;îçÿ �ç���!�F��/;îçÿù\Q���xÿÿÿÿ���ù���`x{0c!}e;���ù\Q`\Qx`\x{c!}\;\;îç!}\;îçÿù\Q‡ \x�ÿÿÿÿ��>=\Qx`\Qx`��ù\ò`\Qx`\x{0c!};\;îçÿ �F�n0t0�c �€d;t ���ù �ç€��!00000000000000000000000m/0000000000000000000000000000000m/\x{){} )|i', "", {}, "[perl #133921]"); 2018 fresh_perl_is('|ß+W0ü0r0\Qx0\Qx0x0c0G00000000000000000O000000000x0x0x0c!}\;îçÿù\Q0 \x�ÿÿÿÿ���ù\Q`\Qx`�{0d ;���ù\ò`\Qm`\x{0c!}\;\;îçÿ �ç���!�F��/;îçÿù\Q���xÿÿÿÿ���ù���`x{0c!};���ù\Q`\Qq`\x{c!}\;\;îç!}\;îçÿù\Q‡ \x�ÿÿÿÿ��>=\Qx`\Qx`��ù\ò`\Qx`\x{0c!};\;îçÿ �0000000F�m0t0�c �€d;t ���ù �ç€��!00000000000000000000000m/0000000000000000000000000000000m/\x{){} )|i', "", {}, "[perl #133921]"); 2019 2020fresh_perl_is('s|ß+W0ü0f0\Qx0\Qx0x0c0G0xgive0000000000000O0h000x0 \xòÿÿÿ��ù\Q`\Q 2021 2022 2023 2024 2025 ç 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041x{0c!}\;\;çÿ �q0/i0/!�F��/;îçÿù\Q���xÿÿÿÿ���ù���`x{0c!}e;���ù\Q`\Qx`\x{0c!}\;ÿÿÿÿ!}\;îçÿù\Q‡\x�ÿÿÿÿ��>=\Qx`\Qx`��ù\ò`ÿ��>=\Qx`\Qx`��ù\ò`\Qx`\x{0c!};\;îçÿ �u00000F�000t0�p �€d? ���ù �ç€��!00000000000000000000000m/0000000000000000000000000000000m/0�\���} )|i', "", {}, "[perl #133921]"); 2042 2043 fresh_perl_is('a aú��úv sWtrt�\ó||ß+Wüef�ù\Qx`\Qx`\x{1c!gGnuc given1111111111111O1111each111\jx` \x�òÿÿÿ���ù\Qx`\Q 2044 2045 2046 2047 2048 2049 ç 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065x{1c!}\;\;îçÿp �qr/elsif/!�eF��/;îçÿù\Q���xÿÿÿÿ���ùHQx���`Lx{1c!}e;���ù\Qx`\Qx`\x{1c!}\;ÿÿÿÿc!}\;îçÿù\Qx‡\x�ÿÿÿÿ��>=\Qx`\Qx`��ù\òx`ÿ��>=\Qx`\Qx`��ù\òx`\Qx`\x{1c!}8;\;îçÿp �unshifteF�normat0�cmp �€d?not ���ùp �ç€��!0000000000000000000000000m/00000000000000000000000000000000m/0R�\���} )|\aï||K??p€¿ÿÿfúd{\{gri{\x{1x/}� ð¹NuntiÀh', "", {}, "[perl #133921]"); 2066 2067 fresh_perl_is('s|ß+W0ü0f0\Qx0\Qx0x0c0g0c 000n0000000000000O0h000x0 \xòÿÿÿ��ù\Q`\Q 2068 2069 2070 2071 2072 2073 ç 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089x{0c!}\;\;îçÿ �/0f/!�F��/;îçÿù\Q���xÿÿÿÿ���ù���`x{0c!};���ù\Q`\Qx`\x{0c!}\;ÿÿÿÿ!}\;îçÿù\Q‡\x�ÿÿÿÿ��>=\Qx`\Qx`��ù\ò`ÿ��>=\Qx`\Qx`��ù\ò`\Qx`\x{0c!};\;îçÿ �000t0F�000t0�p �€d?n ���ù �ç€��!00000000000000000000000m/0000000000000000000000000000000m/�\���} )|i', "", {}, "[perl #133933]"); 2090 } 2091 2092 { # perl #133998] 2093 fresh_perl_is('print "\x{110000}" =~ qr/(?l)|[^\S\pC\s]/', 1, {}, 2094 '/[\S\s]/l works'); 2095 } 2096 2097 { # perl #133995] 2098 use utf8; 2099 fresh_perl_is('"έδωσαν ελληνικήვე" =~ m/[^0](?=0)0?/', "", 2100 {wide_chars => 1}, 2101 '[^0] doesnt crash on UTF-8 target string'); 2102 } 2103 2104 { # [perl #133992] This is a tokenizer bug of parsing a pattern 2105 fresh_perl_is(q:$z = do { 2106 use utf8; 2107 "q!теÑÑ‚! =~ m'" 2108 }; 2109 $z .= 'è(?#„'; 2110 $z .= "'"; 2111 eval $z;:, "", {}, 'foo'); 2112 } 2113 2114 { # [perl #134325] 2115 my $quote="\\Q"; 2116 my $back="\\\\"; 2117 my $ff="\xff"; 2118 my $s = sprintf "/\\1|(|%s)%s%s /i", 2119 $quote x 8 . $back x 69, 2120 $quote x 5 . $back x 4, 2121 $ff x 48; 2122 like(runperl(prog => "$s", stderr => 1), qr/Unmatched \(/); 2123 } 2124 2125SKIP: 2126 { # [perl #134334], Assertion failure 2127 my $utf8_locale = find_utf8_ctype_locale(); 2128 skip "no UTF-8 locale available" unless $utf8_locale; 2129 fresh_perl_like("use POSIX; POSIX::setlocale(&LC_CTYPE, '$utf8_locale'); 'ssss' =~ /\xDF+?sX/il;", 2130 qr/^$/, 2131 {}, 2132 "Assertion failure matching /il on single char folding to multi"); 2133 } 2134 2135 # gh17490: test recursion check 2136 { 2137 my $eval = '(?{1})'; 2138 my $re = sprintf '(?&FOO)(?(DEFINE)(?<FOO>%sfoo))', $eval x 20; 2139 my $result = eval qq{"foo" =~ /$re/}; 2140 is($@ // '', '', "many evals did not die"); 2141 ok($result, "regexp correctly matched"); 2142 } 2143 2144 # gh16947: test regexp corruption (GOSUB) 2145 { 2146 fresh_perl_is(q{ 2147 'xy' =~ /x(?0)|x(?|y|y)/ && print 'ok' 2148 }, 'ok', {}, 'gh16947: test regexp corruption (GOSUB)'); 2149 } 2150 # gh16947: test fix doesn't break SUSPEND 2151 { 2152 fresh_perl_is(q{ 'sx' =~ m{ss++}i; print 'ok' }, 2153 'ok', {}, "gh16947: test fix doesn't break SUSPEND"); 2154 } 2155 2156 # gh17743: more regexp corruption via GOSUB 2157 { 2158 fresh_perl_is(q{ 2159 "0" =~ /((0(?0)|000(?|0000|0000)(?0))|)/; print "ok" 2160 }, 'ok', {}, 'gh17743: test regexp corruption (1)'); 2161 2162 fresh_perl_is(q{ 2163 "000000000000" =~ /(0(())(0((?0)())|000(?|\x{ef}\x{bf}\x{bd}|\x{ef}\x{bf}\x{bd}))|)/; 2164 print "ok" 2165 }, 'ok', {}, 'gh17743: test regexp corruption (2)'); 2166 } 2167 2168} # End of sub run_tests 2169 21701; 2171 2172# 2173# ex: set ts=8 sts=4 sw=4 et: 2174# 2175