$| = 1;
-print "1..1015\n";
+# Test counter output is generated by a BEGIN block at bottom of file
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
+our $Message = "Noname test";
eval 'use Config'; # Defaults assumed if this fails
+run_tests() unless caller;
+
+sub run_tests {
+
$x = "abc\ndef\n";
if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
while ($_ = shift(@XXX)) {
?(.*)? && (print $1,"\n");
/not/ && reset;
- /not ok 26/ && reset 'X';
+ if (/not ok 26/) {
+ if ($^O eq 'VMS') {
+ $_ = shift(@XXX);
+ }
+ else {
+ reset 'X';
+ }
+ }
}
-while (($key,$val) = each(%XXX)) {
+if ($^O ne 'VMS') {
+ while (($key,$val) = each(%XXX)) {
print "not ok 27\n";
exit;
+ }
}
print "ok 27\n";
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)';
+print "not " unless qr/\b\v$/i eq '(?i-xsm:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)';
+print "not " unless qr/\b\v$/s eq '(?s-xim:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)';
+print "not " unless qr/\b\v$/m eq '(?m-xis:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)';
+print "not " unless qr/\b\v$/x eq '(?x-ism:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)';
+print "not " unless qr/\b\v$/xism eq '(?msix:\b\v$)';
print "ok $test\n";
$test++;
-print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)';
+print "not " unless qr/\b\v$/ eq '(?-xism:\b\v$)';
print "ok $test\n";
$test++;
print "ok $test\n";
$test++;
+if ($::running_as_thread) {
+ print "not ok $test # TODO & SKIP: croaks in 5.10 when threaded\n";
+ $test++;
+} else {
$a=qr/(?{++$b})/;
$b = 7;
/$a$a/;
print "not " unless $b eq '9';
print "ok $test\n";
$test++;
+}
-$c="$a";
-/$a$a/;
-print "not " unless $b eq '11';
-print "ok $test\n";
-$test++;
+{
+ local $TODO = $::running_as_thread;
+ $c="$a";
+ /$a$a/;
+ iseq($b, '11');
+}
{
use re "eval";
/$a$c$a/;
- print "not " unless $b eq '14';
- print "ok $test\n";
- $test++;
+ {
+ local $TODO = $::running_as_thread;
+ iseq($b, '14');
+ }
local $lex_a = 2;
my $lex_a = 43;
no re "eval";
$match = eval { /$a$c$a/ };
- print "not "
- unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match;
- print "ok $test\n";
- $test++;
+ # FIXME - split this one. That would require removing a lot of hard coded
+ # test numbers.
+ local $TODO = $::running_as_thread;
+ ok($b eq '14' and $@ =~ /Eval-group not allowed/ and not $match);
}
{
print "ok $test\n";
$test++;
-print "not " unless $str =~ /.\G./ and $& eq 'bc';
-print "ok $test\n";
-$test++;
+{
+ local $TODO = $::running_as_thread;
+ ok($str =~ /.\G./ and $& eq 'bc');
+}
print "not " unless $str =~ /\G../ and $& eq 'cd';
print "ok $test\n";
pos($foo)=1;
$foo=~/.\G(..)/g;
-print "not " unless($1 eq 'ab');
-print "ok $test\n";
-$test++;
+{
+ local $TODO = $::running_as_thread;
+ iseq($1,'ab');
+}
pos($foo) += 1;
$foo=~/.\G(..)/g;
-print "not " unless($1 eq 'cc');
-print "ok $test\n";
-$test++;
+{
+ local $TODO = $::running_as_thread;
+ iseq($1, 'cc');
+}
pos($foo) += 1;
$foo=~/.\G(..)/g;
-print "not " unless($1 eq 'de');
-print "ok $test\n";
-$test++;
+{
+ local $TODO = $::running_as_thread;
+ iseq($1, 'de');
+}
-print "not " unless $foo =~ /\Gef/g;
-print "ok $test\n";
-$test++;
+{
+ local $TODO = $::running_as_thread;
+ ok($foo =~ /\Gef/g);
+}
undef pos $foo;
@b = grep(/\w/,@a);
@c = grep(/[\w]/,@a);
-print "not " if "@b" ne "@c";
-print "ok $test\n";
-$test++;
+iseq("@b","@c");
# see if backtracking optimization works correctly
"\n\n" =~ /\n $ \n/x or print "not ";
{
# bug id 20001008.001
- my $test = 248;
+ $test = 248;
my @x = ("stra\337e 138","stra\337e 138");
for (@x) {
s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
}
SKIP: {
- my $test = 264; # till 575
+ $test = 264; # till 575
use charnames ":full";
print "not " if $x =~ /[\x{100}]/;
print "ok 604\n";
- print "not " unless $x =~ /\p{InLatin1Supplement}/;
+ # the next two tests must be ignored on EBCDIC
+ print "not " unless $x =~ /\p{InLatin1Supplement}/ or ord("A") == 193;
print "ok 605\n";
- print "not " if $x =~ /\P{InLatin1Supplement}/;
+ print "not " if $x =~ /\P{InLatin1Supplement}/ and ord("A") != 193;
print "ok 606\n";
print "not " if $x =~ /\p{InLatinExtendedA}/;
print "not " unless chr(0xfb4f) =~ /\p{IsHebrew}/; # outside InHebrew
print "ok 664\n";
-print "not " unless chr(0xb5) =~ /\p{IsGreek}/; # singleton (not in a range)
-print "ok 665\n";
+# # singleton (not in a range, this test must be ignored on EBCDIC)
+# print "not " unless chr(0xb5) =~ /\p{IsGreek}/ or ord("A") == 193;
+# print "ok 665\n";
+print "ok 665 # 0xb5 moved from Greek to Common with Unicode 4.0.1\n";
print "not " unless chr(0x37a) =~ /\p{IsGreek}/; # singleton
print "ok 666\n";
}
-my $test = 687;
+$test = 687;
# Force scalar context on the patern match
-sub ok ($$) {
+sub ok ($;$) {
my($ok, $name) = @_;
+ my $todo = $TODO ? " # TODO $TODO" : '';
- printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
+ printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
+ ($name||$Message)."$todo\tLine ".((caller)[2]);
printf "# Failed test at line %d\n", (caller)[2] unless $ok;
}
{
- print "not " unless "a" =~ /\p{L&}/;
+ # L& and LC are the same
+ print "not " unless "a" =~ /\p{LC}/ and "a" =~ /\p{L&}/;
print "ok 743\n";
- print "not " if "1" =~ /\p{L&}/;
+ print "not " if "1" =~ /\p{LC}/ or "1" =~ /\p{L&}/;
print "ok 744\n";
}
use charnames ':full';
- print "\N{LATIN SMALL LETTER SHARP S}" =~
- /\N{LATIN SMALL LETTER SHARP S}/ ? "ok 835\n" : "not ok 835\n";
-
- print "\N{LATIN SMALL LETTER SHARP S}" =~
- /\N{LATIN SMALL LETTER SHARP S}/i ? "ok 836\n" : "not ok 836\n";
-
- print "\N{LATIN SMALL LETTER SHARP S}" =~
- /[\N{LATIN SMALL LETTER SHARP S}]/ ? "ok 837\n" : "not ok 837\n";
-
- print "\N{LATIN SMALL LETTER SHARP S}" =~
- /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 838\n" : "not ok 838\n";
-
- print "ss" =~
- /\N{LATIN SMALL LETTER SHARP S}/i ? "ok 839\n" : "not ok 839\n";
-
- print "SS" =~
- /\N{LATIN SMALL LETTER SHARP S}/i ? "ok 840\n" : "not ok 840\n";
+ $test= 835;
- print "ss" =~
- /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 841\n" : "not ok 841\n";
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/);
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/i);
- print "SS" =~
- /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 842\n" : "not ok 842\n";
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/);
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i);
- print "\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i ?
- "ok 843\n" : "not ok 843\n";
+ ok("ss" =~ /\N{LATIN SMALL LETTER SHARP S}/i);
+ ok("SS" =~ /\N{LATIN SMALL LETTER SHARP S}/i);
+ ok("ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i);
+ ok("SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i);
- print "\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i ?
- "ok 844\n" : "not ok 844\n";
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i);
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i);
}
{
print "# more whitespace: U+0085, U+2028, U+2029\n";
# U+0085 needs to be forced to be Unicode, the \x{100} does that.
- print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 845\n" : "not ok 845\n";
+ if ($ordA == 193) {
+ print "<\x{100}\x{0085}>" =~ /<\x{100}e>/ ? "ok 845\n" : "not ok 845\n";
+ } else {
+ print "<\x{100}\x{0085}>" =~ /<\x{100}\s>/ ? "ok 845\n" : "not ok 845\n";
+ }
print "<\x{2028}>" =~ /<\s>/ ? "ok 846\n" : "not ok 846\n";
print "<\x{2029}>" =~ /<\s>/ ? "ok 847\n" : "not ok 847\n";
}
# check utf8/non-utf8 mixtures
# try to force all float/anchored check combinations
my $c = "\x{100}";
- my $test = 865;
+ $test = 865;
my $subst;
for my $re (
"xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x", "xx.*(?=$c)", "(?=$c).*xx",
{
print "# qr/.../x\n";
- my $test = 893;
+ $test = 893;
my $R = qr/ A B C # D E/x;
{
print "# illegal Unicode properties\n";
- my $test = 896;
+ $test = 896;
print eval { "a" =~ /\pq / } ? "not ok $test\n" : "ok $test\n";
$test++;
{
print "# [ID 20020412.005] wrong pmop flags checked when empty pattern\n";
# requires reuse of last successful pattern
- my $test = 898;
+ $test = 898;
$test =~ /\d/;
for (0 .. 1) {
my $match = ?? + 0;
END
}
-print "\x{0712}" =~ /\p{IsSyriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
-print "\x{072F}" =~ /\P{IsSyriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
+ok("\x{0712}" =~ /\p{IsSyriac1}/, '\x{0712}, \p{IsSyriac1}');
+ok("\x{072F}" =~ /\P{IsSyriac1}/, '\x{072F}, \P{IsSyriac1}');
sub Syriac1 {
return <<'END';
END
}
-print "\x{0712}" =~ /\p{Syriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
-print "\x{072F}" =~ /\P{Syriac1}/ ? "ok $test\n" : "not ok $test\n"; $test++;
+ok("\x{0712}" =~ /\p{Syriac1}/, '\x{0712}, \p{Syriac1}');
+ok("\x{072F}" =~ /\P{Syriac1}/, '\x{072F}, \p{Syriac1}');
+
+print "# user-defined character properties may lack \\n at the end\n";
+sub InGreekSmall { return "03B1\t03C9" }
+sub InGreekCapital { return "0391\t03A9\n-03A2" }
+
+ok("\x{03C0}" =~ /\p{InGreekSmall}/, "Small pi");
+ok("\x{03C2}" =~ /\p{InGreekSmall}/, "Final sigma");
+ok("\x{03A0}" =~ /\p{InGreekCapital}/, "Capital PI");
+ok("\x{03A2}" =~ /\P{InGreekCapital}/, "Reserved");
+
+sub AsciiHexAndDash {
+ return <<'END';
++utf8::ASCII_Hex_Digit
++utf8::Dash
+END
+}
+
+ok("-" =~ /\p{Dash}/, "'-' is Dash");
+ok("A" =~ /\p{ASCII_Hex_Digit}/, "'A' is ASCII_Hex_Digit");
+ok("-" =~ /\p{AsciiHexAndDash}/, "'-' is AsciiHexAndDash");
+ok("A" =~ /\p{AsciiHexAndDash}/, "'A' is AsciiHexAndDash");
{
print "# Change #18179\n";
my $ok = $s =~ /(\x{100}{4})/;
my($ord, $len) = (ord $1, length $1);
print +($ok && $ord == 0x100 && $len == 4)
- ? "ok $test\n" : "not ok $test\t# $ok/$ord/$len\n";
+ ? "ok $test\n" : "not ok $test\t# [#18179] $ok/$ord/$len\n";
++$test;
}
ok($a !~ /^\C{4}y/, q{don't match \C{4}y});
}
-$_ = 'aaaaaaaaaa';
-utf8::upgrade($_); chop $_; $\="\n";
-ok(/[^\s]+/, "m/[^\s]/ utf8");
-ok(/[^\d]+/, "m/[^\d]/ utf8");
-ok(($a = $_, $_ =~ s/[^\s]+/./g), "s/[^\s]/ utf8");
-ok(($a = $_, $a =~ s/[^\d]+/./g), "s/[^\s]/ utf8");
+{
+ local $\;
+ $_ = 'aaaaaaaaaa';
+ utf8::upgrade($_); chop $_; $\="\n";
+ ok(/[^\s]+/, "m/[^\s]/ utf8");
+ ok(/[^\d]+/, "m/[^\d]/ utf8");
+ ok(($a = $_, $_ =~ s/[^\s]+/./g), "s/[^\s]/ utf8");
+ ok(($a = $_, $a =~ s/[^\d]+/./g), "s/[^\s]/ utf8");
+}
ok("\x{100}" =~ /\x{100}/, "[perl #15397]");
ok("\x{100}" =~ /(\x{100})/, "[perl #15397]");
foreach (1,2,3,4) {
$p++ if /(??{ $p })/
}
- ok ($p == 5, "[perl #20683] (??{ }) returns stale values");
+ iseq ($p, 5, "[perl #20683] (??{ }) returns stale values");
{ package P; $a=1; sub TIESCALAR { bless[] } sub FETCH { $a++ } }
tie $p, P;
foreach (1,2,3,4) {
/(??{ $p })/
}
- ok ( $p == 5, "(??{ }) returns stale values");
+ iseq ( $p, 5, "(??{ }) returns stale values");
}
{
}
{
- split /(?{ split "" })/, "abc";
+ # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it
+ # hasn't been crashing. Disable this test until it is fixed properly.
+ # XXX also check what it returns rather than just doing ok(1,...)
+ # split /(?{ split "" })/, "abc";
ok(1,'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0');
}
#$_ = "x"; /x(?{func "in regexp"})/;
#$_ = "x"; /x(?{func "in multiline regexp"})/m;
-# bug #19049
+# bug RT#19049
$_="abcdef\n";
@x = m/./g;
-ok("abcde" eq "$`", '# TODO #19049 - global match not setting $`');
+ok("abcde" eq "$`", 'RT#19049 - global match not setting $`');
ok("123\x{100}" =~ /^.*1.*23\x{100}$/, 'uft8 + multiple floating substr');
ok($s =~ /\x{a0}/, "[perl #23769]");
ok($s =~ /\x{a0}+/, "[perl #23769]");
ok($s =~ /\x{a0}\x{a0}/, "[perl #23769]");
+
+ ok("aaa\x{100}" =~ /(a+)/, "[perl #23769] easy invariant");
+ ok($1 eq "aaa", "[perl #23769]");
+
+ ok("\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/, "[perl #23769] regrepeat invariant");
+ ok($1 eq "\xa0\xa0\xa0", "[perl #23769]");
+
+ ok("ababab\x{100} " =~ /((?:ab)+)/, "[perl #23769] hard invariant");
+ ok($1 eq "ababab", "[perl #23769]");
+
+ ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/, "[perl #23769] hard variant");
+ ok($1 eq "\xa0\xa1\xa0\xa1\xa0\xa1", "[perl #23769]");
+
+ ok("aaa\x{100} " =~ /(a+?)/, "[perl #23769] easy invariant");
+ ok($1 eq "a", "[perl #23769]");
+
+ ok("\xa0\xa0\xa0\x{100} " =~ /(\xa0+?)/, "[perl #23769] regrepeat variant");
+ ok($1 eq "\xa0", "[perl #23769]");
+
+ ok("ababab\x{100} " =~ /((?:ab)+?)/, "[perl #23769] hard invariant");
+ ok($1 eq "ab", "[perl #23769]");
+
+ ok("\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/, "[perl #23769] hard variant");
+ ok($1 eq "\xa0\xa1", "[perl #23769]");
+
+ ok("\xc4\xc4\xc4" !~ /(\x{100}+)/, "[perl #23769] don't match first byte of utf8 representation");
+ ok("\xc4\xc4\xc4" !~ /(\x{100}+?)/, "[perl #23769] don't match first byte of utf8 representation");
+}
+
+for (120 .. 130) {
+ my $head = 'x' x $_;
+ for my $tail ('\x{0061}', '\x{1234}') {
+ ok(
+ eval qq{ "$head$tail" =~ /$head$tail/ },
+ '\x{...} misparsed in regexp near 127 char EXACT limit'
+ );
+ }
+}
+
+# perl #25269: panic: pp_match start/end pointers
+ok("a-bc" eq eval {
+ my($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/;
+ "$x-$y";
+}, 'captures can move backwards in string');
+
+# perl #27940: \cA not recognized in character classes
+ok("a\cAb" =~ /\cA/, '\cA in pattern');
+ok("a\cAb" =~ /[\cA]/, '\cA in character class');
+ok("a\cAb" =~ /[\cA-\cB]/, '\cA in character class range');
+ok("abc" =~ /[^\cA-\cB]/, '\cA in negated character class range');
+ok("a\cBb" =~ /[\cA-\cC]/, '\cB in character class range');
+ok("a\cCbc" =~ /[^\cA-\cB]/, '\cC in negated character class range');
+ok("a\cAb" =~ /(??{"\cA"})/, '\cA in ??{} pattern');
+ok("ab" !~ /a\cIb/x, '\cI in pattern');
+
+# perl #28532: optional zero-width match at end of string is ignored
+ok(("abc" =~ /^abc(\z)?/) && defined($1),
+ 'optional zero-width match at end of string');
+ok(("abc" =~ /^abc(\z)??/) && !defined($1),
+ 'optional zero-width match at end of string');
+
+
+
+{ # TRIE related
+ my @got=();
+ "words"=~/(word|word|word)(?{push @got,$1})s$/;
+ ok(@got==1,"TRIE optimation is working") or warn "# @got";
+ @got=();
+ "words"=~/(word|word|word)(?{push @got,$1})s$/i;
+ ok(@got==1,"TRIEF optimisation is working") or warn "# @got";
+
+ my @nums=map {int rand 1000} 1..100;
+ my $re="(".(join "|",@nums).")";
+ $re=qr/\b$re\b/;
+
+ foreach (@nums) {
+ ok($_=~/$re/,"Trie nums");
+ }
+ $_=join " ", @nums;
+ @got=();
+ push @got,$1 while /$re/g;
+
+ my %count;
+ $count{$_}++ for @got;
+ my $ok=1;
+ for (@nums) {
+ $ok=0 if --$count{$_}<0;
+ }
+ ok($ok,"Trie min count matches");
+}
+
+
+# TRIE related
+# LATIN SMALL/CAPITAL LETTER A WITH MACRON
+ok(("foba \x{101}foo" =~ qr/(foo|\x{100}foo|bar)/i) && $1 eq "\x{101}foo",
+ "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH MACRON");
+
+# LATIN SMALL/CAPITAL LETTER A WITH RING BELOW
+ok(("foba \x{1E01}foo" =~ qr/(foo|\x{1E00}foo|bar)/i) && $1 eq "\x{1E01}foo",
+ "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW");
+
+# DESERET SMALL/CAPITAL LETTER LONG I
+ok(("foba \x{10428}foo" =~ qr/(foo|\x{10400}foo|bar)/i) && $1 eq "\x{10428}foo",
+ "TRIEF + DESERET SMALL/CAPITAL LETTER LONG I");
+
+# LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'
+ok(("foba \x{1E01}xfoo" =~ qr/(foo|\x{1E00}Xfoo|bar)/i) && $1 eq "\x{1E01}xfoo",
+ "TRIEF + LATIN SMALL/CAPITAL LETTER A WITH RING BELOW + 'X'");
+
+{# TRIE related
+
+use charnames ':full';
+
+$s="\N{LATIN SMALL LETTER SHARP S}";
+ok(("foba ba$s" =~ qr/(foo|Ba$s|bar)/i)
+ && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss");
+ok(("foba ba$s" =~ qr/(Ba$s|foo|bar)/i)
+ && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss");
+ok(("foba ba$s" =~ qr/(foo|bar|Ba$s)/i)
+ && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss");
+
+ok(("foba ba$s" =~ qr/(foo|Bass|bar)/i)
+ && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ ss");
+
+ok(("foba ba$s" =~ qr/(foo|BaSS|bar)/i)
+ && $1 eq "ba$s",
+ "TRIEF + LATIN SMALL LETTER SHARP S =~ SS");
+
+ok(("foba ba${s}pxySS$s$s" =~ qr/(b(?:a${s}t|a${s}f|a${s}p)[xy]+$s*)/i)
+ && $1 eq "ba${s}pxySS$s$s",
+ "COMMON PREFIX TRIEF + LATIN SMALL LETTER SHARP S");
+
+
+}
+
+
+print "# set PERL_SKIP_PSYCHO_TEST to skip this test\n";
+if (!$ENV{PERL_SKIP_PSYCHO_TEST}){
+ my @normal=qw(these are some normal words);
+ my $psycho=join "|",@normal,map chr $_,255..20000;
+ ok(('these'=~/($psycho)/) && $1 eq 'these','Pyscho');
+} else {
+ ok(1,'Skipped Psycho');
+}
+
+# [perl #36207] mixed utf8 / latin-1 and case folding
+
+{
+ my $utf8 = "\xe9\x{100}"; chop $utf8;
+ my $latin1 = "\xe9";
+
+ ok($utf8 =~ /\xe9/i, "utf8/latin");
+ ok($utf8 =~ /$latin1/i, "utf8/latin runtime");
+ ok($utf8 =~ /(abc|\xe9)/i, "utf8/latin trie");
+ ok($utf8 =~ /(abc|$latin1)/i, "utf8/latin trie runtime");
+
+ ok("\xe9" =~ /$utf8/i, "# latin/utf8");
+ ok("\xe9" =~ /(abc|$utf8)/i, "# latin/utf8 trie");
+ ok($latin1 =~ /$utf8/i, "# latin/utf8 runtime");
+ ok($latin1 =~ /(abc|$utf8)/i, "# latin/utf8 trie runtime");
+}
+
+# [perl #37038] Global regular matches generate invalid pointers
+
+{
+ my $s = "abcd";
+ $s =~ /(..)(..)/g;
+ $s = $1;
+ $s = $2;
+ ok($s eq 'cd',
+ "# assigning to original string should not corrupt match vars");
+}
+
+{
+ package wooosh;
+ sub gloople {
+ "!";
+ }
+ package main;
+
+ my $aeek = bless {}, 'wooosh';
+ eval {$aeek->gloople() =~ /(.)/g;};
+ ok($@ eq "", "//g match against return value of sub") or print "# $@\n";
+}
+
+{
+ sub gloople {
+ "!";
+ }
+ eval {gloople() =~ /(.)/g;};
+ ok($@ eq "", "# 26410 didn't affect sub calls for some reason")
+ or print "# $@\n";
+}
+
+{
+ local $TODO = "See changes 26925-26928, which reverted change 26410";
+ package lv;
+ $var = "abc";
+ sub variable : lvalue { $var }
+
+ package main;
+ my $o = bless [], "lv";
+ my $f = "";
+ eval { for (1..2) { $f .= $1 if $o->variable =~ /(.)/g } };
+ ok($f eq "ab", "pos retained between calls") or print "# $@\n";
+}
+
+{
+ local $TODO = "See changes 26925-26928, which reverted change 26410";
+ $var = "abc";
+ sub variable : lvalue { $var }
+
+ my $f = "";
+ eval { for (1..2) { $f .= $1 if variable() =~ /(.)/g } };
+ ok($f eq "ab", "pos retained between calls") or print "# $@\n";
+}
+
+# [perl #37836] Simple Regex causes SEGV when run on specific data
+if ($ordA == 193) {
+ print "ok $test # Skip: in EBCDIC\n"; $test++;
+} else {
+ no warnings 'utf8';
+ $_ = pack('U0C2', 0xa2, 0xf8); # ill-formed UTF-8
+ my $ret = 0;
+ eval { $ret = s/[\0]+//g };
+ ok($ret == 0, "ill-formed UTF-8 doesn't match NUL in class");
+}
+
+{ # [perl #38293] chr(65535) should be allowed in regexes
+ no warnings 'utf8'; # to allow non-characters
+ my($c, $r, $s);
+
+ $c = chr 0xffff;
+ $c =~ s/$c//g;
+ ok($c eq "", "U+FFFF, parsed as atom");
+
+ $c = chr 0xffff;
+ $r = "\\$c";
+ $c =~ s/$r//g;
+ ok($c eq "", "U+FFFF backslashed, parsed as atom");
+
+ $c = chr 0xffff;
+ $c =~ s/[$c]//g;
+ ok($c eq "", "U+FFFF, parsed in class");
+
+ $c = chr 0xffff;
+ $r = "[\\$c]";
+ $c =~ s/$r//g;
+ ok($c eq "", "U+FFFF backslashed, parsed in class");
+
+ $s = "A\x{ffff}B";
+ $s =~ s/\x{ffff}//i;
+ ok($s eq "AB", "U+FFFF, EXACTF");
+
+ $s = "\x{ffff}A";
+ $s =~ s/\bA//;
+ ok($s eq "\x{ffff}", "U+FFFF, BOUND");
+
+ $s = "\x{ffff}!";
+ $s =~ s/\B!//;
+ ok($s eq "\x{ffff}", "U+FFFF, NBOUND");
+} # non-characters end
+
+{
+ # https://rt.perl.org/rt3/Ticket/Display.html?id=39583
+
+ # The printing characters
+ my @chars = ("A".."Z");
+ my $delim = ",";
+ my $size = 32771 - 4;
+ my $str = '';
+
+ # create some random junk. Inefficient, but it works.
+ for ($i = 0 ; $i < $size ; $i++) {
+ $str .= $chars[int(rand(@chars))];
+ }
+
+ $str .= ($delim x 4);
+ my $res;
+ my $matched;
+ if ($str =~ s/^(.*?)${delim}{4}//s) {
+ $res = $1;
+ $matched=1;
+ }
+ ok($matched,'pattern matches');
+ ok(length($str)==0,"Empty string");
+ ok(defined($res) && length($res)==$size,"\$1 is correct size");
+}
+
+{ # related to [perl #27940]
+ ok("\0-A" =~ /\c@-A/, '@- should not be interpolated in a pattern');
+ ok("\0\0A" =~ /\c@+A/, '@+ should not be interpolated in a pattern');
+ ok("X\@-A" =~ /X@-A/, '@- should not be interpolated in a pattern');
+ ok("X\@\@A" =~ /X@+A/, '@+ should not be interpolated in a pattern');
+
+ ok("X\0A" =~ /X\c@?A/, '\c@?');
+ ok("X\0A" =~ /X\c@*A/, '\c@*');
+ ok("X\0A" =~ /X\c@(A)/, '\c@(');
+ ok("X\0A" =~ /X(\c@)A/, '\c@)');
+ ok("X\0A" =~ /X\c@|ZA/, '\c@|');
+
+ ok("X\@A" =~ /X@?A/, '@?');
+ ok("X\@A" =~ /X@*A/, '@*');
+ ok("X\@A" =~ /X@(A)/, '@(');
+ ok("X\@A" =~ /X(@)A/, '@)');
+ ok("X\@A" =~ /X@|ZA/, '@|');
+
+ local $" = ','; # non-whitespace and non-RE-specific
+ ok('abc' =~ /(.)(.)(.)/, 'the last successful match is bogus');
+ ok("A@+B" =~ /A@{+}B/, 'interpolation of @+ in /@{+}/');
+ ok("A@-B" =~ /A@{-}B/, 'interpolation of @- in /@{-}/');
+ ok("A@+B" =~ /A@{+}B/x, 'interpolation of @+ in /@{+}/x');
+ ok("A@-B" =~ /A@{-}B/x, 'interpolation of @- in /@{-}/x');
+}
+
+{
+ use lib 'lib';
+ use Cname;
+
+ ok('fooB'=~/\N{foo}[\N{B}\N{b}]/,"Passthrough charname");
+ $test=1233; my $handle=make_must_warn('Ignoring excess chars from');
+ $handle->('q(xxWxx) =~ /[\N{WARN}]/');
+ {
+ my $code;
+ my $w="";
+ local $SIG{__WARN__} = sub { $w.=shift };
+ eval($code=<<'EOFTEST') or die "$@\n$code\n";
+ {
+ use warnings;
+
+ #1234
+ ok("\0" !~ /[\N{EMPTY-STR}XY]/,
+ "Zerolength charname in charclass doesnt match \0");
+ 1;
+ }
+EOFTEST
+ ok($w=~/Ignoring zero length/,
+ "Got expected zero length warning");
+ warn $code;
+
+ }
+ $handle= make_must_warn('Ignoring zero length');
+ $handle->('qq(\\0) =~ /[\N{EMPTY-STR}XY]/');
+ ok('AB'=~/(\N{EVIL})/ && $1 eq 'A',"Charname caching $1");
+ ok('ABC'=~/(\N{EVIL})/,"Charname caching $1");
+ ok('xy'=~/x\N{EMPTY-STR}y/, 'Empty string charname produces NOTHING node');
+ ok(''=~/\N{EMPTY-STR}/, 'Empty string charname produces NOTHING node 2');
+
+}
+{
+ print "# MORE LATIN SMALL LETTER SHARP S\n";
+
+ use charnames ':full';
+
+ #see also test #835
+ ok("ss" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i,
+ "unoptimized named sequence in class 1");
+ ok("SS" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i,
+ "unoptimized named sequence in class 2");
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/,
+ "unoptimized named sequence in class 3");
+ ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i,
+ "unoptimized named sequence in class 4");
+
+ ok('aabc' !~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against aabc');
+ ok('a+bc' =~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against a+bc');
+ ok('a+bc' =~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against a+bc');
+
+ ok(' A B'=~/\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/,
+ 'Intermixed named and unicode escapes 1');
+ ok("\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}"=~
+ /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/,
+ 'Intermixed named and unicode escapes 2');
+ ok("\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042} 3"=~
+ /[\N{SPACE}\N{U+0041}][\N{SPACE}\N{U+0042}]/,
+ 'Intermixed named and unicode escapes');
+}
+$brackets = qr{
+ { (?> [^{}]+ | (??{ $brackets }) )* }
+ }x;
+ok("{b{c}d" !~ m/^((??{ $brackets }))/, "bracket mismatch");
+
+SKIP:{
+ our @stack=();
+ my @expect=qw(
+ stuff1
+ stuff2
+ <stuff1>and<stuff2>
+ right
+ <right>
+ <<right>>
+ <<<right>>>
+ <<stuff1>and<stuff2>><<<<right>>>>
+ );
+
+ local $_='<<<stuff1>and<stuff2>><<<<right>>>>>';
+ ok(/^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/,
+ "Recursion should match");
+ ok(@stack==@expect)
+ or skip("Won't test individual results as count isn't equal",
+ 0+@expect);
+ foreach my $idx (@expect) {
+ ok($expect[$idx] eq $stack[$idx],
+ "Expecting '$expect' at stack pos #$idx");
+ }
+
+}
+{
+ my $s='123453456';
+ $s=~s/(?<digits>\d+)\k<digits>/$+{digits}/;
+ ok($s eq '123456','Named capture (angle brackets) s///');
+ $s='123453456';
+ $s=~s/(?'digits'\d+)\k'digits'/$+{digits}/;
+ ok($s eq '123456','Named capture (single quotes) s///');
+}
+
+{
+ my @ary = (
+ pack('U', 0x00F1), # n-tilde
+ '_'.pack('U', 0x00F1), # _ + n-tilde
+ 'c'.pack('U', 0x0327), # c + cedilla
+ pack('U*', 0x00F1, 0x0327), # n-tilde + cedilla
+ 'a'.pack('U', 0x00B2), # a + superscript two
+ pack('U', 0x0391), # ALPHA
+ pack('U', 0x0391).'2', # ALPHA + 2
+ pack('U', 0x0391).'_', # ALPHA + _
+ );
+ for my $uni (@ary) {
+ my ($r1, $c1, $r2, $c2) = eval qq{
+ use utf8;
+ scalar("..foo foo.." =~ /(?'${uni}'foo) \\k'${uni}'/),
+ \$+{${uni}},
+ scalar("..bar bar.." =~ /(?<${uni}>bar) \\k<${uni}>/),
+ \$+{${uni}};
+ };
+ ok($r1, "Named capture UTF (?'')");
+ ok(defined $c1 && $c1 eq 'foo', "Named capture UTF \%+");
+ ok($r2, "Named capture UTF (?<>)");
+ ok(defined $c2 && $c2 eq 'bar', "Named capture UTF \%+");
+ }
+}
+
+sub iseq($$;$) {
+ my ( $got, $expect, $name)=@_;
+ my $todo = $TODO ? " # TODO $TODO" : '';
+
+ $_=defined($_) ? "'$_'" : "undef"
+ for $got, $expect;
+
+ my $ok= $got eq $expect;
+
+ printf "%sok %d - %s$todo\n", ($ok ? "" : "not "), $test,
+ ($name||$Message)."\tLine ".((caller)[2]);
+
+ printf "# Failed test at line %d\n".
+ "# expected: %s\n".
+ "# result: %s\n",
+ (caller)[2], $expect, $got
+ unless $ok;
+
+ $test++;
+ return $ok;
+}
+{
+ my $s='foo bar baz';
+ my (@k,@v,@fetch,$res);
+ my $count= 0;
+ my @names=qw($+{A} $+{B} $+{C});
+ if ($s=~/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/) {
+ while (my ($k,$v)=each(%+)) {
+ $count++;
+ }
+ @k=sort keys(%+);
+ @v=sort values(%+);
+ $res=1;
+ push @fetch,
+ [ "$+{A}", "$1" ],
+ [ "$+{B}", "$2" ],
+ [ "$+{C}", "$3" ],
+ ;
+ }
+ foreach (0..2) {
+ if ($fetch[$_]) {
+ iseq($fetch[$_][0],$fetch[$_][1],$names[$_]);
+ } else {
+ ok(0, $names[$_]);
+ }
+ }
+ iseq($res,1,"$s~=/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/");
+ iseq($count,3,"Got 3 keys in %+ via each");
+ iseq(0+@k, 3, 'Got 3 keys in %+ via keys');
+ iseq("@k","A B C", "Got expected keys");
+ iseq("@v","bar baz foo", "Got expected values");
+ eval'
+ print for $+{this_key_doesnt_exist};
+ ';
+ ok(!$@,'lvalue $+{...} should not throw an exception');
+}
+{
+ my $s='foo bar baz';
+ my @res;
+ if ('1234'=~/(?<A>1)(?<B>2)(?<A>3)(?<B>4)/) {
+ foreach my $name (sort keys(%-)) {
+ my $ary = $-{$name};
+ foreach my $idx (0..$#$ary) {
+ push @res,"$name:$idx:$ary->[$idx]";
+ }
+ }
+ }
+ my @expect=qw(A:0:1 A:1:3 B:0:2 B:1:4);
+ iseq("@res","@expect","Check %-");
+ eval'
+ print for $-{this_key_doesnt_exist};
+ ';
+ ok(!$@,'lvalue $-{...} should not throw an exception');
+}
+# stress test CURLYX/WHILEM.
+#
+# This test includes varying levels of nesting, and according to
+# profiling done against build 28905, exercises every code line in the
+# CURLYX and WHILEM blocks, except those related to LONGJMP, the
+# super-linear cache and warnings. It executes about 0.5M regexes
+
+if ($ENV{PERL_SKIP_PSYCHO_TEST}){
+ printf "ok %d Skip: No psycho tests\n", $test++;
+} else {
+ print "# set PERL_SKIP_PSYCHO_TEST to skip this test\n";
+ my $r = qr/^
+ (?:
+ ( (?:a|z+)+ )
+ (?:
+ ( (?:b|z+){3,}? )
+ (
+ (?:
+ (?:
+ (?:c|z+){1,1}?z
+ )?
+ (?:c|z+){1,1}
+ )*
+ )
+ (?:z*){2,}
+ ( (?:z+|d)+ )
+ (?:
+ ( (?:e|z+)+ )
+ )*
+ ( (?:f|z+)+ )
+ )*
+ ( (?:z+|g)+ )
+ (?:
+ ( (?:h|z+)+ )
+ )*
+ ( (?:i|z+)+ )
+ )+
+ ( (?:j|z+)+ )
+ (?:
+ ( (?:k|z+)+ )
+ )*
+ ( (?:l|z+)+ )
+ $/x;
+
+
+ my $ok = 1;
+ my $msg = "CURLYX stress test";
+ OUTER:
+ for my $a ("x","a","aa") {
+ for my $b ("x","bbb","bbbb") {
+ my $bs = $a.$b;
+ for my $c ("x","c","cc") {
+ my $cs = $bs.$c;
+ for my $d ("x","d","dd") {
+ my $ds = $cs.$d;
+ for my $e ("x","e","ee") {
+ my $es = $ds.$e;
+ for my $f ("x","f","ff") {
+ my $fs = $es.$f;
+ for my $g ("x","g","gg") {
+ my $gs = $fs.$g;
+ for my $h ("x","h","hh") {
+ my $hs = $gs.$h;
+ for my $i ("x","i","ii") {
+ my $is = $hs.$i;
+ for my $j ("x","j","jj") {
+ my $js = $is.$j;
+ for my $k ("x","k","kk") {
+ my $ks = $js.$k;
+ for my $l ("x","l","ll") {
+ my $ls = $ks.$l;
+ if ($ls =~ $r) {
+ if ($ls =~ /x/) {
+ $msg .= ": unexpected match for [$ls]";
+ $ok = 0;
+ last OUTER;
+ }
+ my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12";
+ unless ($ls eq $cap) {
+ $msg .= ": capture: [$ls], got [$cap]";
+ $ok = 0;
+ last OUTER;
+ }
+ }
+ else {
+ unless ($ls =~ /x/) {
+ $msg = ": failed for [$ls]";
+ $ok = 0;
+ last OUTER;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ ok($ok, $msg);
+}
+
+# \, breaks {3,4}
+ok("xaaay" !~ /xa{3\,4}y/, "\, in a pattern");
+ok("xa{3,4}y" =~ /xa{3\,4}y/, "\, in a pattern");
+
+# \c\ followed by _
+ok("x\c_y" !~ /x\c\_y/, "\_ in a pattern");
+ok("x\c\_y" =~ /x\c\_y/, "\_ in a pattern");
+
+# \c\ followed by other characters
+for my $c ("z", "\0", "!", chr(254), chr(256)) {
+ my $targ = "a\034$c";
+ my $reg = "a\\c\\$c";
+ ok(eval("qq/$targ/ =~ /$reg/"), "\\c\\ in pattern");
+}
+
+{
+ my $str='abc';
+ my $count=0;
+ my $mval=0;
+ my $pval=0;
+ while ($str=~/b/g) { $mval=$#-; $pval=$#+; $count++ }
+ iseq($mval,0,"\@- should be empty [RT#36046]");
+ iseq($pval,0,"\@+ should be empty [RT#36046]");
+ iseq($count,1,"should have matched once only [RT#36046]");
+}
+
+{ # Test the (*PRUNE) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(?{$count++})(*FAIL)/;
+ iseq($count,9,"expect 9 for no (*PRUNE)");
+ $count = 0;
+ 'aaab'=~/a+b?(*PRUNE)(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with (*PRUNE)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*PRUNE)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*PRUNE)/");
+ $count = 0;
+ 'aaab'=~/a+b?(??{'(*PRUNE)'})(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with (*PRUNE)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(??{'(*PRUNE)'})(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*PRUNE)/");
+}
+{ # Test the (*SKIP) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(*SKIP)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*SKIP)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*SKIP)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*SKIP)/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with (*SKIP)" );
+ iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" );
+}
+{ # Test the (*SKIP) pattern
+ our $count = 0;
+ 'aaab'=~/a+b?(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*SKIP)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*MARK:foo)(*SKIP)(?{$count++})(*FAIL)/g;
+ iseq($count,4,"/.(*SKIP)/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)(*MARK:foo)(*SKIP)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,2,"Expect 2 with (*SKIP)" );
+ iseq("@res","aaab aaab","adjacent (*SKIP) works as expected" );
+}
+{ # Test the (*SKIP) pattern
+ our $count = 0;
+ 'aaab'=~/a*(*MARK:a)b?(*MARK:b)(*SKIP:a)(?{$count++})(*FAIL)/;
+ iseq($count,3,"expect 3 with *MARK:a)b?(*MARK:b)(*SKIP:a)");
+ local $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a*(*MARK:a)b?)(*MARK:x)(*SKIP:a)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,5,"Expect 5 with (*MARK:a)b?)(*MARK:x)(*SKIP:a)" );
+ iseq("@res","aaab b aaab b ","adjacent (*MARK:a)b?)(*MARK:x)(*SKIP:a) works as expected" );
+}
+{ # Test the (*COMMIT) pattern
+ our $count = 0;
+ 'aaabaaab'=~/a+b?(*COMMIT)(?{$count++})(*FAIL)/;
+ iseq($count,1,"expect 1 with (*COMMIT)");
+ local $_='aaab';
+ $count=0;
+ 1 while /.(*COMMIT)(?{$count++})(*FAIL)/g;
+ iseq($count,1,"/.(*COMMIT)/");
+ $_='aaabaaab';
+ $count=0;
+ our @res=();
+ 1 while /(a+b?)(*COMMIT)(?{$count++; push @res,$1})(*FAIL)/g;
+ iseq($count,1,"Expect 1 with (*COMMIT)" );
+ iseq("@res","aaab","adjacent (*COMMIT) works as expected" );
+}
+{
+ # Test named commits and the $REGERROR var
+ our $REGERROR;
+ for my $name ('',':foo')
+ {
+ for my $pat ("(*PRUNE$name)",
+ ($name? "(*MARK$name)" : "")
+ . "(*SKIP$name)",
+ "(*COMMIT$name)")
+ {
+ for my $suffix ('(*FAIL)','')
+ {
+ 'aaaab'=~/a+b$pat$suffix/;
+ iseq(
+ $REGERROR,
+ ($suffix ? ($name ? 'foo' : "1") : ""),
+ "Test $pat and \$REGERROR $suffix"
+ );
+ }
+ }
+ }
+}
+{
+ # Test named commits and the $REGERROR var
+ package Fnorble;
+ our $REGERROR;
+ for my $name ('',':foo')
+ {
+ for my $pat ("(*PRUNE$name)",
+ ($name? "(*MARK$name)" : "")
+ . "(*SKIP$name)",
+ "(*COMMIT$name)")
+ {
+ for my $suffix ('(*FAIL)','')
+ {
+ 'aaaab'=~/a+b$pat$suffix/;
+ ::iseq(
+ $REGERROR,
+ ($suffix ? ($name ? 'foo' : "1") : ""),
+ "Test $pat and \$REGERROR $suffix"
+ );
+ }
+ }
+ }
+}
+{
+ # Test named commits and the $REGERROR var
+ local $Message = "\$REGERROR";
+ our $REGERROR;
+ for $word (qw(bar baz bop)) {
+ $REGERROR="";
+ "aaaaa$word"=~/a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/;
+ iseq($REGERROR,$word);
+ }
+}
+{ #Regression test for perlbug 40684
+ local $Message = "RT#40684 tests:";
+ my $s = "abc\ndef";
+ my $rex = qr'^abc$'m;
+ ok($s =~ m/$rex/);
+ ok($s =~ m/^abc$/m);
+}
+{
+ #Mindnumbingly simple test of (*THEN)
+ for ("ABC","BAX") {
+ ok(/A (*THEN) X | B (*THEN) C/x,"Simple (*THEN) test");
+ }
+}
+
+{
+ local $Message = "Relative Recursion";
+ my $parens=qr/(\((?:[^()]++|(?-1))*+\))/;
+ local $_='foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))';
+ my ($all,$one,$two)=('','','');
+ if (/foo $parens \s* \+ \s* bar $parens/x) {
+ $all=$&;
+ $one=$1;
+ $two=$2;
+ }
+ iseq($one, '((2*3)+4-3)');
+ iseq($two, '(2*(3+4)-1*(2-3))');
+ iseq($all, 'foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))');
+ iseq($all, $_);
+}
+{
+ my $spaces=" ";
+ local $_=join 'bar',$spaces,$spaces;
+ our $count=0;
+ s/(?>\s+bar)(?{$count++})//g;
+ iseq($_,$spaces,"SUSPEND final string");
+ iseq($count,1,"Optimiser should have prevented more than one match");
+}
+{
+ local $Message = "RT#36909 test";
+ $^R = 'Nothing';
+ {
+ local $^R = "Bad";
+ ok('x foofoo y' =~ m{
+ (foo) # $^R correctly set
+ (?{ "last regexp code result" })
+ }x);
+ iseq($^R,'last regexp code result');
+ }
+ iseq($^R,'Nothing');
+ {
+ local $^R = "Bad";
+
+ ok('x foofoo y' =~ m{
+ (?:foo|bar)+ # $^R correctly set
+ (?{"last regexp code result"})
+ }x);
+ iseq($^R,'last regexp code result');
+ }
+ iseq($^R,'Nothing');
+
+ {
+ local $^R = "Bad";
+ ok('x foofoo y' =~ m{
+ (foo|bar)\1+ # $^R undefined
+ (?{"last regexp code result"})
+ }x);
+ iseq($^R,'last regexp code result');
+ }
+ iseq($^R,'Nothing');
+
+ {
+ local $^R = "Bad";
+ ok('x foofoo y' =~ m{
+ (foo|bar)\1 # this time without the +
+ (?{"last regexp code result"})
+ }x);
+ iseq($^R,'last regexp code result');
+ }
+ iseq($^R,'Nothing');
+}
+{
+ local $Message="RT 22395";
+ local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)";
+ our $count;
+ for my $l (10,100,1000) {
+ $count=0;
+ ('a' x $l) =~ /(.*)(?{$count++})[bc]/;
+ iseq( $count, $l + 1);
+ }
+}
+{
+ local $Message = "RT#22614";
+ local $_='ab';
+ our @len=();
+ /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/;
+ iseq("@len","2 2 2");
+}
+{
+ local $Message = "RT#18209";
+ my $text = ' word1 word2 word3 word4 word5 word6 ';
+
+ my @words = ('word1', 'word3', 'word5');
+ my $count;
+ foreach my $word (@words){
+ $text =~ s/$word\s//gi; # Leave a space to seperate words in the resultant str.
+ # The following block is not working.
+ if($&){
+ $count++;
+ }
+ # End bad block
+ }
+ iseq($count,3);
+ iseq($text,' word2 word4 word6 ');
+}
+{
+ # RT#6893
+ local $_= qq(A\nB\nC\n);
+ my @res;
+ while (m#(\G|\n)([^\n]*)\n#gsx)
+ {
+ push @res,"$2";
+ last if @res>3;
+ }
+ iseq("@res","A B C","RT#6893: /g pattern shouldn't infinite loop");
+}
+
+{
+ # From Message-ID: <877ixs6oa6.fsf@k75.linux.bogus>
+ my $dow_name= "nada";
+ my $parser = "(\$dow_name) = \$time_string =~ /(D\x{e9}\\ C\x{e9}adaoin|D\x{e9}\\ Sathairn|\\w+|\x{100})/";
+ my $time_string = "D\x{e9} C\x{e9}adaoin";
+ eval $parser;
+ ok(!$@,"Test Eval worked");
+ iseq($dow_name,$time_string,"UTF8 trie common prefix extraction");
+}
+
+{
+ my $v;
+ ($v='bar')=~/(\w+)/g;
+ $v='foo';
+ iseq("$1",'bar','$1 is safe after /g - may fail due to specialized config in pp_hot.c')
+}
+{
+ local $Message = "http://nntp.perl.org/group/perl.perl5.porters/118663";
+ my $qr_barR1 = qr/(bar)\g-1/;
+ ok("foobarbarxyz" =~ $qr_barR1);
+ ok("foobarbarxyz" =~ qr/foo${qr_barR1}xyz/);
+ ok("foobarbarxyz" =~ qr/(foo)${qr_barR1}xyz/);
+ ok("foobarbarxyz" =~ qr/(foo)(bar)\g{-1}xyz/);
+ ok("foobarbarxyz" =~ qr/(foo${qr_barR1})xyz/);
+ ok("foobarbarxyz" =~ qr/(foo(bar)\g{-1})xyz/);
+}
+{
+ local $Message = "RT#41010";
+ my @tails=('','(?(1))','(|)','()?');
+ my @quants=('*','+');
+ my $doit=sub {
+ my $pats= shift;
+ for (@_) {
+ for my $pat (@$pats) {
+ for my $quant (@quants) {
+ for my $tail (@tails) {
+ my $re = "($pat$quant\$)$tail";
+ ok(/$re/ && $1 eq $_,"'$_'=~/$re/");
+ ok(/$re/m && $1 eq $_,"'$_'=~/$re/m");
+ }
+ }
+ }
+ }
+ };
+
+ my @dpats=(
+ '\d',
+ '[1234567890]',
+ '(1|[23]|4|[56]|[78]|[90])',
+ '(?:1|[23]|4|[56]|[78]|[90])',
+ '(1|2|3|4|5|6|7|8|9|0)',
+ '(?:1|2|3|4|5|6|7|8|9|0)',
+ );
+ my @spats=('[ ]',' ','( |\t)','(?: |\t)','[ \t]','\s');
+ my @sstrs=(' ');
+ my @dstrs=('12345');
+ $doit->(\@spats,@sstrs);
+ $doit->(\@dpats,@dstrs);
+}
+{
+ local $Message = "\$REGMARK";
+ our @r=();
+ ok('foofoo' =~ /foo (*MARK:foo) (?{push @r,$REGMARK}) /x);
+ iseq("@r","foo");
+ iseq($REGMARK,"foo");
+ ok('foofoo' !~ /foo (*MARK:foo) (*FAIL) /x);
+ ok(!$REGMARK);
+ iseq($REGERROR,'foo');
+}
+{
+ my $x;
+ $x = "abc.def.ghi.jkl";
+ $x =~ s/.*\K\..*//;
+ ok($x eq "abc.def.ghi");
+
+ $x = "one two three four";
+ $x =~ s/o+ \Kthree//g;
+ ok($x eq "one two four");
+
+ $x = "abcde";
+ $x =~ s/(.)\K/$1/g;
+ ok($x eq "aabbccddee");
+}
+sub kt
+{
+ return '4' if $_[0] eq '09028623';
}
-# last test 1015
+{ # Nested EVAL using PL_curpm (via $1 or friends)
+ my $re;
+ our $grabit = qr/ ([0-6][0-9]{7}) (??{ kt $1 }) [890] /x;
+ $re = qr/^ ( (??{ $grabit }) ) $ /x;
+ my @res = '0902862349' =~ $re;
+ iseq(join("-",@res),"0902862349",
+ 'PL_curpm is set properly on nested eval');
+
+ our $qr = qr/ (o) (??{ $1 }) /x;
+ ok( 'boob'=~/( b (??{ $qr }) b )/x && 1,
+ "PL_curpm, nested eval");
+}
+
+{
+ use charnames ":full";
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "I =~ Alphabetic");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{Uppercase}/, "I =~ Uppercase");
+ ok("\N{ROMAN NUMERAL ONE}" !~ /\p{Lowercase}/, "I !~ Lowercase");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "I =~ ID_Start");
+ ok("\N{ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "I =~ ID_Continue");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Alphabetic}/, "i =~ Alphabetic");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" !~ /\p{Uppercase}/, "i !~ Uppercase");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{Lowercase}/, "i =~ Lowercase");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDStart}/, "i =~ ID_Start");
+ ok("\N{SMALL ROMAN NUMERAL ONE}" =~ /\p{IDContinue}/, "i =~ ID_Continue");
+}
+
+{
+# requirement of Unicode Technical Standard #18, 1.7 Code Points
+# cf. http://www.unicode.org/reports/tr18/#Supplementary_Characters
+ for my $u (0x7FF, 0x800, 0xFFFF, 0x10000) {
+ no warnings 'utf8'; # oops
+ my $c = chr $u;
+ my $x = sprintf '%04X', $u;
+ ok( "A${c}B" =~ /A[\0-\x{10000}]B/, "unicode range - $x");
+ }
+}
+
+{
+ my $res="";
+
+ if ('1' =~ /(?|(?<digit>1)|(?<digit>2))/) {
+ $res = "@{$- {digit}}";
+ }
+ iseq($res,"1",
+ "Check that (?|...) doesnt cause dupe entries in the names array");
+ #---
+ $res="";
+ if ('11' =~ /(?|(?<digit>1)|(?<digit>2))(?&digit)/) {
+ $res = "@{$- {digit}}";
+ }
+ iseq($res, "1",
+ "Check that (?&..) to a buffer inside a (?|...) goes to the leftmost");
+}
+
+{
+ use warnings;
+ local $Message = "ASCII pattern that really is utf8";
+ my @w;
+ local $SIG{__WARN__}=sub{push @w,"@_"};
+ my $c=qq(\x{DF});
+ ok($c=~/${c}|\x{100}/);
+ ok(@w==0);
+}
+{
+ local $Message = "corruption of match results of qr// across scopes";
+ my $qr=qr/(fo+)(ba+r)/;
+ 'foobar'=~/$qr/;
+ iseq("$1$2","foobar");
+ {
+ 'foooooobaaaaar'=~/$qr/;
+ iseq("$1$2",'foooooobaaaaar');
+ }
+ iseq("$1$2","foobar");
+}
+{
+ local $Message = "HORIZWS";
+ local $_="\t \r\n \n \t".chr(11)."\n";
+ s/\H/H/g;
+ s/\h/h/g;
+ iseq($_,"hhHHhHhhHH");
+ $_="\t \r\n \n \t".chr(11)."\n";
+ utf8::upgrade($_);
+ s/\H/H/g;
+ s/\h/h/g;
+ iseq($_,"hhHHhHhhHH");
+}
+{
+ local $Message = "Various whitespace special patterns";
+ my @h=map { chr( $_ ) } (
+ 0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, 0x2001, 0x2002,
+ 0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200a,
+ 0x202f, 0x205f, 0x3000
+ );
+ my @v=map { chr( $_ ) } ( 0x0a, 0x0b, 0x0c, 0x0d, 0x85, 0x2028, 0x2029 );
+ my @lb=( "\x0D\x0A",
+ map { chr( $_ ) } ( 0x0A..0x0D,0x85,0x2028,0x2029 ));
+ foreach my $t ([\@h,qr/\h/,qr/\h+/],[\@v,qr/\v/,qr/\v+/],[\@lb,qr/\R/,qr/\R+/],){
+ my $ary=shift @$t;
+ foreach my $pat (@$t) {
+ foreach my $str (@$ary) {
+ ok($str=~/($pat)/,$pat);
+ iseq($1,$str,$pat);
+ utf8::upgrade($str);
+ ok($str=~/($pat)/,"Upgraded string - $pat");
+ iseq($1,$str,"Upgraded string - $pat");
+ }
+ }
+ }
+}
+{
+ local $Message = "Check that \\xDF match properly in its various forms";
+ # test that \xDF matches properly. this is pretty hacky stuff,
+ # but its actually needed. the malarky with '-' is to prevent
+ # compilation caching from playing any role in the test.
+ my @df= (chr(0xDF),'-',chr(0xDF));
+ utf8::upgrade($df[2]);
+ my @strs= ('ss','sS','Ss','SS',chr(0xDF));
+ my @ss= map { ("$_", "$_") } @strs;
+ utf8::upgrade($ss[$_*2+1]) for 0..$#strs;
+
+ for my $ssi (0..$#ss) {
+ for my $dfi (0..$#df) {
+ my $pat= $df[$dfi];
+ my $str= $ss[$ssi];
+ my $utf_df= ($dfi > 1) ? 'utf8' : '';
+ my $utf_ss= ($ssi % 2) ? 'utf8' : '';
+ (my $sstr=$str)=~s/\xDF/\\xDF/;
+
+ if ($utf_df || $utf_ss || length($ss[$ssi])==1) {
+ my $ret= $str=~/$pat/i;
+ next if $pat eq '-';
+ ok($ret,
+ "\"$sstr\"=~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})");
+ } else {
+ my $ret= $str !~ /$pat/i;
+ next if $pat eq '-';
+ ok($ret,
+ "\"$sstr\"!~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})");
+ }
+ }
+ }
+}
+{
+ local $Message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte";
+ my $re = qr/(?:[\x00-\xFF]{4})/;
+ my $hyp = "\0\0\0-";
+ my $esc = "\0\0\0\\";
+
+ my $str = "$esc$hyp$hyp$esc$esc";
+ my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g);
+
+ iseq(0+@a,3);
+ iseq(join('=', @a),"$esc$hyp=$hyp=$esc$esc");
+}
+# test for keys in %+ and %-
+{
+ my $_ = "abcdef";
+ /(?<foo>a)|(?<foo>b)/;
+ iseq( (join ",", sort keys %+), "foo" );
+ iseq( (join ",", sort keys %-), "foo" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), "a " );
+ /(?<bar>a)(?<bar>b)(?<quux>.)/;
+ iseq( (join ",", sort keys %+), "bar,quux" );
+ iseq( (join ",", sort keys %-), "bar,quux" );
+ iseq( (join ",", sort values %+), "a,c" ); # leftmost
+ iseq( (join ",", sort map "@$_", values %-), "a b,c" );
+ /(?<un>a)(?<deux>c)?/; # second buffer won't capture
+ iseq( (join ",", sort keys %+), "un" );
+ iseq( (join ",", sort keys %-), "deux,un" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), ",a" );
+}
+
+# length() on captures, the numbered ones end up in Perl_magic_len
+{
+ my $_ = "aoeu \xe6var ook";
+ /^ \w+ \s (?<eek>\S+)/x;
+
+ iseq( length($`), 0, 'length $`' );
+ iseq( length($'), 4, q[length $'] );
+ iseq( length($&), 9, 'length $&' );
+ iseq( length($1), 4, 'length $1' );
+ iseq( length($+{eek}), 4, 'length $+{eek} == length $1' );
+}
+
+{
+ my $ok=-1;
+
+ $ok=exists($-{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,0,'$+{x} not exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($-{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 1, 'scalar %+ == 1 after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "foo"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$+{x} exists after "foo"=~/(?<x>foo)|bar/');
+}
+{
+ local $_;
+ ($_ = 'abc')=~/(abc)/g;
+ $_ = '123';
+ iseq("$1",'abc',"/g leads to unsafe match vars: $1");
+}
+{
+ local $Message="Message-ID: <20070818091501.7eff4831@r2d2>";
+ my $str= "";
+ for(0..5){
+ my @x;
+ $str .= "@x"; # this should ALWAYS be the empty string
+ 'a'=~/(a|)/;
+ push @x,1;
+ }
+ iseq(length($str),"0","Trie scope error, string should be empty");
+ $str="";
+ my @foo = ('a')x5;
+ for (@foo) {
+ my @bar;
+ $str .= "@bar";
+ s/a|/push @bar, 1/e;
+ }
+ iseq(length($str),"0","Trie scope error, string should be empty");
+}
+{
+# [perl #45605] Regexp failure with utf8-flagged and byte-flagged string
+
+ my $utf_8 = "\xd6schel";
+ utf8::upgrade($utf_8);
+ $utf_8 =~ m{(\xd6|Ö)schel};
+ iseq($1,"\xd6","#45605");
+}
+
+{
+ # Regardless of utf8ness any character matches itself when
+ # doing a case insensitive match. See also [perl #36207]
+ for my $o (0..255) {
+ my @ch=(chr($o),chr($o));
+ utf8::upgrade($ch[1]);
+ for my $u_str (0,1) {
+ for my $u_pat (0,1) {
+ ok( $ch[$u_str]=~/\Q$ch[$u_pat]\E/i,
+ "\$c=~/\$c/i : chr($o) : u_str=$u_str u_pat=$u_pat");
+ ok( $ch[$u_str]=~/\Q$ch[$u_pat]\E|xyz/i,
+ "# \$c=~/\$c|xyz/i : chr($o) : u_str=$u_str u_pat=$u_pat");
+ }
+ }
+ }
+}
+{
+ my $a = 3; "" =~ /(??{ $a })/;
+ my $b = $a;
+ iseq($b, $a, "copy of scalar used for postponed subexpression");
+}
+{
+ local $Message = "\$REGMARK in replacement -- Bug #49190";
+ my $_ = "A";
+ s/(*:B)A/$REGMARK/;
+ iseq $_, "B";
+ $_ = "CCCCBAA";
+ s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g;
+ iseq $_, "ZYX";
+}
+if ($::running_as_thread) {
+ for (1..3) {
+ print "not ok $test # TODO & SKIP: croaks when threaded\n";
+ $test++;
+ }
+} else {
+ our @ctl_n=();
+ our @plus=();
+ our $nested_tags;
+ $nested_tags = qr{
+ <
+ (\w+)
+ (?{
+ push @ctl_n,$^N;
+ push @plus,$+;
+ })
+ >
+ (??{$nested_tags})*
+ </\s* \w+ \s*>
+ }x;
+
+ my $match= '<bla><blubb></blubb></bla>' =~ m/^$nested_tags$/;
+ ok($match,'nested construct matches');
+ iseq("@ctl_n","bla blubb",'$^N inside of (?{}) works as expected');
+ iseq("@plus","bla blubb",'$+ inside of (?{}) works as expected');
+}
+
+
+
+
+# Test counter is at bottom of file. Put new tests above here.
+#-------------------------------------------------------------------
+# Keep the following tests last -- they may crash perl
+{
+ # RT#19049 / RT#38869
+ my @list = (
+ 'ab cdef', # matches regex
+ ( 'e' x 40000 ) .'ab c' # matches not, but 'ab c' matches part of it
+ );
+ my $y;
+ my $x;
+ foreach (@list) {
+ m/ab(.+)cd/i; # the ignore-case seems to be important
+ $y = $1; # use $1, which might not be from the last match!
+ $x = substr($list[0],$-[0],$+[0]-$-[0]);
+ }
+ iseq($y,' ',
+ 'pattern in a loop, failure should not affect previous success');
+ iseq($x,'ab cd',
+ 'pattern in a loop, failure should not affect previous success');
+}
+
+ok(("a" x (2**15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker: #24274")
+ or print "# Unexpected outcome: should pass or crash perl\n";
+
+ok((q(a)x 100) =~ /^(??{'(.)'x 100})/,
+ "Regexp /^(??{'(.)'x 100})/ crashes older perls")
+ or print "# Unexpected outcome: should pass or crash perl\n";
+
+eval '/\k/';
+ok($@=~/\QSequence \k... not terminated in regex;\E/);
+
+{
+ local $Message = "substitution with lookahead (possible segv)";
+ $_="ns1ns1ns1";
+ s/ns(?=\d)/ns_/g;
+ iseq($_,"ns_1ns_1ns_1");
+ $_="ns1";
+ s/ns(?=\d)/ns_/;
+ iseq($_,"ns_1");
+ $_="123";
+ s/(?=\d+)|(?<=\d)/!Bang!/g;
+ iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
+}
+
+# [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache
+
+{
+ local ${^UTF8CACHE} = -1;
+ my $s="[a]a{2}";
+ utf8::upgrade $s;
+ ok("aaa" =~ /$s/, "#45337");
+}
+
+# Put new tests above the dotted line about a page above this comment
+iseq(0+$::test,$::TestCount,"Got the right number of tests!");
+
+} # end of sub pat_tests
+
+# Don't forget to update this!
+BEGIN {
+ $::TestCount = 4019;
+ print "1..$::TestCount\n";
+}
+"Truth";
https://perl5.git.perl.org / perl5.git / blobdiff