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.
18 require Config; import Config;
19 require './test.pl'; require './charset_tools.pl';
20 require './loc_tools.pl';
21 set_up_inc('../lib', '.', '../ext/re');
24 skip_all('no re module') unless defined &DynaLoader::boot_DynaLoader;
25 skip_all_without_unicode_tables();
27 plan tests => 857; # Update this when adding/deleting tests.
29 run_tests() unless caller;
36 my $sharp_s = uni_to_native("\xdf");
40 (my $x_pretty = $x) =~ s/\n/\\n/g;
42 ok $x =~ /^abc/, qq ["$x_pretty" =~ /^abc/];
43 ok $x !~ /^def/, qq ["$x_pretty" !~ /^def/];
45 # used to be a test for $*
46 ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m];
48 ok(!($x =~ /^xxx/), qq ["$x_pretty" =~ /^xxx/]);
49 ok(!($x !~ /^abc/), qq ["$x_pretty" !~ /^abc/]);
51 ok $x =~ /def/, qq ["$x_pretty" =~ /def/];
52 ok(!($x !~ /def/), qq ["$x_pretty" !~ /def/]);
54 ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/];
55 ok(!($x =~ /.def/), qq ["$x_pretty" =~ /.def/]);
57 ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/];
58 ok(!($x !~ /\ndef/), qq ["$x_pretty" !~ /\\ndef/]);
63 ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/];
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+/]);
74 ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/];
75 ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/];
78 ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/];
79 unlike($_, qr/a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]);
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 [\$_ = '$_'; /^\$_\$/];
89 # used to be a test for $*
90 ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m];
94 our %XXX = map {($_ => $_)} 123, 234, 345;
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;
100 is($r, $e, "?(.*)?");
116 ok !keys %XXX, "%XXX is empty";
122 my $message = "Test empty pattern";
128 is($&, $xyz, $message);
133 is($&, $xyz, $message);
137 no warnings 'uninitialized';
139 is($&, $xyz, $message);
143 is($&, $xyz, $message);
145 # each entry: regexp, match string, $&, //o match success
148 [ "", "xy", "x", 1 ],
149 [ "y", "yz", "y", !1 ],
151 for my $test (@tests) {
152 my ($re, $str, $matched, $omatch) = @$test;
154 ok($str =~ /$re/, "$str matches /$re/");
155 is($&, $matched, "on $matched");
157 is($str =~ /$re/o, $omatch, "$str matches /$re/o (or not)");
162 my $message = q !Check $`, $&, $'!;
164 /def/; # optimized up to cmd
165 is("$`:$&:$'", 'abc:def:ghi', $message);
168 /cde/ + 0; # optimized only to spat
169 is("$`:$&:$'", 'ab:cde:fghi', $message);
171 /[d][e][f]/; # not optimized
172 is("$`:$&:$'", 'abc:def:ghi', $message);
176 $_ = 'now is the {time for all} good men to come to.';
178 is($1, 'time for all', "Match braces");
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);
196 my $message = "Test /g";
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";
202 is("@words", $exp, $message);
208 is("@words", $exp, $message);
215 is("@words", "to:to", $message);
219 is("@words", "to:to", $message);
235 my $t1 = my $t2 = my $t3 = my $t4 = my $t5 =
236 my $t6 = my $t7 = my $t8 = my $t9 = 0;
238 for my $iter (1 .. 5) {
249 my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
250 is($x, '505550555', "Test /o");
255 ok "abc" =~ /^abc$|$xyz/, "| after \$";
257 # perl 4.009 says "unmatched ()"
258 my $message = '$ inside ()';
261 eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
262 is($@, "", $message);
263 is($result, "abc:bc", $message);
267 my $message = "Scalar /g";
270 ok( /abc/g && $` eq "", $message);
271 ok( /abc/g && $` eq "abcfoo", $message);
272 ok(!/abc/g, $message);
274 $message = "Scalar /gi";
276 ok( /ABC/gi && $` eq "", $message);
277 ok( /ABC/gi && $` eq "abcfoo", $message);
278 ok(!/ABC/gi, $message);
280 $message = "Scalar /g";
282 ok( /abc/g && $' eq "fooabcbar", $message);
283 ok( /abc/g && $' eq "bar", $message);
287 is(@x, 2, "/g reset after assignment");
291 my $message = '/g, \G and pos';
295 is(pos $_, 2, $message);
297 is(pos $_, undef, $message);
301 my $message = '(?{ })';
303 'abc' =~ m'a(?{ $out = 2 })b';
304 is($out, 2, $message);
307 'abc' =~ m'a(?{ $out = 3 })c';
308 is($out, 1, $message);
312 $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
313 my @out = /(?<!foo)bar./g;
314 is("@out", 'bar2 barf', "Negative lookbehind");
318 my $message = "REG_INFTY tests";
319 # Tests which depend on REG_INFTY
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.
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.
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);
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);
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");
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";
359 for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
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);
366 like("ba$a=", qr/b(?:a|b)+=/, $message);
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
385 my $message = "20000 nodes, const-len '$_'";
386 ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o), $message;
388 $message = "20000 nodes, var-len '$_'";
389 ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o,), $message;
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)";
403 (?{ $c = 1 }) # Initialize
405 (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop
407 ) # Fail: will unwind one iteration back
410 [^()]+ # Match a big chunk
413 ) # Do not try to match subchunks
421 )+ # This may not match with different subblocks
426 ) # Otherwise the chunk 1 may succeed with $c>0
432 push @ans, $res while $res = matchit;
433 is("@ans", "1 1 1", $message);
436 is("@ans", $expect, $message);
438 $message = "Recursion with (??{ })";
440 $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/;
442 @ans = my @ans1 = ();
443 push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g;
445 is("@ans", "1 1 1", $message);
446 is("@ans1", $expect, $message);
449 is("@ans", $expect, $message);
454 ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/';
458 my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad
459 is("@ans", 'a/ b', "Stack may be bad");
463 my $message = "Eval-group not allowed at runtime";
464 my $code = '{$blah = 45}';
467 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message);
470 my $res = eval { "xx" =~ /(?$code)/o };
472 no warnings 'uninitialized';
473 chomp $@; my $message = "$message '$@', '$res', '$blah'";
474 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message);
479 $res = eval { "xx" =~ /(?$code)/o };
481 no warnings 'uninitialized';
482 my $message = "$message '$@', '$res', '$blah'";
483 ok(!$@ && $res, $message);
486 $code = '{$blah = 45}';
489 is($blah, 45, $message);
493 is($blah, 45, $message);
497 my $message = "Pos checks";
500 is(pos $x, 2, $message);
503 is(pos $x, 2, $message);
511 is(f (pos $x), 4, $message);
515 my $message = 'Checking $^R';
517 'foot' =~ /foo(?{$x = 12; 75})[t]/;
518 is($^R, 75, $message);
521 'foot' =~ /foo(?{$x = 12; 75})[xy]/;
522 ok($^R eq '67' && $x eq '12', $message);
525 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
526 ok($^R eq '79' && $x eq '12', $message);
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$/');
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');
545 my $dual = qr/\b\v$/;
549 skip 'Locales not available', 1 unless locales_enabled('LC_CTYPE');
553 is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale');
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');
563 skip 'Locales not available', 1 unless locales_enabled('LC_CTYPE');
565 is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings');
568 no feature 'unicode_strings';
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');
574 is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings');
577 skip 'Locales not available', 2 unless locales_enabled('LC_CTYPE');
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');
586 my $message = "Look around";
588 foreach my $ans ('', 'c') {
589 ok(/(?<=(?=a)..)((?=c)|.)/g, $message);
590 is($1, $ans, $message);
595 my $message = "Empty clause";
597 foreach my $ans ('', 'a', '') {
598 ok(/^|a|$/g, $message);
599 is($&, $ans, $message);
605 my $message = "Prefixify";
607 my ($v, $a, $b, $res) = @_;
608 ok($v =~ s/\Q$a\E/$b/, $message);
609 is($v, $res, $message);
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');
620 ok $1 && /$1/, "Capture a quote";
624 no warnings 'closure';
625 my $message = '(?{ $var } refers to package vars';
629 '' =~ /(?{ $c = 4 })/;
630 main::is($c, 4, $message);
631 main::is($::c, 3, $message);
635 is(eval 'q(a:[b]:) =~ /[x[:foo:]]/', undef);
636 like ($@, qr/POSIX class \[:[^:]+:\] unknown in regex/,
637 'POSIX class [: :] must have valid name');
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");
647 # test if failure of patterns returns empty list
648 my $message = "Failed pattern returns empty list";
651 is("@_", "", $message);
654 is("@_", "", $message);
657 is("@_", "", $message);
660 is("@_", "", $message);
664 my $message = '@- and @+ and @{^CAPTURE} tests';
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);
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);
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);
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);
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);
741 is($#{^CAPTURE}, 0, $message); # one less than $#-
742 is($#+, 2, $message);
743 is($#-, 1, $message);
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.)
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';
755 foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)',
756 '${^CAPTURE}[0] = 13',
757 '@- = qw (foo bar)', '$^N = 42') {
759 like($@, qr/^Modification of a read-only value attempted/,
760 '$^N, @- and @+ are read-only');
764 my $message = '\G testing';
768 is("@a", "a a", $message);
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);
782 my $message = '\G and intuit and anchoring';
785 ok($_ =~ /\Gabc/, $message);
786 ok($_ =~ /^\Gabc/, $message);
789 ok($_ =~ /\Gdef/, $message);
791 ok($_ =~ /\Gdef$/, $message);
793 ok($_ =~ /abc\Gdef$/, $message);
795 ok($_ =~ /^abc\Gdef$/, $message);
797 ok($_ =~ /c\Gd/, $message);
799 ok($_ =~ /..\GX?def/, $message);
805 my @a = $s =~ /(\d)\G/g; # this infinitely looped up till 5.19.1
806 is("@a", "1", '\G looping');
811 my $message = 'pos inside (?{ })';
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);
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);
830 like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message);
831 is($foo, $str, $message);
832 is($bar, 2, $message);
836 ok(/b(?{$foo = $_; $bar = pos})c/g, $message);
837 is($foo, $str, $message);
838 is($bar, 2, $message);
839 is(pos, 3, $message);
844 1 while /b(?{$foo = $_; $bar = pos})c/g;
845 is($foo, $str, $message);
846 is($bar, 2, $message);
847 is(pos, undef, $message);
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);
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);
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);
875 my $message = '\G anchor checks';
876 my $foo = 'aabbccddeeffgg';
879 ok($foo =~ /.\G(..)/g, $message);
880 is($1, 'ab', $message);
883 ok($foo =~ /.\G(..)/g, $message);
884 is($1, 'cc', $message);
887 ok($foo =~ /.\G(..)/g, $message);
888 is($1, 'de', $message);
890 ok($foo =~ /\Gef/g, $message);
893 ok($foo =~ /\G(..)/g, $message);
894 is($1, 'aa', $message);
896 ok($foo =~ /\G(..)/g, $message);
897 is($1, 'bb', $message);
900 ok($foo =~ /\G(..)/g, $message);
901 is($1, 'cd', $message);
905 my $message = 'basic \G floating checks';
906 my $foo = 'aabbccddeeffgg';
909 ok($foo =~ /a+\G(..)/g, "$message: a+\\G");
910 is($1, 'ab', "$message: ab");
913 ok($foo =~ /b+\G(..)/g, "$message: b+\\G");
914 is($1, 'cc', "$message: cc");
917 ok($foo =~ /d+\G(..)/g, "$message: d+\\G");
918 is($1, 'de', "$message: de");
920 ok($foo =~ /\Gef/g, "$message: \\Gef");
924 ok($foo =~ /(?=a+\G)(..)/g, "$message: (?a+\\G)");
925 is($1, 'aa', "$message: aa");
929 ok($foo =~ /a(?=a+\G)(..)/g, "$message: a(?=a+\\G)");
930 is($1, 'ab', "$message: ab");
936 my @res = /(\d*|x)/g;
938 is("@res", "123||x|123|", "0 match in alternation");
942 my $message = "Match against temporaries (created via pp_helem())" .
944 ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message);
945 is($1, "bar", $message);
949 my $message = 'package $i inside (?{ }), ' .
950 'saved substrings and changing $_';
951 our @a = qw [foo bar];
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);
957 $message = 'lexical $i inside (?{ }), ' .
958 'saved substrings and changing $_';
959 no warnings 'closure';
960 my @c = qw [foo bar];
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);
968 my $message = 'Brackets';
971 { (?> [^{}]+ | (??{ $brackets }) )* }
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);
985 ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg');
989 my $message = '\G anchor checks';
990 my $text = "aaXbXcc";
992 ok($text !~ /\GXb*X/g, $message);
997 unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"');
999 my $text = "abc dbf";
1000 my @res = ($text =~ /.*?(b).*?\b/g);
1001 is("@res", "b b", '\b is not special');
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);
1012 @c = grep /[\S]/, @a;
1013 is("@b", "@c", $message);
1016 @c = grep /[^\S]/, @a;
1017 is("@b", "@c", $message);
1020 @c = grep /[\s]/, @a;
1021 is("@b", "@c", $message);
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/");
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);
1044 @c = grep /[\D]/, @a;
1045 is("@b", "@c", $message);
1048 @c = grep /[^\D]/, @a;
1049 is("@b", "@c", $message);
1052 @c = grep /[\d]/, @a;
1053 is("@b", "@c", $message);
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);
1063 @c = grep /[\W]/, @a;
1064 is("@b", "@c", $message);
1067 @c = grep /[^\W]/, @a;
1068 is("@b", "@c", $message);
1071 @c = grep /[\w]/, @a;
1072 is("@b", "@c", $message);
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);
1092 use overload '""' => sub {'Object S'};
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);
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);
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)");
1118 my $message = '\s, [[:space:]] and [[:blank:]]';
1119 my %space = (spc => " ",
1124 # There's no \v but the vertical tabulator seems miraculously
1125 # be 11 both in ASCII and EBCDIC.
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;
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);
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)
1145 ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i";
1149 # we are actually testing that we dont die when executing these patterns
1152 ok(utf8::is_utf8($e),"got a unicode string - rt75680");
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");
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");
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");
1172 # Tests for bug 77414.
1175 my $message = '\p property after empty * match';
1177 like("1", qr/\s*\pN/, $message);
1178 like("-", qr/\s*\p{Dash}/, $message);
1179 like(" ", qr/\w*\p{Blank}/, $message);
1182 like("1", qr/\s*\pN+/, $message);
1183 like("-", qr/\s*\p{Dash}{1}/, $message);
1184 like(" ", qr/\w*\p{Blank}{1,4}/, $message);
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";
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";
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)/';
1214 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212");
1217 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212");
1222 local $::TODO = "[perl #38133]";
1224 "A" =~ /(((?:A))?)+/;
1230 is($first, $second);
1234 # RT #3516: \G in a m//g expression causes problems
1236 while ("abc" =~ m/(\G[ac])?/g) {
1237 last if $count++ > 10;
1239 ok($count < 10, 'RT #3516 A');
1242 while ("abc" =~ m/(\G|.)[ac]/g) {
1243 last if $count++ > 10;
1245 ok($count < 10, 'RT #3516 B');
1248 while ("abc" =~ m/(\G?[ac])?/g) {
1249 last if $count++ > 10;
1251 ok($count < 10, 'RT #3516 C');
1254 # RT #84294: Is this a bug in the simple Perl regex?
1255 # : Nested buffers and (?{...}) dont play nicely on partial matches
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');
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}";
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}");
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
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");
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)) {
1295 "abc" =~ qr/(?<$char>abc)/;
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)));
1305 utf8::upgrade($pat);
1306 like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string");
1309 { # Crash with @a =~ // warning
1310 local $SIG{__WARN__} = sub {
1311 pass 'no crash for @a =~ // warning'
1313 eval ' sub { my @a =~ // } ';
1316 { # Concat overloading and qr// thingies
1322 '""' => sub { ${$_[0]} },
1324 push @refs, ref $_[1] if ref $_[1];
1325 bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]"
1330 my $o = bless \$s, Cat::;
1332 is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth';
1338 $count++ while $str=~/.*/g;
1339 is $count, 2, 'test that ANCH_MBOL works properly. We should get 2 from $count++ while "\n"=~/.*/g';
1341 $class_count++ while $str=~/[^\n]*/g;
1342 is $class_count, $count, 'while "\n"=~/.*/g and while "\n"=~/[^\n]*/g should behave the same';
1344 $anch_count++ while $str=~/^.*/mg;
1345 is $anch_count, 1, 'while "\n"=~/^.*/mg should match only once';
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";
1353 unlike "\x{100}", qr/(?i:\w)/, "(?i: shouldn't lose the passed in /a";
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";
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
1364 for my $s (byte_utf8a_to_utf8n("\xc4\x80"), "\x{100}") {
1365 ok($s =~ /^$s$/, "re-compile check is UTF8-aware");
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.
1375 use overload 'qr' => sub { qr/(??{50})/ };
1378 use overload '""' => sub { qr/(??{51})/ };
1381 use overload '.' => sub { $_[1] . qr/(??{52})/ };
1384 use overload '""' => sub { qr/(??{7})/ },
1385 '.' => sub { $_[1] . qr/(??{53})/ };
1387 package Qr_indirect;
1388 use overload '""' => sub { $_[0][0] };
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,/),
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");
1409 ok("A5$i" =~ /^A$o$/, "Qr$i");
1410 ok("5$i" =~ /$o/, "Qr$i bare");
1414 my $o = bless [ bless [], "Qr1" ], 'Qr_indirect';
1415 ok("A51" =~ /^A$o/, "Qr_indirect");
1416 ok("51" =~ /$o/, "Qr_indirect bare");
1419 { # Various flags weren't being set when a [] is optimized into an
1421 ok("\x{017F}\x{017F}" =~ qr/^[$sharp_s]?$/i, "[] to EXACTish optimization");
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\")";
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?\$/");
1440 # #116148: Pattern utf8ness sticks around globally
1441 # the utf8 in the first match was sticking around for the second
1444 use feature 'unicode_strings';
1450 ok("Perl" =~ /P.*$/i, '#116148');
1453 { # 118297: Mixing up- and down-graded strings in regex
1454 utf8::upgrade(my $u = "\x{e5}");
1455 utf8::downgrade(my $d = "\x{e5}");
1457 local $SIG{__WARN__} = sub { $warned++ if $_[0] =~ /\AMalformed UTF-8/ };
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");
1464 like($c, $re, "mixed up-/downgraded pattern matches upgraded string");
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.
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;
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");
1484 $capture= "($capture)" for 1 .. $i;
1485 for my $mid ("","b") {
1486 my $str= "a${mid}a";
1487 my $backref= "\\$i";
1489 ok($str=~/$capture$mid$backref/,"\\$i works with $i buffers '$str'=~/...$mid$backref/");
1492 is("$@","","\\$i works with $i buffers works with $i buffers '$str'=~/...$mid$backref/");
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
1504 for ($c, 'C', $c, 'DE') {
1505 ok(/(.)/, "COWable match");
1514 # /[#$x]/x didn't interpolate the var $x.
1517 $s =~ s/[a#$b%]/X/g;
1518 is ($s, 'XbXX$XX&', 'RT #45667 without /x');
1520 $s =~ s/[a#$b%]/X/gx;
1521 is ($s, 'XbXX$XX&', 'RT #45667 with /x');
1525 no warnings "uninitialized";
1529 pass('no crash with /@a/ when array has nonexistent elems');
1533 is runperl(prog => 'delete $::{qq-\cR-}; //; print qq-ok\n-'),
1535 'deleting *^R does not result in crashes';
1537 *^R = *caretRglobwithnoscalar;
1539 is $^R, 42, 'assigning to *^R does not result in a crash';
1543 .' q-..- =~ /(??{undef *^R;q--})(?{42})/; '
1548 'undefining *^R within (??{}) does not result in a crash';
1551 SKIP: { # Test literal range end point special handling
1552 unless ($::IS_EBCDIC) {
1553 skip "Valid only for EBCDIC", 24;
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]');
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}]');
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}]');
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}]');
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}]');
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
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]');
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/
1602 skip "no re-debug under miniperl" if is_miniperl;
1604 use re qw(Debug COMPILE);
1607 fresh_perl_like($prog, qr/synthetic stclass/, { stderr=>1 }, "$re generates a synthetic start class");
1612 like "\x{AA}", qr/a?[\W_]/d, "\\W with /d synthetic start class works";
1616 skip("Tests are ASCII-centric, some would fail on EBCDIC", 12) if $::IS_EBCDIC;
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.
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");
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");
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");
1645 ok("abc" =~ /a
\85b
\85c/x, "NEL is white-space under /x");
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");
1654 # This one is for completeness
1655 ok('a<b>c' =~ qr<a\<b\>c>, "'\\<' is a literal in qr<...>)");
1658 { # Was getting optimized into EXACT (non-folding node)
1661 like("X", qr/$x/, "UTF-8 of /[x]/i matches upper case");
1664 SKIP: { # 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',
1669 require utf8; require 'utf8_heavy.pl';
1673 if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){
1674 print "It's good! >$1< >$2<\n";
1676 print "It's not good...\n";
1678 prog that cannot load uni tables
1679 qr/^Can't locate unicore\/Heavy\.pl(?x:
1680 )|^Can't find Unicode property definition/,
1682 '\p{} should not fail silently when uni tables evanesce');
1685 { # Special handling of literal-ended ranges in [...] was breaking this
1687 like("ÿ", qr/[ÿ-ÿ]/, "\"ÿ\" should match [ÿ-ÿ]");
1691 like("TffffffffffffTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff", qr/TffffffffffffTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff/il, "");
1692 like("TffffffffffffT\x{100}TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff", qr/TffffffffffffT\x{100}TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT5TTTTTTTTTTTTTTTTTTTTTTTTT3TTgTTTTTTTTTTTTTTTTTTTTT2TTTTTTTTTTTTTTTTTTTTTTTHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHHiHHHHHHHfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff&ffff/il, "");
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");
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}/ };
1711 like($e, qr{\x{123}},
1712 "qr/${pat}x/ shows x in error even if it's a wide character");
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;
1723 ok(1, "big backref $pat did not crash");
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.
1734 BEGIN{require q(./test.pl);}
1736 for my $len (1 .. 20) {
1737 my $eights= q(8) x $len;
1738 eval qq{ qr/\\\\$eights/ };
1740 print q(No infinite loop here!);
1742 fresh_perl_is($code, "No infinite loop here!", {},
1743 "test that we handle things like m/\\888888888/ without infinite loops" );
1746 { # Test that we handle some malformed UTF-8 without looping [perl
1750 BEGIN{require q(./test.pl);}
1751 use Encode qw(_utf8_on);
1752 # \x80 and \x41 are continuation bytes in their respective
1754 my $malformed = (ord("A") == 65) ? "a\x80\n" : "a\x41\n";
1755 utf8::downgrade($malformed);
1756 _utf8_on($malformed);
1758 $malformed =~ /(\n\r|\r)$/;
1759 print q(No infinite loop here!);
1761 fresh_perl_like($code, qr/Malformed UTF-8 character/, {},
1762 "test that we handle some UTF-8 malformations without looping" );
1766 # [perl #123843] hits SEGV trying to compile this pattern
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");
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 };
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');
1784 # [perl #126406] panic with unmatchable quantifier
1786 no warnings "regexp";
1787 "" =~ m/(.0\N{6,0}0\N{6,0}000000000000000000000000000000000)/;
1789 fresh_perl_is($code, "", {},
1790 "perl [#126406] panic");
1793 my $bug="[perl #126182]"; # test for infinite pattern recursion
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" ],
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))"],
1815 my ($expr, $expect, $test_name, $cap1)= @$tuple;
1816 # avoid quotes in this code!
1818 BEGIN{require q(./test.pl);}
1820 my $status= eval(q{ !(' . $expr . ') ? q(failed) : ' .
1821 ($cap1 ? '($1 ne q['.$cap1.']) ? qq(badmatch:$1) : ' : '') .
1823 || ( ( $@ =~ /Infinite recursion/ ) ? qq(died) : q(strange-death) );
1826 fresh_perl_is($code, $expect, {}, "$bug - $test_name" );
1831 BEGIN{require q(test.pl);}
1833 $SIG{ALRM} = sub {print "Timeout\n"; exit(1)};
1835 $_ = "a" x 1000 . "b" x 1000 . "c" x 1000;
1837 ',"Timeout",{},"Test Perl 73464")
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');
1846 ok($AE =~ $re, '/[\xE6\s]/i matches \xC6 when in UTF-8');
1850 is(0+("\n" =~ m'\n'), 1, q|m'\n' should interpolate escapes|);
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" );
1860 my $got= run_perl( switches => [ '-l' ], prog => <<'EOF_CODE' );
1864 my $p=qr/(?{ s!!x! })/;
1876 $error = $died ? ($@ || qq(Zombie)) : qq(none);
1877 print $died ? qq(died) : qq(lived);
1878 print qq(Error: $@);
1880 my @got= split /\n/, $got;
1881 is($got[0],"ab","empty pattern in regex codeblock: got expected start string");
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" );
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
1900 $s =~ m{([abcd]) (?{ die if $1 eq 'd'; })}gx;
1905 pass("call to current regex doesn't leak");
1911 # [perl #130495] /x comment skipping stopped a byte short, leading
1912 # to assertion failure or 'malformed utf-8 character" warning
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',
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, "");
1925 [ $no, undef, '<undef>' ],
1927 [ $no, "\0", '\0' ],
1928 [ $yes, "\0z", '\0z' ],
1929 [ $no, "\0z\0", '\0z\0' ],
1930 [ $yes, "\0z\n", '\0z\n' ],
1932 my($result, $target, $disp) = @$test;
1933 no warnings qw/uninitialized/;
1934 is($target =~ $re, $result, "[perl #130522] with target '$disp'");
1938 # [perl #129377] backref to an unmatched capture should not cause
1939 # reading before start of string.
1941 skip "no re-debug under miniperl" if is_miniperl;
1943 use re qw(Debug EXECUTE);
1944 "x" =~ m{ () y | () \1 }x;
1946 fresh_perl_like($prog, qr{
1948 }msx, { stderr => 1 }, "Offsets in debug output are not negative");
1954 # This test also used to leak - fixed by the commit which added
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");
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");
1966 # RT #131893 - fails with ASAN -fsanitize=undefined
1967 fresh_perl_is('qr/0(0?(0||00*))|/', '', {}, "integer overflow during compilation");
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
1975 my $text = "=t=\x{5000}";
1977 ok(scalar($text !~ m{(~*=[a-z]=)}g), "RT #131575");
1980 fresh_perl_is('"AA" =~ m/AA{1,0}/','',{},"handle OPFAIL insert properly");
1983 fresh_perl_is('$_="0\x{1000000}";/^000?\0000/','',{},"dont throw assert errors trying to fbm past end of string");
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");
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");
1992 fresh_perl_is('m m0*0+\Rm', "",{},"Undefined behavior in address sanitizer");
1995 fresh_perl_is('m/((?<=(0?)))/', "Variable length lookbehind not implemented in regex m/((?<=(0?)))/ at - line 1.",{},"Was getting 'Double free'");
1998 # this would panic on DEBUGGING builds
1999 fresh_perl_is(<<'CODE', "ok\nok\n",{}, 'Bad length magic was left on $^R');
2000 while( "\N{U+100}bc" =~ /(..?)(?{$^N})/g ) {
2001 print "ok\n" if length($^R)==length("$^R");
2005 { # [perl #133871], ASAN/valgrind out-of-bounds access
2006 fresh_perl_like('qr/(?|(())|())|//', qr/syntax error/, {}, "[perl #133871]");
2008 { # [perl #133921], segfault
2009 fresh_perl_is('qr
\ 40||ß+p00000F00000ù\Q00000ÿ00000x00000x0c0e0\Qx0\Qx0\x{0c!}\;\;î0\x
\0ÿÿÿþ
\0\0\0ù\Q`\Qx`
\0\ 1{0c!}
\ 1e;
\0\0\0ù\ò`\Qm`\x{0c!}\;\;îçÿ
\0\7fç
\0\0\0!
\0F
\ 5\0\0/;îçÿù\Q
\0\ 1\0\0x
\10ÿÿÿÿ
\0\0\0ù
\0\0\0\7f`x{0c!}
\ 1e;
\0\0\0ù\Q`\Qx`\x{c!}\;\;îç!}\;îçÿù\Q
\87 \x
\0ÿÿÿÿ
\0\0>=\Qx`\Qx`
\0\0ù\ò`\Qx`\x{0c!};\;îçÿ
\0F
\ 5\0n0t0
\0c
\0\80\ 1d;t
\0\0\0ù
\0\7fç
\80\0\0!00000000000000000000000m/00000000000000000000
\ e00000000000m/
\10\10\10\10\x{){}
\10\10\10\10)|
\10\10\ 4i', "", {}, "[perl #133921]");
2010 fresh_perl_is('
\ 4|ß+W0ü0r0\Qx0\Qx0x0c0G00000000000000000O000000000x0x0x0c!}\;îçÿù\Q0 \x
\0ÿÿÿÿ
\0\0\0ù\Q`\Qx`
\0\ 1{0d ;
\0\0\0ù\ò`\Qm`\x{0c!}\;\;îçÿ
\0\7fç
\0\0\0!
\0F
\ 5\0\0/;îçÿù\Q
\0\ 1\0\0x
\10ÿÿÿÿ
\0\0\0ù
\0\0\0\7f`x{0c!}
\ 1;
\0\0\0ù\Q`\Qq`\x{c!}\;\;îç!}\;îçÿù\Q
\87 \x
\0ÿÿÿÿ
\0\0>=\Qx`\Qx`
\0\0ù\ò`\Qx`\x{0c!};\;îçÿ
\00000000F
\ 5\0m0t0
\0c
\0\80\ 1d;t
\0\0\0ù
\0\7fç
\80\0\0!00000000000000000000000m/00000000000000000000
\ e00000000000m/
\10\10\10\10\x{){}
\10\10\10\10)|
\10\10\ 4\ 4i', "", {}, "[perl #133921]");
2013 } # End of sub run_tests
2018 # ex: set ts=8 sts=4 sw=4 et: