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