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