Commit | Line | Data |
8d063cd8 |
1 | #!./perl |
8d37f932 |
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 |
ff3f963a |
5 | # that does fit that format, add it to re/re_tests, not here. Tests for \N |
6 | # should be added here because they are treated as single quoted strings |
7 | # there, which means they avoid the lexer which otherwise would look at them. |
8d063cd8 |
8 | |
84281c31 |
9 | use strict; |
10 | use warnings; |
11 | use 5.010; |
12 | |
13 | |
14 | sub run_tests; |
15 | |
9133bbab |
16 | $| = 1; |
3568d838 |
17 | |
8d37f932 |
18 | |
e4d48cc9 |
19 | BEGIN { |
20 | chdir 't' if -d 't'; |
9d45b377 |
21 | @INC = ('../lib','.'); |
22 | do "re/ReTest.pl" or die $@; |
e4d48cc9 |
23 | } |
84281c31 |
24 | |
84281c31 |
25 | |
37820adc |
26 | plan tests => 299; # Update this when adding/deleting tests. |
b7a35066 |
27 | |
9d45b377 |
28 | run_tests() unless caller; |
b7a35066 |
29 | |
84281c31 |
30 | # |
31 | # Tests start here. |
32 | # |
33 | sub run_tests { |
0ef3e39e |
34 | |
84281c31 |
35 | { |
b485d051 |
36 | |
84281c31 |
37 | my $x = "abc\ndef\n"; |
fd291da9 |
38 | |
84281c31 |
39 | ok $x =~ /^abc/, qq ["$x" =~ /^abc/]; |
40 | ok $x !~ /^def/, qq ["$x" !~ /^def/]; |
fd291da9 |
41 | |
84281c31 |
42 | # used to be a test for $* |
43 | ok $x =~ /^def/m, qq ["$x" =~ /^def/m]; |
fd291da9 |
44 | |
84281c31 |
45 | nok $x =~ /^xxx/, qq ["$x" =~ /^xxx/]; |
46 | nok $x !~ /^abc/, qq ["$x" !~ /^abc/]; |
fd291da9 |
47 | |
84281c31 |
48 | ok $x =~ /def/, qq ["$x" =~ /def/]; |
49 | nok $x !~ /def/, qq ["$x" !~ /def/]; |
4765795a |
50 | |
84281c31 |
51 | ok $x !~ /.def/, qq ["$x" !~ /.def/]; |
52 | nok $x =~ /.def/, qq ["$x" =~ /.def/]; |
4765795a |
53 | |
84281c31 |
54 | ok $x =~ /\ndef/, qq ["$x" =~ /\ndef/]; |
55 | nok $x !~ /\ndef/, qq ["$x" !~ /\ndef/]; |
56 | } |
4765795a |
57 | |
84281c31 |
58 | { |
59 | $_ = '123'; |
60 | ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/]; |
61 | } |
f9969324 |
62 | |
84281c31 |
63 | { |
64 | $_ = 'aaabbbccc'; |
65 | ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc', |
66 | qq [\$_ = '$_'; /(a*b*)(c*)/]; |
67 | ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/]; |
68 | nok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; |
69 | |
70 | $_ = 'aaabccc'; |
71 | ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; |
72 | ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; |
73 | |
74 | $_ = 'aaaccc'; |
75 | ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; |
76 | nok /a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]; |
77 | |
78 | $_ = 'abcdef'; |
79 | ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/]; |
80 | ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/]; |
81 | ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|]; |
82 | ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/]; |
4765795a |
83 | } |
4765795a |
84 | |
84281c31 |
85 | { |
86 | # used to be a test for $* |
87 | ok "ab\ncd\n" =~ /^cd/m, qq ["ab\ncd\n" =~ /^cd/m]; |
88 | } |
4765795a |
89 | |
84281c31 |
90 | { |
91 | our %XXX = map {($_ => $_)} 123, 234, 345; |
92 | |
93 | our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3'); |
94 | while ($_ = shift(@XXX)) { |
95 | my $f = index ($_, 'not') >= 0 ? \&nok : \&ok; |
96 | my $r = ?(.*)?; |
97 | &$f ($r, "?(.*)?"); |
98 | /not/ && reset; |
99 | if (/not ok 2/) { |
100 | if ($^O eq 'VMS') { |
101 | $_ = shift(@XXX); |
102 | } |
103 | else { |
104 | reset 'X'; |
105 | } |
106 | } |
107 | } |
4765795a |
108 | |
84281c31 |
109 | SKIP: { |
110 | if ($^O eq 'VMS') { |
111 | skip "Reset 'X'", 1; |
112 | } |
113 | ok !keys %XXX, "%XXX is empty"; |
114 | } |
4765795a |
115 | |
84281c31 |
116 | } |
4765795a |
117 | |
84281c31 |
118 | { |
119 | local $Message = "Test empty pattern"; |
120 | my $xyz = 'xyz'; |
121 | my $cde = 'cde'; |
122 | |
123 | $cde =~ /[^ab]*/; |
124 | $xyz =~ //; |
125 | iseq $&, $xyz; |
126 | |
127 | my $foo = '[^ab]*'; |
128 | $cde =~ /$foo/; |
129 | $xyz =~ //; |
130 | iseq $&, $xyz; |
131 | |
132 | $cde =~ /$foo/; |
133 | my $null; |
134 | no warnings 'uninitialized'; |
135 | $xyz =~ /$null/; |
136 | iseq $&, $xyz; |
137 | |
138 | $null = ""; |
139 | $xyz =~ /$null/; |
140 | iseq $&, $xyz; |
141 | } |
4765795a |
142 | |
84281c31 |
143 | { |
144 | local $Message = q !Check $`, $&, $'!; |
145 | $_ = 'abcdefghi'; |
0f289c68 |
146 | /def/; # optimized up to cmd |
84281c31 |
147 | iseq "$`:$&:$'", 'abc:def:ghi'; |
4765795a |
148 | |
84281c31 |
149 | no warnings 'void'; |
0f289c68 |
150 | /cde/ + 0; # optimized only to spat |
84281c31 |
151 | iseq "$`:$&:$'", 'ab:cde:fghi'; |
4765795a |
152 | |
0f289c68 |
153 | /[d][e][f]/; # not optimized |
84281c31 |
154 | iseq "$`:$&:$'", 'abc:def:ghi'; |
155 | } |
4765795a |
156 | |
84281c31 |
157 | { |
158 | $_ = 'now is the {time for all} good men to come to.'; |
159 | / {([^}]*)}/; |
160 | iseq $1, 'time for all', "Match braces"; |
161 | } |
4765795a |
162 | |
84281c31 |
163 | { |
164 | local $Message = "{N,M} quantifier"; |
165 | $_ = 'xxx {3,4} yyy zzz'; |
166 | ok /( {3,4})/; |
167 | iseq $1, ' '; |
168 | ok !/( {4,})/; |
169 | ok /( {2,3}.)/; |
170 | iseq $1, ' y'; |
171 | ok /(y{2,3}.)/; |
172 | iseq $1, 'yyy '; |
173 | ok !/x {3,4}/; |
174 | ok !/^xxx {3,4}/; |
175 | } |
4765795a |
176 | |
84281c31 |
177 | { |
178 | local $Message = "Test /g"; |
179 | local $" = ":"; |
180 | $_ = "now is the time for all good men to come to."; |
181 | my @words = /(\w+)/g; |
182 | my $exp = "now:is:the:time:for:all:good:men:to:come:to"; |
4765795a |
183 | |
84281c31 |
184 | iseq "@words", $exp; |
4765795a |
185 | |
84281c31 |
186 | @words = (); |
187 | while (/\w+/g) { |
188 | push (@words, $&); |
189 | } |
190 | iseq "@words", $exp; |
4765795a |
191 | |
84281c31 |
192 | @words = (); |
193 | pos = 0; |
194 | while (/to/g) { |
195 | push(@words, $&); |
196 | } |
197 | iseq "@words", "to:to"; |
4765795a |
198 | |
84281c31 |
199 | pos $_ = 0; |
200 | @words = /to/g; |
201 | iseq "@words", "to:to"; |
202 | } |
4765795a |
203 | |
84281c31 |
204 | { |
205 | $_ = "abcdefghi"; |
206 | |
207 | my $pat1 = 'def'; |
208 | my $pat2 = '^def'; |
209 | my $pat3 = '.def.'; |
210 | my $pat4 = 'abc'; |
211 | my $pat5 = '^abc'; |
212 | my $pat6 = 'abc$'; |
213 | my $pat7 = 'ghi'; |
214 | my $pat8 = '\w*ghi'; |
215 | my $pat9 = 'ghi$'; |
216 | |
217 | my $t1 = my $t2 = my $t3 = my $t4 = my $t5 = |
218 | my $t6 = my $t7 = my $t8 = my $t9 = 0; |
219 | |
220 | for my $iter (1 .. 5) { |
221 | $t1++ if /$pat1/o; |
222 | $t2++ if /$pat2/o; |
223 | $t3++ if /$pat3/o; |
224 | $t4++ if /$pat4/o; |
225 | $t5++ if /$pat5/o; |
226 | $t6++ if /$pat6/o; |
227 | $t7++ if /$pat7/o; |
228 | $t8++ if /$pat8/o; |
229 | $t9++ if /$pat9/o; |
230 | } |
231 | my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; |
232 | iseq $x, '505550555', "Test /o"; |
233 | } |
4765795a |
234 | |
4765795a |
235 | |
84281c31 |
236 | SKIP: { |
237 | my $xyz = 'xyz'; |
238 | ok "abc" =~ /^abc$|$xyz/, "| after \$"; |
4765795a |
239 | |
84281c31 |
240 | # perl 4.009 says "unmatched ()" |
241 | local $Message = '$ inside ()'; |
4765795a |
242 | |
84281c31 |
243 | my $result; |
244 | eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; |
245 | iseq $@, "" or skip "eval failed", 1; |
246 | iseq $result, "abc:bc"; |
247 | } |
4765795a |
248 | |
4765795a |
249 | |
84281c31 |
250 | { |
251 | local $Message = "Scalar /g"; |
252 | $_ = "abcfooabcbar"; |
253 | |
254 | ok /abc/g && $` eq ""; |
255 | ok /abc/g && $` eq "abcfoo"; |
256 | ok !/abc/g; |
257 | |
258 | local $Message = "Scalar /gi"; |
259 | pos = 0; |
260 | ok /ABC/gi && $` eq ""; |
261 | ok /ABC/gi && $` eq "abcfoo"; |
262 | ok !/ABC/gi; |
263 | |
264 | local $Message = "Scalar /g"; |
265 | pos = 0; |
266 | ok /abc/g && $' eq "fooabcbar"; |
267 | ok /abc/g && $' eq "bar"; |
268 | |
269 | $_ .= ''; |
270 | my @x = /abc/g; |
271 | iseq @x, 2, "/g reset after assignment"; |
4765795a |
272 | } |
4765795a |
273 | |
84281c31 |
274 | { |
275 | local $Message = '/g, \G and pos'; |
276 | $_ = "abdc"; |
277 | pos $_ = 2; |
278 | /\Gc/gc; |
279 | iseq pos $_, 2; |
280 | /\Gc/g; |
281 | ok !defined pos $_; |
282 | } |
4765795a |
283 | |
84281c31 |
284 | { |
285 | local $Message = '(?{ })'; |
286 | our $out = 1; |
287 | 'abc' =~ m'a(?{ $out = 2 })b'; |
288 | iseq $out, 2; |
289 | |
290 | $out = 1; |
291 | 'abc' =~ m'a(?{ $out = 3 })c'; |
292 | iseq $out, 1; |
293 | } |
4765795a |
294 | |
4765795a |
295 | |
84281c31 |
296 | { |
297 | $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; |
298 | my @out = /(?<!foo)bar./g; |
299 | iseq "@out", 'bar2 barf', "Negative lookbehind"; |
300 | } |
4765795a |
301 | |
84281c31 |
302 | { |
303 | local $Message = "REG_INFTY tests"; |
304 | # Tests which depend on REG_INFTY |
305 | $::reg_infty = $Config {reg_infty} // 32767; |
306 | $::reg_infty_m = $::reg_infty - 1; |
307 | $::reg_infty_p = $::reg_infty + 1; |
308 | $::reg_infty_m = $::reg_infty_m; # Surpress warning. |
309 | |
310 | # As well as failing if the pattern matches do unexpected things, the |
311 | # next three tests will fail if you should have picked up a lower-than- |
312 | # default value for $reg_infty from Config.pm, but have not. |
313 | |
314 | eval_ok q (('aaa' =~ /(a{1,$::reg_infty_m})/)[0] eq 'aaa'); |
315 | eval_ok q (('a' x $::reg_infty_m) =~ /a{$::reg_infty_m}/); |
316 | eval_ok q (('a' x ($::reg_infty_m - 1)) !~ /a{$::reg_infty_m}/); |
317 | eval "'aaa' =~ /a{1,$::reg_infty}/"; |
318 | ok $@ =~ /^\QQuantifier in {,} bigger than/; |
319 | eval "'aaa' =~ /a{1,$::reg_infty_p}/"; |
320 | ok $@ =~ /^\QQuantifier in {,} bigger than/; |
4765795a |
321 | } |
8269fa76 |
322 | |
84281c31 |
323 | { |
324 | # Poke a couple more parse failures |
325 | my $context = 'x' x 256; |
326 | eval qq("${context}y" =~ /(?<=$context)y/); |
327 | ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit"; |
328 | } |
8269fa76 |
329 | |
84281c31 |
330 | { |
331 | # Long Monsters |
332 | local $Message = "Long monster"; |
333 | for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory |
334 | my $a = 'a' x $l; |
335 | local $Error = "length = $l"; |
336 | ok "ba$a=" =~ /a$a=/; |
337 | nok "b$a=" =~ /a$a=/; |
338 | ok "b$a=" =~ /ba+=/; |
339 | |
84281c31 |
340 | ok "ba$a=" =~ /b(?:a|b)+=/; |
341 | } |
342 | } |
8269fa76 |
343 | |
b8ef571c |
344 | |
84281c31 |
345 | { |
346 | # 20000 nodes, each taking 3 words per string, and 1 per branch |
347 | my $long_constant_len = join '|', 12120 .. 32645; |
348 | my $long_var_len = join '|', 8120 .. 28645; |
349 | my %ans = ( 'ax13876y25677lbc' => 1, |
350 | 'ax13876y25677mcb' => 0, # not b. |
351 | 'ax13876y35677nbc' => 0, # Num too big |
352 | 'ax13876y25677y21378obc' => 1, |
0f289c68 |
353 | 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] |
84281c31 |
354 | 'ax13876y25677y21378y21378kbc' => 1, |
355 | 'ax13876y25677y21378y21378kcb' => 0, # Not b. |
356 | 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs |
357 | ); |
358 | |
359 | local $Message = "20000 nodes"; |
360 | for (keys %ans) { |
361 | local $Error = "const-len '$_'"; |
362 | ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o); |
363 | |
364 | local $Error = "var-len '$_'"; |
365 | ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o); |
366 | } |
b8ef571c |
367 | } |
209a9bc1 |
368 | |
84281c31 |
369 | { |
370 | local $Message = "Complicated backtracking"; |
371 | $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e"; |
372 | my $expect = "(bla()) ((l)u((e))) (l(e)e)"; |
373 | |
374 | use vars '$c'; |
375 | sub matchit { |
376 | m/ |
377 | ( |
378 | \( |
0f289c68 |
379 | (?{ $c = 1 }) # Initialize |
84281c31 |
380 | (?: |
381 | (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop |
382 | (?! |
0f289c68 |
383 | ) # Fail: will unwind one iteration back |
384 | ) |
84281c31 |
385 | (?: |
0f289c68 |
386 | [^()]+ # Match a big chunk |
84281c31 |
387 | (?= |
388 | [()] |
0f289c68 |
389 | ) # Do not try to match subchunks |
84281c31 |
390 | | |
391 | \( |
392 | (?{ ++$c }) |
393 | | |
394 | \) |
395 | (?{ --$c }) |
396 | ) |
0f289c68 |
397 | )+ # This may not match with different subblocks |
84281c31 |
398 | ) |
399 | (?(?{ $c != 0 }) |
400 | (?! |
0f289c68 |
401 | ) # Fail |
402 | ) # Otherwise the chunk 1 may succeed with $c>0 |
84281c31 |
403 | /xg; |
404 | } |
3568d838 |
405 | |
84281c31 |
406 | my @ans = (); |
407 | my $res; |
408 | push @ans, $res while $res = matchit; |
409 | iseq "@ans", "1 1 1"; |
3568d838 |
410 | |
84281c31 |
411 | @ans = matchit; |
412 | iseq "@ans", $expect; |
3568d838 |
413 | |
84281c31 |
414 | local $Message = "Recursion with (??{ })"; |
415 | our $matched; |
416 | $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; |
3568d838 |
417 | |
84281c31 |
418 | @ans = my @ans1 = (); |
419 | push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g; |
3568d838 |
420 | |
84281c31 |
421 | iseq "@ans", "1 1 1"; |
422 | iseq "@ans1", $expect; |
3568d838 |
423 | |
84281c31 |
424 | @ans = m/$matched/g; |
425 | iseq "@ans", $expect; |
3568d838 |
426 | |
84281c31 |
427 | } |
3568d838 |
428 | |
84281c31 |
429 | { |
430 | ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/'; |
431 | } |
3568d838 |
432 | |
84281c31 |
433 | { |
0f289c68 |
434 | my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad |
84281c31 |
435 | iseq "@ans", 'a/ b', "Stack may be bad"; |
436 | } |
3568d838 |
437 | |
84281c31 |
438 | { |
439 | local $Message = "Eval-group not allowed at runtime"; |
440 | my $code = '{$blah = 45}'; |
441 | our $blah = 12; |
442 | eval { /(?$code)/ }; |
443 | ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12; |
444 | |
445 | for $code ('{$blah = 45}','=xx') { |
446 | $blah = 12; |
447 | my $res = eval { "xx" =~ /(?$code)/o }; |
448 | no warnings 'uninitialized'; |
449 | local $Error = "'$@', '$res', '$blah'"; |
450 | if ($code eq '=xx') { |
451 | ok !$@ && $res; |
452 | } |
453 | else { |
454 | ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12; |
455 | } |
456 | } |
3568d838 |
457 | |
84281c31 |
458 | $code = '{$blah = 45}'; |
459 | $blah = 12; |
460 | eval "/(?$code)/"; |
461 | iseq $blah, 45; |
3568d838 |
462 | |
84281c31 |
463 | $blah = 12; |
464 | /(?{$blah = 45})/; |
465 | iseq $blah, 45; |
466 | } |
3568d838 |
467 | |
84281c31 |
468 | { |
469 | local $Message = "Pos checks"; |
470 | my $x = 'banana'; |
471 | $x =~ /.a/g; |
472 | iseq pos ($x), 2; |
3568d838 |
473 | |
84281c31 |
474 | $x =~ /.z/gc; |
475 | iseq pos ($x), 2; |
3568d838 |
476 | |
84281c31 |
477 | sub f { |
478 | my $p = $_[0]; |
479 | return $p; |
480 | } |
3568d838 |
481 | |
84281c31 |
482 | $x =~ /.a/g; |
483 | iseq f (pos ($x)), 4; |
484 | } |
3568d838 |
485 | |
84281c31 |
486 | { |
487 | local $Message = 'Checking $^R'; |
488 | our $x = $^R = 67; |
489 | 'foot' =~ /foo(?{$x = 12; 75})[t]/; |
490 | iseq $^R, 75; |
491 | |
492 | $x = $^R = 67; |
493 | 'foot' =~ /foo(?{$x = 12; 75})[xy]/; |
494 | ok $^R eq '67' && $x eq '12'; |
495 | |
496 | $x = $^R = 67; |
497 | 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; |
498 | ok $^R eq '79' && $x eq '12'; |
499 | } |
3568d838 |
500 | |
84281c31 |
501 | { |
502 | iseq qr/\b\v$/i, '(?i-xsm:\b\v$)', 'qr/\b\v$/i'; |
503 | iseq qr/\b\v$/s, '(?s-xim:\b\v$)', 'qr/\b\v$/s'; |
504 | iseq qr/\b\v$/m, '(?m-xis:\b\v$)', 'qr/\b\v$/m'; |
505 | iseq qr/\b\v$/x, '(?x-ism:\b\v$)', 'qr/\b\v$/x'; |
506 | iseq qr/\b\v$/xism, '(?msix:\b\v$)', 'qr/\b\v$/xism'; |
507 | iseq qr/\b\v$/, '(?-xism:\b\v$)', 'qr/\b\v$/'; |
508 | } |
3568d838 |
509 | |
3568d838 |
510 | |
84281c31 |
511 | { |
512 | local $Message = "Look around"; |
513 | $_ = 'xabcx'; |
514 | SKIP: |
515 | foreach my $ans ('', 'c') { |
516 | ok /(?<=(?=a)..)((?=c)|.)/g or skip "Match failed", 1; |
517 | iseq $1, $ans; |
518 | } |
519 | } |
3568d838 |
520 | |
84281c31 |
521 | { |
522 | local $Message = "Empty clause"; |
523 | $_ = 'a'; |
524 | foreach my $ans ('', 'a', '') { |
525 | ok /^|a|$/g or skip "Match failed", 1; |
526 | iseq $&, $ans; |
527 | } |
528 | } |
3568d838 |
529 | |
84281c31 |
530 | { |
531 | local $Message = "Prefixify"; |
532 | sub prefixify { |
533 | SKIP: { |
534 | my ($v, $a, $b, $res) = @_; |
535 | ok $v =~ s/\Q$a\E/$b/ or skip "Match failed", 1; |
536 | iseq $v, $res; |
537 | } |
538 | } |
3568d838 |
539 | |
84281c31 |
540 | prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); |
541 | prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); |
542 | } |
3568d838 |
543 | |
84281c31 |
544 | { |
545 | $_ = 'var="foo"'; |
546 | /(\")/; |
547 | ok $1 && /$1/, "Capture a quote"; |
548 | } |
3568d838 |
549 | |
84281c31 |
550 | { |
84281c31 |
551 | no warnings 'closure'; |
552 | local $Message = '(?{ $var } refers to package vars'; |
553 | package aa; |
554 | our $c = 2; |
555 | $::c = 3; |
556 | '' =~ /(?{ $c = 4 })/; |
557 | main::iseq $c, 4; |
558 | main::iseq $::c, 3; |
559 | } |
3568d838 |
560 | |
84281c31 |
561 | { |
562 | must_die 'q(a:[b]:) =~ /[x[:foo:]]/', |
563 | 'POSIX class \[:[^:]+:\] unknown in regex', |
564 | 'POSIX class [: :] must have valid name'; |
565 | |
566 | for my $d (qw [= .]) { |
567 | must_die "/[[${d}foo${d}]]/", |
568 | "\QPOSIX syntax [$d $d] is reserved for future extensions", |
569 | "POSIX syntax [[$d $d]] is an error"; |
570 | } |
571 | } |
3568d838 |
572 | |
3568d838 |
573 | |
84281c31 |
574 | { |
575 | # test if failure of patterns returns empty list |
576 | local $Message = "Failed pattern returns empty list"; |
577 | $_ = 'aaa'; |
578 | @_ = /bbb/; |
579 | iseq "@_", ""; |
3568d838 |
580 | |
84281c31 |
581 | @_ = /bbb/g; |
582 | iseq "@_", ""; |
a72deede |
583 | |
84281c31 |
584 | @_ = /(bbb)/; |
585 | iseq "@_", ""; |
a72deede |
586 | |
84281c31 |
587 | @_ = /(bbb)/g; |
588 | iseq "@_", ""; |
589 | } |
a72deede |
590 | |
0f289c68 |
591 | |
84281c31 |
592 | { |
593 | local $Message = '@- and @+ tests'; |
594 | |
595 | /a(?=.$)/; |
596 | iseq $#+, 0; |
597 | iseq $#-, 0; |
598 | iseq $+ [0], 2; |
599 | iseq $- [0], 1; |
600 | ok !defined $+ [1] && !defined $- [1] && |
601 | !defined $+ [2] && !defined $- [2]; |
602 | |
603 | /a(a)(a)/; |
604 | iseq $#+, 2; |
605 | iseq $#-, 2; |
606 | iseq $+ [0], 3; |
607 | iseq $- [0], 0; |
608 | iseq $+ [1], 2; |
609 | iseq $- [1], 1; |
610 | iseq $+ [2], 3; |
611 | iseq $- [2], 2; |
612 | ok !defined $+ [3] && !defined $- [3] && |
613 | !defined $+ [4] && !defined $- [4]; |
614 | |
615 | |
616 | /.(a)(b)?(a)/; |
617 | iseq $#+, 3; |
618 | iseq $#-, 3; |
619 | iseq $+ [1], 2; |
620 | iseq $- [1], 1; |
621 | iseq $+ [3], 3; |
622 | iseq $- [3], 2; |
623 | ok !defined $+ [2] && !defined $- [2] && |
624 | !defined $+ [4] && !defined $- [4]; |
625 | |
626 | |
627 | /.(a)/; |
628 | iseq $#+, 1; |
629 | iseq $#-, 1; |
630 | iseq $+ [0], 2; |
631 | iseq $- [0], 0; |
632 | iseq $+ [1], 2; |
633 | iseq $- [1], 1; |
634 | ok !defined $+ [2] && !defined $- [2] && |
635 | !defined $+ [3] && !defined $- [3]; |
636 | |
637 | /.(a)(ba*)?/; |
638 | iseq $#+, 2; |
639 | iseq $#-, 1; |
640 | } |
a72deede |
641 | |
a72deede |
642 | |
84281c31 |
643 | { |
644 | local $DiePattern = '^Modification of a read-only value attempted'; |
645 | local $Message = 'Elements of @- and @+ are read-only'; |
646 | must_die '$+[0] = 13'; |
647 | must_die '$-[0] = 13'; |
648 | must_die '@+ = (7, 6, 5)'; |
649 | must_die '@- = qw (foo bar)'; |
650 | } |
a72deede |
651 | |
a72deede |
652 | |
84281c31 |
653 | { |
654 | local $Message = '\G testing'; |
655 | $_ = 'aaa'; |
656 | pos = 1; |
657 | my @a = /\Ga/g; |
658 | iseq "@a", "a a"; |
659 | |
660 | my $str = 'abcde'; |
661 | pos $str = 2; |
662 | ok $str !~ /^\G/; |
663 | ok $str !~ /^.\G/; |
664 | ok $str =~ /^..\G/; |
665 | ok $str !~ /^...\G/; |
666 | ok $str =~ /\G../ && $& eq 'cd'; |
667 | |
668 | local $TODO = $running_as_thread; |
669 | ok $str =~ /.\G./ && $& eq 'bc'; |
670 | } |
a72deede |
671 | |
569b5e07 |
672 | |
84281c31 |
673 | { |
674 | local $Message = 'pos inside (?{ })'; |
675 | my $str = 'abcde'; |
676 | our ($foo, $bar); |
677 | ok $str =~ /b(?{$foo = $_; $bar = pos})c/; |
678 | iseq $foo, $str; |
679 | iseq $bar, 2; |
680 | ok !defined pos ($str); |
681 | |
682 | undef $foo; |
683 | undef $bar; |
684 | pos $str = undef; |
685 | ok $str =~ /b(?{$foo = $_; $bar = pos})c/g; |
686 | iseq $foo, $str; |
687 | iseq $bar, 2; |
688 | iseq pos ($str), 3; |
689 | |
690 | $_ = $str; |
691 | undef $foo; |
692 | undef $bar; |
693 | ok /b(?{$foo = $_; $bar = pos})c/; |
694 | iseq $foo, $str; |
695 | iseq $bar, 2; |
696 | |
697 | undef $foo; |
698 | undef $bar; |
699 | ok /b(?{$foo = $_; $bar = pos})c/g; |
700 | iseq $foo, $str; |
701 | iseq $bar, 2; |
702 | iseq pos, 3; |
703 | |
704 | undef $foo; |
705 | undef $bar; |
706 | pos = undef; |
707 | 1 while /b(?{$foo = $_; $bar = pos})c/g; |
708 | iseq $foo, $str; |
709 | iseq $bar, 2; |
710 | ok !defined pos; |
711 | |
712 | undef $foo; |
713 | undef $bar; |
714 | $_ = 'abcde|abcde'; |
715 | ok s/b(?{$foo = $_; $bar = pos})c/x/g; |
716 | iseq $foo, 'abcde|abcde'; |
717 | iseq $bar, 8; |
718 | iseq $_, 'axde|axde'; |
719 | |
720 | # List context: |
721 | $_ = 'abcde|abcde'; |
722 | our @res; |
723 | () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; |
724 | @res = map {defined $_ ? "'$_'" : 'undef'} @res; |
725 | iseq "@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; |
726 | |
727 | @res = (); |
728 | () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; |
729 | @res = map {defined $_ ? "'$_'" : 'undef'} @res; |
730 | iseq "@res", "'' 'ab' 'cde|abcde' " . |
731 | "'' 'abc' 'de|abcde' " . |
732 | "'abcd' 'e|' 'abcde' " . |
733 | "'abcde|' 'ab' 'cde' " . |
734 | "'abcde|' 'abc' 'de'" ; |
735 | } |
f33976b4 |
736 | |
cce850e4 |
737 | |
84281c31 |
738 | { |
739 | local $Message = '\G anchor checks'; |
740 | my $foo = 'aabbccddeeffgg'; |
741 | pos ($foo) = 1; |
742 | { |
743 | local $TODO = $running_as_thread; |
744 | no warnings 'uninitialized'; |
745 | ok $foo =~ /.\G(..)/g; |
746 | iseq $1, 'ab'; |
cce850e4 |
747 | |
84281c31 |
748 | pos ($foo) += 1; |
749 | ok $foo =~ /.\G(..)/g; |
750 | iseq $1, 'cc'; |
cce850e4 |
751 | |
84281c31 |
752 | pos ($foo) += 1; |
753 | ok $foo =~ /.\G(..)/g; |
754 | iseq $1, 'de'; |
cce850e4 |
755 | |
84281c31 |
756 | ok $foo =~ /\Gef/g; |
757 | } |
cce850e4 |
758 | |
84281c31 |
759 | undef pos $foo; |
760 | ok $foo =~ /\G(..)/g; |
761 | iseq $1, 'aa'; |
cce850e4 |
762 | |
84281c31 |
763 | ok $foo =~ /\G(..)/g; |
764 | iseq $1, 'bb'; |
cce850e4 |
765 | |
84281c31 |
766 | pos ($foo) = 5; |
767 | ok $foo =~ /\G(..)/g; |
768 | iseq $1, 'cd'; |
769 | } |
cce850e4 |
770 | |
cce850e4 |
771 | |
84281c31 |
772 | { |
773 | $_ = '123x123'; |
774 | my @res = /(\d*|x)/g; |
775 | local $" = '|'; |
776 | iseq "@res", "123||x|123|", "0 match in alternation"; |
777 | } |
cce850e4 |
778 | |
d9f424b2 |
779 | |
84281c31 |
780 | { |
781 | local $Message = "Match against temporaries (created via pp_helem())" . |
782 | " is safe"; |
783 | ok {foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g; |
784 | iseq $1, "bar"; |
785 | } |
75685a94 |
786 | |
d9f424b2 |
787 | |
84281c31 |
788 | { |
789 | local $Message = 'package $i inside (?{ }), ' . |
790 | 'saved substrings and changing $_'; |
791 | our @a = qw [foo bar]; |
792 | our @b = (); |
793 | s/(\w)(?{push @b, $1})/,$1,/g for @a; |
794 | iseq "@b", "f o o b a r"; |
795 | iseq "@a", ",f,,o,,o, ,b,,a,,r,"; |
796 | |
797 | local $Message = 'lexical $i inside (?{ }), ' . |
798 | 'saved substrings and changing $_'; |
799 | no warnings 'closure'; |
800 | my @c = qw [foo bar]; |
801 | my @d = (); |
802 | s/(\w)(?{push @d, $1})/,$1,/g for @c; |
803 | iseq "@d", "f o o b a r"; |
804 | iseq "@c", ",f,,o,,o, ,b,,a,,r,"; |
d9f424b2 |
805 | } |
806 | |
d9f424b2 |
807 | |
84281c31 |
808 | { |
809 | local $Message = 'Brackets'; |
810 | our $brackets; |
811 | $brackets = qr { |
812 | { (?> [^{}]+ | (??{ $brackets }) )* } |
813 | }x; |
814 | |
815 | ok "{{}" =~ $brackets; |
816 | iseq $&, "{}"; |
817 | ok "something { long { and } hairy" =~ $brackets; |
818 | iseq $&, "{ and }"; |
819 | ok "something { long { and } hairy" =~ m/((??{ $brackets }))/; |
820 | iseq $&, "{ and }"; |
821 | } |
a4c04bdc |
822 | |
e2d8ce26 |
823 | |
84281c31 |
824 | { |
825 | $_ = "a-a\nxbb"; |
826 | pos = 1; |
827 | nok m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg'; |
828 | } |
a4c04bdc |
829 | |
a4c04bdc |
830 | |
84281c31 |
831 | { |
832 | local $Message = '\G anchor checks'; |
833 | my $text = "aaXbXcc"; |
834 | pos ($text) = 0; |
835 | ok $text !~ /\GXb*X/g; |
836 | } |
a4c04bdc |
837 | |
a4c04bdc |
838 | |
84281c31 |
839 | { |
840 | $_ = "xA\n" x 500; |
841 | nok /^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"'; |
a4c04bdc |
842 | |
84281c31 |
843 | my $text = "abc dbf"; |
844 | my @res = ($text =~ /.*?(b).*?\b/g); |
845 | iseq "@res", "b b", '\b is not special'; |
987aaf07 |
846 | } |
a4c04bdc |
847 | |
a4c04bdc |
848 | |
84281c31 |
849 | { |
850 | local $Message = '\S, [\S], \s, [\s]'; |
851 | my @a = map chr, 0 .. 255; |
9d45b377 |
852 | my @b = grep m/\S/, @a; |
853 | my @c = grep m/[^\s]/, @a; |
84281c31 |
854 | iseq "@b", "@c"; |
855 | |
856 | @b = grep /\S/, @a; |
857 | @c = grep /[\S]/, @a; |
858 | iseq "@b", "@c"; |
859 | |
860 | @b = grep /\s/, @a; |
861 | @c = grep /[^\S]/, @a; |
862 | iseq "@b", "@c"; |
863 | |
864 | @b = grep /\s/, @a; |
865 | @c = grep /[\s]/, @a; |
866 | iseq "@b", "@c"; |
867 | } |
868 | { |
869 | local $Message = '\D, [\D], \d, [\d]'; |
870 | my @a = map chr, 0 .. 255; |
871 | my @b = grep /\D/, @a; |
872 | my @c = grep /[^\d]/, @a; |
873 | iseq "@b", "@c"; |
874 | |
875 | @b = grep /\D/, @a; |
876 | @c = grep /[\D]/, @a; |
877 | iseq "@b", "@c"; |
878 | |
879 | @b = grep /\d/, @a; |
880 | @c = grep /[^\D]/, @a; |
881 | iseq "@b", "@c"; |
882 | |
883 | @b = grep /\d/, @a; |
884 | @c = grep /[\d]/, @a; |
885 | iseq "@b", "@c"; |
886 | } |
887 | { |
888 | local $Message = '\W, [\W], \w, [\w]'; |
889 | my @a = map chr, 0 .. 255; |
890 | my @b = grep /\W/, @a; |
891 | my @c = grep /[^\w]/, @a; |
892 | iseq "@b", "@c"; |
893 | |
894 | @b = grep /\W/, @a; |
895 | @c = grep /[\W]/, @a; |
896 | iseq "@b", "@c"; |
897 | |
898 | @b = grep /\w/, @a; |
899 | @c = grep /[^\W]/, @a; |
900 | iseq "@b", "@c"; |
901 | |
902 | @b = grep /\w/, @a; |
903 | @c = grep /[\w]/, @a; |
904 | iseq "@b", "@c"; |
905 | } |
a4c04bdc |
906 | |
a4c04bdc |
907 | |
84281c31 |
908 | { |
909 | # see if backtracking optimization works correctly |
910 | local $Message = 'Backtrack optimization'; |
911 | ok "\n\n" =~ /\n $ \n/x; |
912 | ok "\n\n" =~ /\n* $ \n/x; |
913 | ok "\n\n" =~ /\n+ $ \n/x; |
914 | ok "\n\n" =~ /\n? $ \n/x; |
915 | ok "\n\n" =~ /\n*? $ \n/x; |
916 | ok "\n\n" =~ /\n+? $ \n/x; |
917 | ok "\n\n" =~ /\n?? $ \n/x; |
918 | ok "\n\n" !~ /\n*+ $ \n/x; |
919 | ok "\n\n" !~ /\n++ $ \n/x; |
920 | ok "\n\n" =~ /\n?+ $ \n/x; |
921 | } |
a4c04bdc |
922 | |
a4c04bdc |
923 | |
84281c31 |
924 | { |
925 | package S; |
926 | use overload '""' => sub {'Object S'}; |
927 | sub new {bless []} |
0f289c68 |
928 | |
9d45b377 |
929 | local $::Message = "Ref stringification"; |
84281c31 |
930 | ::ok do { \my $v} =~ /^SCALAR/, "Scalar ref stringification"; |
931 | ::ok do {\\my $v} =~ /^REF/, "Ref ref stringification"; |
932 | ::ok [] =~ /^ARRAY/, "Array ref stringification"; |
933 | ::ok {} =~ /^HASH/, "Hash ref stringification"; |
934 | ::ok 'S' -> new =~ /^Object S/, "Object stringification"; |
935 | } |
a4c04bdc |
936 | |
a4c04bdc |
937 | |
84281c31 |
938 | { |
939 | local $Message = "Test result of match used as match"; |
940 | ok 'a1b' =~ ('xyz' =~ /y/); |
941 | iseq $`, 'a'; |
942 | ok 'a1b' =~ ('xyz' =~ /t/); |
943 | iseq $`, 'a'; |
944 | } |
a4c04bdc |
945 | |
a4c04bdc |
946 | |
84281c31 |
947 | { |
948 | local $Message = '"1" is not \s'; |
949 | may_not_warn sub {ok ("1\n" x 102) !~ /^\s*\n/m}; |
950 | } |
a4c04bdc |
951 | |
a4c04bdc |
952 | |
84281c31 |
953 | { |
954 | local $Message = '\s, [[:space:]] and [[:blank:]]'; |
955 | my %space = (spc => " ", |
956 | tab => "\t", |
957 | cr => "\r", |
958 | lf => "\n", |
959 | ff => "\f", |
960 | # There's no \v but the vertical tabulator seems miraculously |
961 | # be 11 both in ASCII and EBCDIC. |
962 | vt => chr(11), |
963 | false => "space"); |
964 | |
965 | my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space; |
966 | my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space; |
967 | my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space; |
968 | |
969 | iseq "@space0", "cr ff lf spc tab"; |
970 | iseq "@space1", "cr ff lf spc tab vt"; |
971 | iseq "@space2", "spc tab"; |
972 | } |
a4c04bdc |
973 | |
ff3f963a |
974 | { |
975 | use charnames ":full"; |
976 | local $Message = 'Delayed interpolation of \N'; |
977 | my $r1 = qr/\N{THAI CHARACTER SARA I}/; |
978 | my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}"; |
979 | |
980 | # Bug #56444 |
981 | ok $s1 =~ /$r1+/, 'my $r1 = qr/\N{THAI CHARACTER SARA I}/; my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}; $s1 =~ /$r1+/'; |
982 | |
983 | # Bug #62056 |
984 | ok "${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/, '"${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/'; |
985 | |
986 | ok "abbbbc" =~ m/\N{1}/ && $& eq "a", '"abbbbc" =~ m/\N{1}/ && $& eq "a"'; |
987 | ok "abbbbc" =~ m/\N{3,4}/ && $& eq "abbb", '"abbbbc" =~ m/\N{3,4}/ && $& eq "abbb"'; |
988 | } |
989 | |
37820adc |
990 | { |
991 | use charnames ":full"; |
992 | local $Message = '[perl #74982] Period coming after \N{}'; |
993 | ok "\x{ff08}." =~ m/\N{FULLWIDTH LEFT PARENTHESIS}./ && $& eq "\x{ff08}."; |
994 | ok "\x{ff08}." =~ m/[\N{FULLWIDTH LEFT PARENTHESIS}]./ && $& eq "\x{ff08}."; |
995 | } |
ff3f963a |
996 | |
84281c31 |
997 | } # End of sub run_tests |
998 | |
999 | 1; |