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; | |
9 | use 5.010; | |
10 | ||
84281c31 A |
11 | sub run_tests; |
12 | ||
9133bbab | 13 | $| = 1; |
3568d838 | 14 | |
8d37f932 | 15 | |
e4d48cc9 GS |
16 | BEGIN { |
17 | chdir 't' if -d 't'; | |
9d45b377 | 18 | @INC = ('../lib','.'); |
569f7fc5 | 19 | require Config; import Config; |
6f4e0180 | 20 | require './test.pl'; |
e4d48cc9 | 21 | } |
84281c31 | 22 | |
e0362b86 | 23 | plan tests => 721; # Update this when adding/deleting tests. |
b7a35066 | 24 | |
9d45b377 | 25 | run_tests() unless caller; |
b7a35066 | 26 | |
84281c31 A |
27 | # |
28 | # Tests start here. | |
29 | # | |
30 | sub run_tests { | |
0ef3e39e | 31 | |
84281c31 | 32 | { |
84281c31 | 33 | my $x = "abc\ndef\n"; |
5895685f | 34 | (my $x_pretty = $x) =~ s/\n/\\n/g; |
fd291da9 | 35 | |
5895685f NC |
36 | ok $x =~ /^abc/, qq ["$x_pretty" =~ /^abc/]; |
37 | ok $x !~ /^def/, qq ["$x_pretty" !~ /^def/]; | |
fd291da9 | 38 | |
84281c31 | 39 | # used to be a test for $* |
5895685f | 40 | ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m]; |
fd291da9 | 41 | |
b33825c4 NC |
42 | ok(!($x =~ /^xxx/), qq ["$x_pretty" =~ /^xxx/]); |
43 | ok(!($x !~ /^abc/), qq ["$x_pretty" !~ /^abc/]); | |
fd291da9 | 44 | |
5895685f | 45 | ok $x =~ /def/, qq ["$x_pretty" =~ /def/]; |
b33825c4 | 46 | ok(!($x !~ /def/), qq ["$x_pretty" !~ /def/]); |
4765795a | 47 | |
5895685f | 48 | ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/]; |
b33825c4 | 49 | ok(!($x =~ /.def/), qq ["$x_pretty" =~ /.def/]); |
4765795a | 50 | |
5895685f | 51 | ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/]; |
b33825c4 | 52 | ok(!($x !~ /\ndef/), qq ["$x_pretty" !~ /\\ndef/]); |
84281c31 | 53 | } |
4765795a | 54 | |
84281c31 A |
55 | { |
56 | $_ = '123'; | |
57 | ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/]; | |
58 | } | |
f9969324 | 59 | |
84281c31 A |
60 | { |
61 | $_ = 'aaabbbccc'; | |
62 | ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc', | |
63 | qq [\$_ = '$_'; /(a*b*)(c*)/]; | |
64 | ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/]; | |
b33825c4 | 65 | unlike($_, qr/a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]); |
84281c31 A |
66 | |
67 | $_ = 'aaabccc'; | |
68 | ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]; | |
69 | ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; | |
70 | ||
71 | $_ = 'aaaccc'; | |
72 | ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/]; | |
b33825c4 | 73 | unlike($_, qr/a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]); |
84281c31 A |
74 | |
75 | $_ = 'abcdef'; | |
76 | ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/]; | |
77 | ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/]; | |
78 | ok m|bc/*d|, qq [\$_ = '$_'; m|bc/*d|]; | |
79 | ok /^$_$/, qq [\$_ = '$_'; /^\$_\$/]; | |
4765795a | 80 | } |
4765795a | 81 | |
84281c31 A |
82 | { |
83 | # used to be a test for $* | |
5895685f | 84 | ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m]; |
84281c31 | 85 | } |
4765795a | 86 | |
84281c31 A |
87 | { |
88 | our %XXX = map {($_ => $_)} 123, 234, 345; | |
89 | ||
90 | our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3'); | |
91 | while ($_ = shift(@XXX)) { | |
b33825c4 | 92 | my $e = index ($_, 'not') >= 0 ? '' : 1; |
725a61d7 | 93 | my $r = m?(.*)?; |
b33825c4 | 94 | is($r, $e, "?(.*)?"); |
84281c31 A |
95 | /not/ && reset; |
96 | if (/not ok 2/) { | |
97 | if ($^O eq 'VMS') { | |
98 | $_ = shift(@XXX); | |
99 | } | |
100 | else { | |
101 | reset 'X'; | |
102 | } | |
103 | } | |
104 | } | |
4765795a | 105 | |
84281c31 A |
106 | SKIP: { |
107 | if ($^O eq 'VMS') { | |
108 | skip "Reset 'X'", 1; | |
109 | } | |
110 | ok !keys %XXX, "%XXX is empty"; | |
111 | } | |
4765795a | 112 | |
84281c31 | 113 | } |
4765795a | 114 | |
84281c31 | 115 | { |
4f890a30 | 116 | my $message = "Test empty pattern"; |
84281c31 A |
117 | my $xyz = 'xyz'; |
118 | my $cde = 'cde'; | |
119 | ||
120 | $cde =~ /[^ab]*/; | |
121 | $xyz =~ //; | |
4f890a30 | 122 | is($&, $xyz, $message); |
84281c31 A |
123 | |
124 | my $foo = '[^ab]*'; | |
125 | $cde =~ /$foo/; | |
126 | $xyz =~ //; | |
4f890a30 | 127 | is($&, $xyz, $message); |
84281c31 A |
128 | |
129 | $cde =~ /$foo/; | |
130 | my $null; | |
131 | no warnings 'uninitialized'; | |
132 | $xyz =~ /$null/; | |
4f890a30 | 133 | is($&, $xyz, $message); |
84281c31 A |
134 | |
135 | $null = ""; | |
136 | $xyz =~ /$null/; | |
4f890a30 | 137 | is($&, $xyz, $message); |
84281c31 | 138 | } |
4765795a | 139 | |
84281c31 | 140 | { |
4f890a30 | 141 | my $message = q !Check $`, $&, $'!; |
84281c31 | 142 | $_ = 'abcdefghi'; |
0f289c68 | 143 | /def/; # optimized up to cmd |
4f890a30 | 144 | is("$`:$&:$'", 'abc:def:ghi', $message); |
4765795a | 145 | |
84281c31 | 146 | no warnings 'void'; |
0f289c68 | 147 | /cde/ + 0; # optimized only to spat |
4f890a30 | 148 | is("$`:$&:$'", 'ab:cde:fghi', $message); |
4765795a | 149 | |
0f289c68 | 150 | /[d][e][f]/; # not optimized |
4f890a30 | 151 | is("$`:$&:$'", 'abc:def:ghi', $message); |
84281c31 | 152 | } |
4765795a | 153 | |
84281c31 A |
154 | { |
155 | $_ = 'now is the {time for all} good men to come to.'; | |
2a53d331 | 156 | / \{([^}]*)}/; |
de26e0cc | 157 | is($1, 'time for all', "Match braces"); |
84281c31 | 158 | } |
4765795a | 159 | |
84281c31 | 160 | { |
4f890a30 | 161 | my $message = "{N,M} quantifier"; |
84281c31 | 162 | $_ = 'xxx {3,4} yyy zzz'; |
4f890a30 NC |
163 | ok(/( {3,4})/, $message); |
164 | is($1, ' ', $message); | |
165 | unlike($_, qr/( {4,})/, $message); | |
166 | ok(/( {2,3}.)/, $message); | |
167 | is($1, ' y', $message); | |
168 | ok(/(y{2,3}.)/, $message); | |
169 | is($1, 'yyy ', $message); | |
170 | unlike($_, qr/x {3,4}/, $message); | |
171 | unlike($_, qr/^xxx {3,4}/, $message); | |
84281c31 | 172 | } |
4765795a | 173 | |
84281c31 | 174 | { |
4f890a30 | 175 | my $message = "Test /g"; |
84281c31 A |
176 | local $" = ":"; |
177 | $_ = "now is the time for all good men to come to."; | |
178 | my @words = /(\w+)/g; | |
179 | my $exp = "now:is:the:time:for:all:good:men:to:come:to"; | |
4765795a | 180 | |
4f890a30 | 181 | is("@words", $exp, $message); |
4765795a | 182 | |
84281c31 A |
183 | @words = (); |
184 | while (/\w+/g) { | |
185 | push (@words, $&); | |
186 | } | |
4f890a30 | 187 | is("@words", $exp, $message); |
4765795a | 188 | |
84281c31 A |
189 | @words = (); |
190 | pos = 0; | |
191 | while (/to/g) { | |
192 | push(@words, $&); | |
193 | } | |
4f890a30 | 194 | is("@words", "to:to", $message); |
4765795a | 195 | |
84281c31 A |
196 | pos $_ = 0; |
197 | @words = /to/g; | |
4f890a30 | 198 | is("@words", "to:to", $message); |
84281c31 | 199 | } |
4765795a | 200 | |
84281c31 A |
201 | { |
202 | $_ = "abcdefghi"; | |
203 | ||
204 | my $pat1 = 'def'; | |
205 | my $pat2 = '^def'; | |
206 | my $pat3 = '.def.'; | |
207 | my $pat4 = 'abc'; | |
208 | my $pat5 = '^abc'; | |
209 | my $pat6 = 'abc$'; | |
210 | my $pat7 = 'ghi'; | |
211 | my $pat8 = '\w*ghi'; | |
212 | my $pat9 = 'ghi$'; | |
213 | ||
214 | my $t1 = my $t2 = my $t3 = my $t4 = my $t5 = | |
215 | my $t6 = my $t7 = my $t8 = my $t9 = 0; | |
216 | ||
217 | for my $iter (1 .. 5) { | |
218 | $t1++ if /$pat1/o; | |
219 | $t2++ if /$pat2/o; | |
220 | $t3++ if /$pat3/o; | |
221 | $t4++ if /$pat4/o; | |
222 | $t5++ if /$pat5/o; | |
223 | $t6++ if /$pat6/o; | |
224 | $t7++ if /$pat7/o; | |
225 | $t8++ if /$pat8/o; | |
226 | $t9++ if /$pat9/o; | |
227 | } | |
228 | my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9"; | |
de26e0cc | 229 | is($x, '505550555', "Test /o"); |
84281c31 | 230 | } |
4765795a | 231 | |
4f890a30 | 232 | { |
84281c31 A |
233 | my $xyz = 'xyz'; |
234 | ok "abc" =~ /^abc$|$xyz/, "| after \$"; | |
4765795a | 235 | |
84281c31 | 236 | # perl 4.009 says "unmatched ()" |
4f890a30 | 237 | my $message = '$ inside ()'; |
4765795a | 238 | |
84281c31 A |
239 | my $result; |
240 | eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"'; | |
4f890a30 NC |
241 | is($@, "", $message); |
242 | is($result, "abc:bc", $message); | |
84281c31 | 243 | } |
4765795a | 244 | |
84281c31 | 245 | { |
4f890a30 | 246 | my $message = "Scalar /g"; |
84281c31 A |
247 | $_ = "abcfooabcbar"; |
248 | ||
4f890a30 NC |
249 | ok( /abc/g && $` eq "", $message); |
250 | ok( /abc/g && $` eq "abcfoo", $message); | |
251 | ok(!/abc/g, $message); | |
84281c31 | 252 | |
4f890a30 | 253 | $message = "Scalar /gi"; |
84281c31 | 254 | pos = 0; |
4f890a30 NC |
255 | ok( /ABC/gi && $` eq "", $message); |
256 | ok( /ABC/gi && $` eq "abcfoo", $message); | |
257 | ok(!/ABC/gi, $message); | |
84281c31 | 258 | |
4f890a30 | 259 | $message = "Scalar /g"; |
84281c31 | 260 | pos = 0; |
4f890a30 NC |
261 | ok( /abc/g && $' eq "fooabcbar", $message); |
262 | ok( /abc/g && $' eq "bar", $message); | |
84281c31 A |
263 | |
264 | $_ .= ''; | |
265 | my @x = /abc/g; | |
de26e0cc | 266 | is(@x, 2, "/g reset after assignment"); |
4765795a | 267 | } |
4765795a | 268 | |
84281c31 | 269 | { |
4f890a30 | 270 | my $message = '/g, \G and pos'; |
84281c31 A |
271 | $_ = "abdc"; |
272 | pos $_ = 2; | |
273 | /\Gc/gc; | |
4f890a30 | 274 | is(pos $_, 2, $message); |
84281c31 | 275 | /\Gc/g; |
4f890a30 | 276 | is(pos $_, undef, $message); |
84281c31 | 277 | } |
4765795a | 278 | |
84281c31 | 279 | { |
4f890a30 | 280 | my $message = '(?{ })'; |
84281c31 A |
281 | our $out = 1; |
282 | 'abc' =~ m'a(?{ $out = 2 })b'; | |
4f890a30 | 283 | is($out, 2, $message); |
84281c31 A |
284 | |
285 | $out = 1; | |
286 | 'abc' =~ m'a(?{ $out = 3 })c'; | |
4f890a30 | 287 | is($out, 1, $message); |
84281c31 | 288 | } |
4765795a | 289 | |
84281c31 A |
290 | { |
291 | $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; | |
292 | my @out = /(?<!foo)bar./g; | |
de26e0cc | 293 | is("@out", 'bar2 barf', "Negative lookbehind"); |
84281c31 | 294 | } |
4765795a | 295 | |
84281c31 | 296 | { |
4f890a30 | 297 | my $message = "REG_INFTY tests"; |
84281c31 | 298 | # Tests which depend on REG_INFTY |
19d6612d NC |
299 | |
300 | # Defaults assumed if this fails | |
301 | eval { require Config; }; | |
302 | $::reg_infty = $Config::Config{reg_infty} // 32767; | |
84281c31 A |
303 | $::reg_infty_m = $::reg_infty - 1; |
304 | $::reg_infty_p = $::reg_infty + 1; | |
93f09d7b | 305 | $::reg_infty_m = $::reg_infty_m; # Suppress warning. |
84281c31 A |
306 | |
307 | # As well as failing if the pattern matches do unexpected things, the | |
308 | # next three tests will fail if you should have picked up a lower-than- | |
309 | # default value for $reg_infty from Config.pm, but have not. | |
310 | ||
14358a41 NC |
311 | is(eval q{('aaa' =~ /(a{1,$::reg_infty_m})/)[0]}, 'aaa', $message); |
312 | is($@, '', $message); | |
313 | is(eval q{('a' x $::reg_infty_m) =~ /a{$::reg_infty_m}/}, 1, $message); | |
314 | is($@, '', $message); | |
315 | isnt(q{('a' x ($::reg_infty_m - 1)) !~ /a{$::reg_infty_m}/}, 1, $message); | |
316 | is($@, '', $message); | |
317 | ||
84281c31 | 318 | eval "'aaa' =~ /a{1,$::reg_infty}/"; |
224b2e7e | 319 | like($@, qr/^\QQuantifier in {,} bigger than/, $message); |
84281c31 | 320 | eval "'aaa' =~ /a{1,$::reg_infty_p}/"; |
4f890a30 | 321 | like($@, qr/^\QQuantifier in {,} bigger than/, $message); |
4765795a | 322 | } |
8269fa76 | 323 | |
84281c31 A |
324 | { |
325 | # Poke a couple more parse failures | |
326 | my $context = 'x' x 256; | |
327 | eval qq("${context}y" =~ /(?<=$context)y/); | |
328 | ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit"; | |
329 | } | |
8269fa76 | 330 | |
84281c31 A |
331 | { |
332 | # Long Monsters | |
84281c31 A |
333 | for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory |
334 | my $a = 'a' x $l; | |
4f890a30 NC |
335 | my $message = "Long monster, length = $l"; |
336 | like("ba$a=", qr/a$a=/, $message); | |
337 | unlike("b$a=", qr/a$a=/, $message); | |
338 | like("b$a=", qr/ba+=/, $message); | |
84281c31 | 339 | |
224b2e7e | 340 | like("ba$a=", qr/b(?:a|b)+=/, $message); |
84281c31 A |
341 | } |
342 | } | |
8269fa76 | 343 | |
84281c31 A |
344 | { |
345 | # 20000 nodes, each taking 3 words per string, and 1 per branch | |
346 | my $long_constant_len = join '|', 12120 .. 32645; | |
347 | my $long_var_len = join '|', 8120 .. 28645; | |
348 | my %ans = ( 'ax13876y25677lbc' => 1, | |
349 | 'ax13876y25677mcb' => 0, # not b. | |
350 | 'ax13876y35677nbc' => 0, # Num too big | |
351 | 'ax13876y25677y21378obc' => 1, | |
0f289c68 | 352 | 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o] |
84281c31 A |
353 | 'ax13876y25677y21378y21378kbc' => 1, |
354 | 'ax13876y25677y21378y21378kcb' => 0, # Not b. | |
355 | 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs | |
356 | ); | |
357 | ||
84281c31 | 358 | for (keys %ans) { |
4f890a30 NC |
359 | my $message = "20000 nodes, const-len '$_'"; |
360 | ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o), $message; | |
84281c31 | 361 | |
4f890a30 NC |
362 | $message = "20000 nodes, var-len '$_'"; |
363 | ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o,), $message; | |
84281c31 | 364 | } |
b8ef571c | 365 | } |
209a9bc1 | 366 | |
84281c31 | 367 | { |
4f890a30 | 368 | my $message = "Complicated backtracking"; |
84281c31 A |
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 A |
378 | (?: |
379 | (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop | |
380 | (?! | |
0f289c68 YO |
381 | ) # Fail: will unwind one iteration back |
382 | ) | |
84281c31 | 383 | (?: |
0f289c68 | 384 | [^()]+ # Match a big chunk |
84281c31 A |
385 | (?= |
386 | [()] | |
0f289c68 | 387 | ) # Do not try to match subchunks |
84281c31 A |
388 | | |
389 | \( | |
390 | (?{ ++$c }) | |
391 | | | |
392 | \) | |
393 | (?{ --$c }) | |
394 | ) | |
0f289c68 | 395 | )+ # This may not match with different subblocks |
84281c31 A |
396 | ) |
397 | (?(?{ $c != 0 }) | |
398 | (?! | |
0f289c68 YO |
399 | ) # Fail |
400 | ) # Otherwise the chunk 1 may succeed with $c>0 | |
84281c31 A |
401 | /xg; |
402 | } | |
3568d838 | 403 | |
84281c31 A |
404 | my @ans = (); |
405 | my $res; | |
406 | push @ans, $res while $res = matchit; | |
4f890a30 | 407 | is("@ans", "1 1 1", $message); |
3568d838 | 408 | |
84281c31 | 409 | @ans = matchit; |
4f890a30 | 410 | is("@ans", $expect, $message); |
3568d838 | 411 | |
4f890a30 | 412 | $message = "Recursion with (??{ })"; |
84281c31 A |
413 | our $matched; |
414 | $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; | |
3568d838 | 415 | |
84281c31 A |
416 | @ans = my @ans1 = (); |
417 | push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g; | |
3568d838 | 418 | |
4f890a30 NC |
419 | is("@ans", "1 1 1", $message); |
420 | is("@ans1", $expect, $message); | |
3568d838 | 421 | |
84281c31 | 422 | @ans = m/$matched/g; |
4f890a30 | 423 | is("@ans", $expect, $message); |
3568d838 | 424 | |
84281c31 | 425 | } |
3568d838 | 426 | |
84281c31 A |
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 |
de26e0cc | 433 | is("@ans", 'a/ b', "Stack may be bad"); |
84281c31 | 434 | } |
3568d838 | 435 | |
84281c31 | 436 | { |
4f890a30 | 437 | my $message = "Eval-group not allowed at runtime"; |
84281c31 A |
438 | my $code = '{$blah = 45}'; |
439 | our $blah = 12; | |
440 | eval { /(?$code)/ }; | |
4f890a30 | 441 | ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); |
84281c31 | 442 | |
3044771b NC |
443 | $blah = 12; |
444 | my $res = eval { "xx" =~ /(?$code)/o }; | |
445 | { | |
446 | no warnings 'uninitialized'; | |
5895685f | 447 | chomp $@; my $message = "$message '$@', '$res', '$blah'"; |
4f890a30 | 448 | ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message); |
3044771b NC |
449 | } |
450 | ||
451 | $code = '=xx'; | |
452 | $blah = 12; | |
453 | $res = eval { "xx" =~ /(?$code)/o }; | |
454 | { | |
455 | no warnings 'uninitialized'; | |
4f890a30 NC |
456 | my $message = "$message '$@', '$res', '$blah'"; |
457 | ok(!$@ && $res, $message); | |
3044771b | 458 | } |
3568d838 | 459 | |
84281c31 A |
460 | $code = '{$blah = 45}'; |
461 | $blah = 12; | |
462 | eval "/(?$code)/"; | |
4f890a30 | 463 | is($blah, 45, $message); |
3568d838 | 464 | |
84281c31 A |
465 | $blah = 12; |
466 | /(?{$blah = 45})/; | |
4f890a30 | 467 | is($blah, 45, $message); |
84281c31 | 468 | } |
3568d838 | 469 | |
84281c31 | 470 | { |
4f890a30 | 471 | my $message = "Pos checks"; |
84281c31 A |
472 | my $x = 'banana'; |
473 | $x =~ /.a/g; | |
4f890a30 | 474 | is(pos $x, 2, $message); |
3568d838 | 475 | |
84281c31 | 476 | $x =~ /.z/gc; |
4f890a30 | 477 | is(pos $x, 2, $message); |
3568d838 | 478 | |
84281c31 A |
479 | sub f { |
480 | my $p = $_[0]; | |
481 | return $p; | |
482 | } | |
3568d838 | 483 | |
84281c31 | 484 | $x =~ /.a/g; |
4f890a30 | 485 | is(f (pos $x), 4, $message); |
84281c31 | 486 | } |
3568d838 | 487 | |
84281c31 | 488 | { |
4f890a30 | 489 | my $message = 'Checking $^R'; |
84281c31 A |
490 | our $x = $^R = 67; |
491 | 'foot' =~ /foo(?{$x = 12; 75})[t]/; | |
4f890a30 | 492 | is($^R, 75, $message); |
84281c31 A |
493 | |
494 | $x = $^R = 67; | |
495 | 'foot' =~ /foo(?{$x = 12; 75})[xy]/; | |
4f890a30 | 496 | ok($^R eq '67' && $x eq '12', $message); |
84281c31 A |
497 | |
498 | $x = $^R = 67; | |
499 | 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; | |
4f890a30 | 500 | ok($^R eq '79' && $x eq '12', $message); |
84281c31 | 501 | } |
3568d838 | 502 | |
84281c31 | 503 | { |
de26e0cc NC |
504 | is(qr/\b\v$/i, '(?^i:\b\v$)', 'qr/\b\v$/i'); |
505 | is(qr/\b\v$/s, '(?^s:\b\v$)', 'qr/\b\v$/s'); | |
506 | is(qr/\b\v$/m, '(?^m:\b\v$)', 'qr/\b\v$/m'); | |
507 | is(qr/\b\v$/x, '(?^x:\b\v$)', 'qr/\b\v$/x'); | |
508 | is(qr/\b\v$/xism, '(?^msix:\b\v$)', 'qr/\b\v$/xism'); | |
509 | is(qr/\b\v$/, '(?^:\b\v$)', 'qr/\b\v$/'); | |
84281c31 | 510 | } |
3568d838 | 511 | |
9de15fec | 512 | { # Test that charset modifier work, and are interpolated |
de26e0cc NC |
513 | is(qr/\b\v$/, '(?^:\b\v$)', 'Verify no locale, no unicode_strings gives default modifier'); |
514 | is(qr/(?l:\b\v$)/, '(?^:(?l:\b\v$))', 'Verify infix l modifier compiles'); | |
515 | is(qr/(?u:\b\v$)/, '(?^:(?u:\b\v$))', 'Verify infix u modifier compiles'); | |
516 | is(qr/(?l)\b\v$/, '(?^:(?l)\b\v$)', 'Verify (?l) compiles'); | |
517 | is(qr/(?u)\b\v$/, '(?^:(?u)\b\v$)', 'Verify (?u) compiles'); | |
9de15fec KW |
518 | |
519 | my $dual = qr/\b\v$/; | |
569f7fc5 JR |
520 | my $locale; |
521 | ||
522 | SKIP: { | |
523 | skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale}); | |
524 | ||
525 | BEGIN { | |
526 | if($Config{d_setlocale}) { | |
527 | require locale; import locale; | |
528 | } | |
529 | } | |
530 | $locale = qr/\b\v$/; | |
531 | is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale'); | |
532 | no locale; | |
533 | } | |
9de15fec KW |
534 | |
535 | use feature 'unicode_strings'; | |
536 | my $unicode = qr/\b\v$/; | |
de26e0cc NC |
537 | is($unicode, '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings'); |
538 | is(qr/abc$dual/, '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); | |
569f7fc5 JR |
539 | |
540 | SKIP: { | |
541 | skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale}); | |
542 | ||
543 | is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings'); | |
544 | } | |
9de15fec KW |
545 | |
546 | no feature 'unicode_strings'; | |
569f7fc5 JR |
547 | SKIP: { |
548 | skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale}); | |
549 | ||
550 | is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings'); | |
551 | } | |
552 | ||
de26e0cc | 553 | is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings'); |
9de15fec | 554 | |
569f7fc5 JR |
555 | SKIP: { |
556 | skip 'No locale testing without d_setlocale', 2 if(!$Config{d_setlocale}); | |
557 | ||
558 | BEGIN { | |
559 | if($Config{d_setlocale}) { | |
560 | require locale; import locale; | |
561 | } | |
562 | } | |
563 | is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale'); | |
564 | is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale'); | |
565 | } | |
9de15fec KW |
566 | } |
567 | ||
84281c31 | 568 | { |
4f890a30 | 569 | my $message = "Look around"; |
84281c31 | 570 | $_ = 'xabcx'; |
84281c31 | 571 | foreach my $ans ('', 'c') { |
4f890a30 NC |
572 | ok(/(?<=(?=a)..)((?=c)|.)/g, $message); |
573 | is($1, $ans, $message); | |
84281c31 A |
574 | } |
575 | } | |
3568d838 | 576 | |
84281c31 | 577 | { |
4f890a30 | 578 | my $message = "Empty clause"; |
84281c31 A |
579 | $_ = 'a'; |
580 | foreach my $ans ('', 'a', '') { | |
4f890a30 NC |
581 | ok(/^|a|$/g, $message); |
582 | is($&, $ans, $message); | |
84281c31 A |
583 | } |
584 | } | |
3568d838 | 585 | |
84281c31 | 586 | { |
84281c31 | 587 | sub prefixify { |
4f890a30 NC |
588 | my $message = "Prefixify"; |
589 | { | |
84281c31 | 590 | my ($v, $a, $b, $res) = @_; |
4f890a30 NC |
591 | ok($v =~ s/\Q$a\E/$b/, $message); |
592 | is($v, $res, $message); | |
84281c31 A |
593 | } |
594 | } | |
3568d838 | 595 | |
84281c31 A |
596 | prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); |
597 | prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); | |
598 | } | |
3568d838 | 599 | |
84281c31 A |
600 | { |
601 | $_ = 'var="foo"'; | |
602 | /(\")/; | |
603 | ok $1 && /$1/, "Capture a quote"; | |
604 | } | |
3568d838 | 605 | |
84281c31 | 606 | { |
84281c31 | 607 | no warnings 'closure'; |
4f890a30 | 608 | my $message = '(?{ $var } refers to package vars'; |
84281c31 A |
609 | package aa; |
610 | our $c = 2; | |
611 | $::c = 3; | |
612 | '' =~ /(?{ $c = 4 })/; | |
4f890a30 NC |
613 | main::is($c, 4, $message); |
614 | main::is($::c, 3, $message); | |
84281c31 | 615 | } |
3568d838 | 616 | |
84281c31 | 617 | { |
cb124425 NC |
618 | is(eval 'q(a:[b]:) =~ /[x[:foo:]]/', undef); |
619 | like ($@, qr/POSIX class \[:[^:]+:\] unknown in regex/, | |
620 | 'POSIX class [: :] must have valid name'); | |
84281c31 A |
621 | |
622 | for my $d (qw [= .]) { | |
cb124425 NC |
623 | is(eval "/[[${d}foo${d}]]/", undef); |
624 | like ($@, qr/\QPOSIX syntax [$d $d] is reserved for future extensions/, | |
625 | "POSIX syntax [[$d $d]] is an error"); | |
84281c31 A |
626 | } |
627 | } | |
3568d838 | 628 | |
84281c31 A |
629 | { |
630 | # test if failure of patterns returns empty list | |
4f890a30 | 631 | my $message = "Failed pattern returns empty list"; |
84281c31 A |
632 | $_ = 'aaa'; |
633 | @_ = /bbb/; | |
4f890a30 | 634 | is("@_", "", $message); |
3568d838 | 635 | |
84281c31 | 636 | @_ = /bbb/g; |
4f890a30 | 637 | is("@_", "", $message); |
a72deede | 638 | |
84281c31 | 639 | @_ = /(bbb)/; |
4f890a30 | 640 | is("@_", "", $message); |
a72deede | 641 | |
84281c31 | 642 | @_ = /(bbb)/g; |
4f890a30 | 643 | is("@_", "", $message); |
84281c31 | 644 | } |
a72deede | 645 | |
84281c31 | 646 | { |
4f890a30 | 647 | my $message = '@- and @+ tests'; |
84281c31 A |
648 | |
649 | /a(?=.$)/; | |
4f890a30 NC |
650 | is($#+, 0, $message); |
651 | is($#-, 0, $message); | |
652 | is($+ [0], 2, $message); | |
653 | is($- [0], 1, $message); | |
654 | ok(!defined $+ [1] && !defined $- [1] && | |
655 | !defined $+ [2] && !defined $- [2], $message); | |
84281c31 A |
656 | |
657 | /a(a)(a)/; | |
4f890a30 NC |
658 | is($#+, 2, $message); |
659 | is($#-, 2, $message); | |
660 | is($+ [0], 3, $message); | |
661 | is($- [0], 0, $message); | |
662 | is($+ [1], 2, $message); | |
663 | is($- [1], 1, $message); | |
664 | is($+ [2], 3, $message); | |
665 | is($- [2], 2, $message); | |
666 | ok(!defined $+ [3] && !defined $- [3] && | |
667 | !defined $+ [4] && !defined $- [4], $message); | |
84281c31 | 668 | |
54a4274e | 669 | # Exists has a special check for @-/@+ - bug 45147 |
4f890a30 NC |
670 | ok(exists $-[0], $message); |
671 | ok(exists $+[0], $message); | |
672 | ok(exists $-[2], $message); | |
673 | ok(exists $+[2], $message); | |
674 | ok(!exists $-[3], $message); | |
675 | ok(!exists $+[3], $message); | |
676 | ok(exists $-[-1], $message); | |
677 | ok(exists $+[-1], $message); | |
678 | ok(exists $-[-3], $message); | |
679 | ok(exists $+[-3], $message); | |
680 | ok(!exists $-[-4], $message); | |
681 | ok(!exists $+[-4], $message); | |
84281c31 A |
682 | |
683 | /.(a)(b)?(a)/; | |
4f890a30 NC |
684 | is($#+, 3, $message); |
685 | is($#-, 3, $message); | |
686 | is($+ [1], 2, $message); | |
687 | is($- [1], 1, $message); | |
688 | is($+ [3], 3, $message); | |
689 | is($- [3], 2, $message); | |
690 | ok(!defined $+ [2] && !defined $- [2] && | |
691 | !defined $+ [4] && !defined $- [4], $message); | |
84281c31 | 692 | |
84281c31 | 693 | /.(a)/; |
4f890a30 NC |
694 | is($#+, 1, $message); |
695 | is($#-, 1, $message); | |
696 | is($+ [0], 2, $message); | |
697 | is($- [0], 0, $message); | |
698 | is($+ [1], 2, $message); | |
699 | is($- [1], 1, $message); | |
700 | ok(!defined $+ [2] && !defined $- [2] && | |
701 | !defined $+ [3] && !defined $- [3], $message); | |
84281c31 A |
702 | |
703 | /.(a)(ba*)?/; | |
4f890a30 NC |
704 | is($#+, 2, $message); |
705 | is($#-, 1, $message); | |
232af1f8 FC |
706 | |
707 | # Check that values don’t stick | |
708 | " "=~/()()()(.)(..)/; | |
709 | my($m,$p) = (\$-[5], \$+[5]); | |
710 | () = "$$_" for $m, $p; # FETCH (or eqv.) | |
711 | " " =~ /()/; | |
712 | is $$m, undef, 'values do not stick to @- elements'; | |
713 | is $$p, undef, 'values do not stick to @+ elements'; | |
84281c31 | 714 | } |
a72deede | 715 | |
d9bad346 FC |
716 | foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)', |
717 | '@- = qw (foo bar)', '$^N = 42') { | |
cb124425 NC |
718 | is(eval $_, undef); |
719 | like($@, qr/^Modification of a read-only value attempted/, | |
d9bad346 | 720 | '$^N, @- and @+ are read-only'); |
84281c31 | 721 | } |
a72deede | 722 | |
84281c31 | 723 | { |
4f890a30 | 724 | my $message = '\G testing'; |
84281c31 A |
725 | $_ = 'aaa'; |
726 | pos = 1; | |
727 | my @a = /\Ga/g; | |
4f890a30 | 728 | is("@a", "a a", $message); |
84281c31 A |
729 | |
730 | my $str = 'abcde'; | |
731 | pos $str = 2; | |
4f890a30 NC |
732 | unlike($str, qr/^\G/, $message); |
733 | unlike($str, qr/^.\G/, $message); | |
734 | like($str, qr/^..\G/, $message); | |
735 | unlike($str, qr/^...\G/, $message); | |
736 | ok($str =~ /\G../ && $& eq 'cd', $message); | |
4f890a30 | 737 | ok($str =~ /.\G./ && $& eq 'bc', $message); |
cf44e600 DM |
738 | |
739 | } | |
740 | ||
741 | { | |
742 | my $message = '\G and intuit and anchoring'; | |
743 | $_ = "abcdef"; | |
744 | pos = 0; | |
745 | ok($_ =~ /\Gabc/, $message); | |
746 | ok($_ =~ /^\Gabc/, $message); | |
747 | ||
748 | pos = 3; | |
749 | ok($_ =~ /\Gdef/, $message); | |
750 | pos = 3; | |
751 | ok($_ =~ /\Gdef$/, $message); | |
752 | pos = 3; | |
753 | ok($_ =~ /abc\Gdef$/, $message); | |
754 | pos = 3; | |
755 | ok($_ =~ /^abc\Gdef$/, $message); | |
756 | pos = 3; | |
757 | ok($_ =~ /c\Gd/, $message); | |
e0362b86 DM |
758 | pos = 3; |
759 | ok($_ =~ /..\GX?def/, $message); | |
84281c31 | 760 | } |
a72deede | 761 | |
84281c31 | 762 | { |
fe3974be DM |
763 | my $s = '123'; |
764 | pos($s) = 1; | |
765 | my @a = $s =~ /(\d)\G/g; # this infinitely looped up till 5.19.1 | |
766 | is("@a", "1", '\G looping'); | |
767 | } | |
768 | ||
769 | ||
770 | { | |
4f890a30 | 771 | my $message = 'pos inside (?{ })'; |
84281c31 A |
772 | my $str = 'abcde'; |
773 | our ($foo, $bar); | |
4f890a30 NC |
774 | like($str, qr/b(?{$foo = $_; $bar = pos})c/, $message); |
775 | is($foo, $str, $message); | |
776 | is($bar, 2, $message); | |
777 | is(pos $str, undef, $message); | |
84281c31 A |
778 | |
779 | undef $foo; | |
780 | undef $bar; | |
781 | pos $str = undef; | |
4f890a30 NC |
782 | ok($str =~ /b(?{$foo = $_; $bar = pos})c/g, $message); |
783 | is($foo, $str, $message); | |
784 | is($bar, 2, $message); | |
785 | is(pos $str, 3, $message); | |
84281c31 A |
786 | |
787 | $_ = $str; | |
788 | undef $foo; | |
789 | undef $bar; | |
4f890a30 NC |
790 | like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message); |
791 | is($foo, $str, $message); | |
792 | is($bar, 2, $message); | |
84281c31 A |
793 | |
794 | undef $foo; | |
795 | undef $bar; | |
4f890a30 NC |
796 | ok(/b(?{$foo = $_; $bar = pos})c/g, $message); |
797 | is($foo, $str, $message); | |
798 | is($bar, 2, $message); | |
799 | is(pos, 3, $message); | |
84281c31 A |
800 | |
801 | undef $foo; | |
802 | undef $bar; | |
803 | pos = undef; | |
804 | 1 while /b(?{$foo = $_; $bar = pos})c/g; | |
4f890a30 NC |
805 | is($foo, $str, $message); |
806 | is($bar, 2, $message); | |
807 | is(pos, undef, $message); | |
84281c31 A |
808 | |
809 | undef $foo; | |
810 | undef $bar; | |
811 | $_ = 'abcde|abcde'; | |
4f890a30 NC |
812 | ok(s/b(?{$foo = $_; $bar = pos})c/x/g, $message); |
813 | is($foo, 'abcde|abcde', $message); | |
814 | is($bar, 8, $message); | |
815 | is($_, 'axde|axde', $message); | |
84281c31 A |
816 | |
817 | # List context: | |
818 | $_ = 'abcde|abcde'; | |
819 | our @res; | |
820 | () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; | |
821 | @res = map {defined $_ ? "'$_'" : 'undef'} @res; | |
4f890a30 | 822 | is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message); |
84281c31 A |
823 | |
824 | @res = (); | |
825 | () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; | |
826 | @res = map {defined $_ ? "'$_'" : 'undef'} @res; | |
4f890a30 | 827 | is("@res", "'' 'ab' 'cde|abcde' " . |
84281c31 A |
828 | "'' 'abc' 'de|abcde' " . |
829 | "'abcd' 'e|' 'abcde' " . | |
830 | "'abcde|' 'ab' 'cde' " . | |
4f890a30 | 831 | "'abcde|' 'abc' 'de'", $message); |
84281c31 | 832 | } |
f33976b4 | 833 | |
84281c31 | 834 | { |
4f890a30 | 835 | my $message = '\G anchor checks'; |
84281c31 A |
836 | my $foo = 'aabbccddeeffgg'; |
837 | pos ($foo) = 1; | |
cce850e4 | 838 | |
98bee633 DM |
839 | ok($foo =~ /.\G(..)/g, $message); |
840 | is($1, 'ab', $message); | |
cce850e4 | 841 | |
98bee633 DM |
842 | pos ($foo) += 1; |
843 | ok($foo =~ /.\G(..)/g, $message); | |
844 | is($1, 'cc', $message); | |
cce850e4 | 845 | |
98bee633 DM |
846 | pos ($foo) += 1; |
847 | ok($foo =~ /.\G(..)/g, $message); | |
848 | is($1, 'de', $message); | |
849 | ||
850 | ok($foo =~ /\Gef/g, $message); | |
cce850e4 | 851 | |
84281c31 | 852 | undef pos $foo; |
4f890a30 NC |
853 | ok($foo =~ /\G(..)/g, $message); |
854 | is($1, 'aa', $message); | |
cce850e4 | 855 | |
4f890a30 NC |
856 | ok($foo =~ /\G(..)/g, $message); |
857 | is($1, 'bb', $message); | |
cce850e4 | 858 | |
84281c31 | 859 | pos ($foo) = 5; |
4f890a30 NC |
860 | ok($foo =~ /\G(..)/g, $message); |
861 | is($1, 'cd', $message); | |
84281c31 | 862 | } |
cce850e4 | 863 | |
84281c31 | 864 | { |
9c13586e DM |
865 | my $message = 'basic \G floating checks'; |
866 | my $foo = 'aabbccddeeffgg'; | |
867 | pos ($foo) = 1; | |
868 | ||
869 | ok($foo =~ /a+\G(..)/g, "$message: a+\\G"); | |
870 | is($1, 'ab', "$message: ab"); | |
871 | ||
872 | pos ($foo) += 1; | |
873 | ok($foo =~ /b+\G(..)/g, "$message: b+\\G"); | |
874 | is($1, 'cc', "$message: cc"); | |
875 | ||
876 | pos ($foo) += 1; | |
877 | ok($foo =~ /d+\G(..)/g, "$message: d+\\G"); | |
878 | is($1, 'de', "$message: de"); | |
879 | ||
880 | ok($foo =~ /\Gef/g, "$message: \\Gef"); | |
881 | ||
882 | pos ($foo) = 1; | |
883 | ||
884 | ok($foo =~ /(?=a+\G)(..)/g, "$message: (?a+\\G)"); | |
885 | is($1, 'aa', "$message: aa"); | |
886 | ||
887 | pos ($foo) = 2; | |
888 | ||
889 | ok($foo =~ /a(?=a+\G)(..)/g, "$message: a(?=a+\\G)"); | |
890 | is($1, 'ab', "$message: ab"); | |
891 | ||
892 | } | |
893 | ||
894 | { | |
84281c31 A |
895 | $_ = '123x123'; |
896 | my @res = /(\d*|x)/g; | |
897 | local $" = '|'; | |
de26e0cc | 898 | is("@res", "123||x|123|", "0 match in alternation"); |
84281c31 | 899 | } |
cce850e4 | 900 | |
84281c31 | 901 | { |
4f890a30 | 902 | my $message = "Match against temporaries (created via pp_helem())" . |
84281c31 | 903 | " is safe"; |
4f890a30 NC |
904 | ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message); |
905 | is($1, "bar", $message); | |
84281c31 | 906 | } |
75685a94 | 907 | |
84281c31 | 908 | { |
4f890a30 | 909 | my $message = 'package $i inside (?{ }), ' . |
84281c31 A |
910 | 'saved substrings and changing $_'; |
911 | our @a = qw [foo bar]; | |
912 | our @b = (); | |
913 | s/(\w)(?{push @b, $1})/,$1,/g for @a; | |
4f890a30 NC |
914 | is("@b", "f o o b a r", $message); |
915 | is("@a", ",f,,o,,o, ,b,,a,,r,", $message); | |
84281c31 | 916 | |
4f890a30 | 917 | $message = 'lexical $i inside (?{ }), ' . |
84281c31 A |
918 | 'saved substrings and changing $_'; |
919 | no warnings 'closure'; | |
920 | my @c = qw [foo bar]; | |
921 | my @d = (); | |
922 | s/(\w)(?{push @d, $1})/,$1,/g for @c; | |
4f890a30 NC |
923 | is("@d", "f o o b a r", $message); |
924 | is("@c", ",f,,o,,o, ,b,,a,,r,", $message); | |
d9f424b2 JH |
925 | } |
926 | ||
84281c31 | 927 | { |
4f890a30 | 928 | my $message = 'Brackets'; |
84281c31 A |
929 | our $brackets; |
930 | $brackets = qr { | |
931 | { (?> [^{}]+ | (??{ $brackets }) )* } | |
932 | }x; | |
933 | ||
4f890a30 NC |
934 | ok("{{}" =~ $brackets, $message); |
935 | is($&, "{}", $message); | |
936 | ok("something { long { and } hairy" =~ $brackets, $message); | |
937 | is($&, "{ and }", $message); | |
938 | ok("something { long { and } hairy" =~ m/((??{ $brackets }))/, $message); | |
939 | is($&, "{ and }", $message); | |
84281c31 | 940 | } |
a4c04bdc | 941 | |
84281c31 A |
942 | { |
943 | $_ = "a-a\nxbb"; | |
944 | pos = 1; | |
b33825c4 | 945 | ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg'); |
84281c31 | 946 | } |
a4c04bdc | 947 | |
84281c31 | 948 | { |
4f890a30 | 949 | my $message = '\G anchor checks'; |
84281c31 A |
950 | my $text = "aaXbXcc"; |
951 | pos ($text) = 0; | |
4f890a30 | 952 | ok($text !~ /\GXb*X/g, $message); |
84281c31 | 953 | } |
a4c04bdc | 954 | |
84281c31 A |
955 | { |
956 | $_ = "xA\n" x 500; | |
b33825c4 | 957 | unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"'); |
a4c04bdc | 958 | |
84281c31 A |
959 | my $text = "abc dbf"; |
960 | my @res = ($text =~ /.*?(b).*?\b/g); | |
de26e0cc | 961 | is("@res", "b b", '\b is not special'); |
987aaf07 | 962 | } |
a4c04bdc | 963 | |
84281c31 | 964 | { |
4f890a30 | 965 | my $message = '\S, [\S], \s, [\s]'; |
84281c31 | 966 | my @a = map chr, 0 .. 255; |
9d45b377 YO |
967 | my @b = grep m/\S/, @a; |
968 | my @c = grep m/[^\s]/, @a; | |
4f890a30 | 969 | is("@b", "@c", $message); |
84281c31 A |
970 | |
971 | @b = grep /\S/, @a; | |
972 | @c = grep /[\S]/, @a; | |
4f890a30 | 973 | is("@b", "@c", $message); |
84281c31 A |
974 | |
975 | @b = grep /\s/, @a; | |
976 | @c = grep /[^\S]/, @a; | |
4f890a30 | 977 | is("@b", "@c", $message); |
84281c31 A |
978 | |
979 | @b = grep /\s/, @a; | |
980 | @c = grep /[\s]/, @a; | |
4f890a30 | 981 | is("@b", "@c", $message); |
84281c31 A |
982 | } |
983 | { | |
4f890a30 | 984 | my $message = '\D, [\D], \d, [\d]'; |
84281c31 A |
985 | my @a = map chr, 0 .. 255; |
986 | my @b = grep /\D/, @a; | |
987 | my @c = grep /[^\d]/, @a; | |
4f890a30 | 988 | is("@b", "@c", $message); |
84281c31 A |
989 | |
990 | @b = grep /\D/, @a; | |
991 | @c = grep /[\D]/, @a; | |
4f890a30 | 992 | is("@b", "@c", $message); |
84281c31 A |
993 | |
994 | @b = grep /\d/, @a; | |
995 | @c = grep /[^\D]/, @a; | |
4f890a30 | 996 | is("@b", "@c", $message); |
84281c31 A |
997 | |
998 | @b = grep /\d/, @a; | |
999 | @c = grep /[\d]/, @a; | |
4f890a30 | 1000 | is("@b", "@c", $message); |
84281c31 A |
1001 | } |
1002 | { | |
4f890a30 | 1003 | my $message = '\W, [\W], \w, [\w]'; |
84281c31 A |
1004 | my @a = map chr, 0 .. 255; |
1005 | my @b = grep /\W/, @a; | |
1006 | my @c = grep /[^\w]/, @a; | |
4f890a30 | 1007 | is("@b", "@c", $message); |
84281c31 A |
1008 | |
1009 | @b = grep /\W/, @a; | |
1010 | @c = grep /[\W]/, @a; | |
4f890a30 | 1011 | is("@b", "@c", $message); |
84281c31 A |
1012 | |
1013 | @b = grep /\w/, @a; | |
1014 | @c = grep /[^\W]/, @a; | |
4f890a30 | 1015 | is("@b", "@c", $message); |
84281c31 A |
1016 | |
1017 | @b = grep /\w/, @a; | |
1018 | @c = grep /[\w]/, @a; | |
4f890a30 | 1019 | is("@b", "@c", $message); |
84281c31 | 1020 | } |
a4c04bdc | 1021 | |
84281c31 A |
1022 | { |
1023 | # see if backtracking optimization works correctly | |
4f890a30 NC |
1024 | my $message = 'Backtrack optimization'; |
1025 | like("\n\n", qr/\n $ \n/x, $message); | |
1026 | like("\n\n", qr/\n* $ \n/x, $message); | |
1027 | like("\n\n", qr/\n+ $ \n/x, $message); | |
1028 | like("\n\n", qr/\n? $ \n/x, $message); | |
1029 | like("\n\n", qr/\n*? $ \n/x, $message); | |
1030 | like("\n\n", qr/\n+? $ \n/x, $message); | |
1031 | like("\n\n", qr/\n?? $ \n/x, $message); | |
1032 | unlike("\n\n", qr/\n*+ $ \n/x, $message); | |
1033 | unlike("\n\n", qr/\n++ $ \n/x, $message); | |
1034 | like("\n\n", qr/\n?+ $ \n/x, $message); | |
84281c31 | 1035 | } |
a4c04bdc | 1036 | |
84281c31 A |
1037 | { |
1038 | package S; | |
1039 | use overload '""' => sub {'Object S'}; | |
1040 | sub new {bless []} | |
0f289c68 | 1041 | |
4f890a30 | 1042 | my $message = "Ref stringification"; |
5895685f NC |
1043 | ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or diag($message); |
1044 | ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or diag($message); | |
1045 | ::ok([] =~ /^ARRAY/, "Array ref stringification") or diag($message); | |
1046 | ::ok({} =~ /^HASH/, "Hash ref stringification") or diag($message); | |
1047 | ::ok('S' -> new =~ /^Object S/, "Object stringification") or diag($message); | |
84281c31 | 1048 | } |
a4c04bdc | 1049 | |
84281c31 | 1050 | { |
4f890a30 NC |
1051 | my $message = "Test result of match used as match"; |
1052 | ok('a1b' =~ ('xyz' =~ /y/), $message); | |
1053 | is($`, 'a', $message); | |
1054 | ok('a1b' =~ ('xyz' =~ /t/), $message); | |
1055 | is($`, 'a', $message); | |
84281c31 | 1056 | } |
a4c04bdc | 1057 | |
84281c31 | 1058 | { |
d728c370 | 1059 | my $message = '"1" is not \s'; |
c11a8df3 NC |
1060 | warning_is(sub {unlike("1\n" x 102, qr/^\s*\n/m, $message)}, |
1061 | undef, "$message (did not warn)"); | |
84281c31 | 1062 | } |
a4c04bdc | 1063 | |
84281c31 | 1064 | { |
4f890a30 | 1065 | my $message = '\s, [[:space:]] and [[:blank:]]'; |
84281c31 A |
1066 | my %space = (spc => " ", |
1067 | tab => "\t", | |
1068 | cr => "\r", | |
1069 | lf => "\n", | |
1070 | ff => "\f", | |
1071 | # There's no \v but the vertical tabulator seems miraculously | |
1072 | # be 11 both in ASCII and EBCDIC. | |
1073 | vt => chr(11), | |
1074 | false => "space"); | |
1075 | ||
1076 | my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space; | |
1077 | my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space; | |
1078 | my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space; | |
1079 | ||
075b9d7d | 1080 | is("@space0", "cr ff lf spc tab vt", $message); |
4f890a30 NC |
1081 | is("@space1", "cr ff lf spc tab vt", $message); |
1082 | is("@space2", "spc tab", $message); | |
84281c31 | 1083 | } |
a4c04bdc | 1084 | |
ff3f963a | 1085 | { |
c9415951 | 1086 | my $n= 50; |
93f09d7b | 1087 | # this must be a high number and go from 0 to N, as the bug we are looking for doesn't |
c9415951 YO |
1088 | # seem to be predictable. Slight changes to the test make it fail earlier or later. |
1089 | foreach my $i (0 .. $n) | |
1090 | { | |
1091 | my $str= "\n" x $i; | |
93f09d7b | 1092 | ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i"; |
c9415951 YO |
1093 | } |
1094 | } | |
92f3d482 YO |
1095 | { |
1096 | # we are actually testing that we dont die when executing these patterns | |
1097 | use utf8; | |
1098 | my $e = "Böck"; | |
1099 | ok(utf8::is_utf8($e),"got a unicode string - rt75680"); | |
1100 | ||
1101 | ok($e !~ m/.*?[x]$/, "unicode string against /.*?[x]\$/ - rt75680"); | |
1102 | ok($e !~ m/.*?\p{Space}$/i, "unicode string against /.*?\\p{space}\$/i - rt75680"); | |
1103 | ok($e !~ m/.*?[xyz]$/, "unicode string against /.*?[xyz]\$/ - rt75680"); | |
1104 | ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/, "unicode string against big pattern - rt75680"); | |
1105 | } | |
1106 | { | |
1107 | # we are actually testing that we dont die when executing these patterns | |
1108 | my $e = "B\x{f6}ck"; | |
1109 | ok(!utf8::is_utf8($e), "got a latin string - rt75680"); | |
1110 | ||
1111 | ok($e !~ m/.*?[x]$/, "latin string against /.*?[x]\$/ - rt75680"); | |
1112 | ok($e !~ m/.*?\p{Space}$/i, "latin string against /.*?\\p{space}\$/i - rt75680"); | |
1113 | ok($e !~ m/.*?[xyz]$/,"latin string against /.*?[xyz]\$/ - rt75680"); | |
1114 | ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/,"latin string against big pattern - rt75680"); | |
1115 | } | |
c920e018 A |
1116 | |
1117 | { | |
1118 | # | |
1119 | # Tests for bug 77414. | |
1120 | # | |
1121 | ||
4f890a30 | 1122 | my $message = '\p property after empty * match'; |
c920e018 | 1123 | { |
4f890a30 NC |
1124 | like("1", qr/\s*\pN/, $message); |
1125 | like("-", qr/\s*\p{Dash}/, $message); | |
1126 | like(" ", qr/\w*\p{Blank}/, $message); | |
c920e018 A |
1127 | } |
1128 | ||
4f890a30 NC |
1129 | like("1", qr/\s*\pN+/, $message); |
1130 | like("-", qr/\s*\p{Dash}{1}/, $message); | |
1131 | like(" ", qr/\w*\p{Blank}{1,4}/, $message); | |
c920e018 A |
1132 | |
1133 | } | |
1134 | ||
7c17ea2f KW |
1135 | SKIP: { # Some constructs with Latin1 characters cause a utf8 string not |
1136 | # to match itself in non-utf8 | |
ef237063 | 1137 | if ($::IS_EBCDIC) { |
7c17ea2f KW |
1138 | skip "Needs to be customized to run on EBCDIC", 6; |
1139 | } | |
634c83a2 KW |
1140 | my $c = "\xc0"; |
1141 | my $pattern = my $utf8_pattern = qr/((\xc0)+,?)/; | |
1142 | utf8::upgrade($utf8_pattern); | |
1143 | ok $c =~ $pattern, "\\xc0 =~ $pattern; Neither pattern nor target utf8"; | |
d4e0b827 | 1144 | ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8"; |
634c83a2 | 1145 | ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not"; |
d4e0b827 | 1146 | ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not"; |
634c83a2 KW |
1147 | utf8::upgrade($c); |
1148 | ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not"; | |
d4e0b827 | 1149 | ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not"; |
634c83a2 | 1150 | ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8"; |
d4e0b827 | 1151 | ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8"; |
634c83a2 KW |
1152 | } |
1153 | ||
8cc86590 | 1154 | SKIP: { # Make sure can override the formatting |
ef237063 | 1155 | if ($::IS_EBCDIC) { |
8cc86590 KW |
1156 | skip "Needs to be customized to run on EBCDIC", 2; |
1157 | } | |
1158 | use feature 'unicode_strings'; | |
1159 | ok "\xc0" =~ /\w/, 'Under unicode_strings: "\xc0" =~ /\w/'; | |
1160 | ok "\xc0" !~ /(?d:\w)/, 'Under unicode_strings: "\xc0" !~ /(?d:\w)/'; | |
1161 | } | |
1162 | ||
704f71be | 1163 | { |
5b6010b3 YO |
1164 | my $str= "\x{100}"; |
1165 | chop $str; | |
1166 | my $qr= qr/$str/; | |
de26e0cc | 1167 | is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212"); |
5b6010b3 YO |
1168 | $str= ""; |
1169 | $qr= qr/$str/; | |
de26e0cc | 1170 | is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212"); |
5b6010b3 YO |
1171 | |
1172 | } | |
1173 | ||
72aa120d | 1174 | { |
04934b6d | 1175 | local $::TODO = "[perl #38133]"; |
72aa120d KW |
1176 | |
1177 | "A" =~ /(((?:A))?)+/; | |
1178 | my $first = $2; | |
1179 | ||
1180 | "A" =~ /(((A))?)+/; | |
1181 | my $second = $2; | |
1182 | ||
de26e0cc | 1183 | is($first, $second); |
72aa120d KW |
1184 | } |
1185 | ||
99ca48e1 DM |
1186 | { |
1187 | # RT #3516: \G in a m//g expression causes problems | |
1188 | my $count = 0; | |
1189 | while ("abc" =~ m/(\G[ac])?/g) { | |
1190 | last if $count++ > 10; | |
1191 | } | |
1192 | ok($count < 10, 'RT #3516 A'); | |
1193 | ||
1194 | $count = 0; | |
1195 | while ("abc" =~ m/(\G|.)[ac]/g) { | |
1196 | last if $count++ > 10; | |
1197 | } | |
1198 | ok($count < 10, 'RT #3516 B'); | |
1199 | ||
1200 | $count = 0; | |
1201 | while ("abc" =~ m/(\G?[ac])?/g) { | |
1202 | last if $count++ > 10; | |
1203 | } | |
1204 | ok($count < 10, 'RT #3516 C'); | |
1205 | } | |
d774cd11 YO |
1206 | { |
1207 | # RT #84294: Is this a bug in the simple Perl regex? | |
1208 | # : Nested buffers and (?{...}) dont play nicely on partial matches | |
1209 | our @got= (); | |
1210 | ok("ab" =~ /((\w+)(?{ push @got, $2 })){2}/,"RT #84294: Pattern should match"); | |
d774cd11 YO |
1211 | my $want= "'ab', 'a', 'b'"; |
1212 | my $got= join(", ", map { defined($_) ? "'$_'" : "undef" } @got); | |
1213 | is($got,$want,'RT #84294: check that "ab" =~ /((\w+)(?{ push @got, $2 })){2}/ leaves @got in the correct state'); | |
1214 | } | |
1215 | ||
0bda3001 KW |
1216 | { |
1217 | # Suppress warnings, as the non-unicode one comes out even if turn off | |
1218 | # warnings here (because the execution is done in another scope). | |
1219 | local $SIG{__WARN__} = sub {}; | |
1220 | my $str = "\x{110000}"; | |
1221 | ||
2d88a86a KW |
1222 | unlike($str, qr/\p{ASCII_Hex_Digit=True}/, "Non-Unicode doesn't match \\p{AHEX=True}"); |
1223 | like($str, qr/\p{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\p{AHEX=False}"); | |
1224 | like($str, qr/\P{ASCII_Hex_Digit=True}/, "Non-Unicode matches \\P{AHEX=True}"); | |
1225 | unlike($str, qr/\P{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\P{AHEX=FALSE}"); | |
0bda3001 KW |
1226 | } |
1227 | ||
b289b443 | 1228 | { |
c256547e | 1229 | # Test that IDstart works, but because the author (khw) knows |
b289b443 KW |
1230 | # regexes much better than the rest of the core, it is being done here |
1231 | # in the context of a regex which relies on buffer names beginng with | |
1232 | # IDStarts. | |
1233 | use utf8; | |
1234 | my $str = "abc"; | |
1235 | like($str, qr/(?<a>abc)/, "'a' is legal IDStart"); | |
1236 | like($str, qr/(?<_>abc)/, "'_' is legal IDStart"); | |
1237 | like($str, qr/(?<ß>abc)/, "U+00DF is legal IDStart"); | |
1238 | like($str, qr/(?<â„•>abc)/, "U+2115' is legal IDStart"); | |
1239 | ||
1240 | # This test works on Unicode 6.0 in which U+2118 and U+212E are legal | |
1241 | # IDStarts there, but are not Word characters, and therefore Perl | |
1242 | # doesn't allow them to be IDStarts. But there is no guarantee that | |
1243 | # Unicode won't change things around in the future so that at some | |
1244 | # future Unicode revision these tests would need to be revised. | |
1245 | foreach my $char ("%", "×", chr(0x2118), chr(0x212E)) { | |
1246 | my $prog = <<"EOP"; | |
1247 | use utf8;; | |
1248 | "abc" =~ qr/(?<$char>abc)/; | |
1249 | EOP | |
1250 | utf8::encode($prog); | |
20e5bab4 | 1251 | fresh_perl_like($prog, qr!Group name must start with a non-digit word character!, {}, |
b289b443 KW |
1252 | sprintf("'U+%04X not legal IDFirst'", ord($char))); |
1253 | } | |
1254 | } | |
bbdd8bad KW |
1255 | |
1256 | { # [perl #101710] | |
1257 | my $pat = "b"; | |
1258 | utf8::upgrade($pat); | |
1259 | like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string"); | |
1260 | } | |
1261 | ||
ba510004 FC |
1262 | { # Crash with @a =~ // warning |
1263 | local $SIG{__WARN__} = sub { | |
1264 | pass 'no crash for @a =~ // warning' | |
1265 | }; | |
1266 | eval ' sub { my @a =~ // } '; | |
1267 | } | |
1268 | ||
cc88c9aa FC |
1269 | { # Concat overloading and qr// thingies |
1270 | my @refs; | |
1271 | my $qr = qr//; | |
3bbc3d30 YO |
1272 | package Cat { |
1273 | require overload; | |
1274 | overload->import( | |
cc88c9aa FC |
1275 | '""' => sub { ${$_[0]} }, |
1276 | '.' => sub { | |
1277 | push @refs, ref $_[1] if ref $_[1]; | |
1278 | bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]" | |
1279 | } | |
3bbc3d30 | 1280 | ); |
cc88c9aa FC |
1281 | } |
1282 | my $s = "foo"; | |
1283 | my $o = bless \$s, Cat::; | |
1284 | /$o$qr/; | |
1285 | is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth'; | |
1286 | } | |
1287 | ||
21eede78 YO |
1288 | { |
1289 | my $count=0; | |
1290 | my $str="\n"; | |
1291 | $count++ while $str=~/.*/g; | |
1292 | is $count, 2, 'test that ANCH_MBOL works properly. We should get 2 from $count++ while "\n"=~/.*/g'; | |
1293 | my $class_count= 0; | |
1294 | $class_count++ while $str=~/[^\n]*/g; | |
1295 | is $class_count, $count, 'while "\n"=~/.*/g and while "\n"=~/[^\n]*/g should behave the same'; | |
1296 | my $anch_count= 0; | |
1297 | $anch_count++ while $str=~/^.*/mg; | |
1298 | is $anch_count, 1, 'while "\n"=~/^.*/mg should match only once'; | |
1299 | } | |
96f54887 KW |
1300 | |
1301 | { # [perl #111174] | |
1302 | use re '/u'; | |
1303 | like "\xe0", qr/(?i:\xc0)/, "(?i: shouldn't lose the passed in /u"; | |
1304 | use re '/a'; | |
1305 | unlike "\x{100}", qr/(?i:\w)/, "(?i: shouldn't lose the passed in /a"; | |
1306 | use re '/aa'; | |
1307 | unlike 'k', qr/(?i:\N{KELVIN SIGN})/, "(?i: shouldn't lose the passed in /aa"; | |
1308 | } | |
6ae44cd2 DM |
1309 | |
1310 | { | |
1311 | # the test for whether the pattern should be re-compiled should | |
1312 | # consider the UTF8ness of the previous and current pattern | |
1313 | # string, as well as the physical bytes of the pattern string | |
1314 | ||
1315 | for my $s ("\xc4\x80", "\x{100}") { | |
1316 | ok($s =~ /^$s$/, "re-compile check is UTF8-aware"); | |
1317 | } | |
1318 | } | |
1319 | ||
e03b874a DM |
1320 | # #113682 more overloading and qr// |
1321 | # when doing /foo$overloaded/, if $overloaded returns | |
1322 | # a qr/(?{})/ via qr or "" overloading, then 'use re 'eval' | |
1323 | # shouldn't be required. Via '.', it still is. | |
1324 | { | |
1325 | package Qr0; | |
1326 | use overload 'qr' => sub { qr/(??{50})/ }; | |
1327 | ||
1328 | package Qr1; | |
1329 | use overload '""' => sub { qr/(??{51})/ }; | |
1330 | ||
1331 | package Qr2; | |
1332 | use overload '.' => sub { $_[1] . qr/(??{52})/ }; | |
1333 | ||
1334 | package Qr3; | |
1335 | use overload '""' => sub { qr/(??{7})/ }, | |
1336 | '.' => sub { $_[1] . qr/(??{53})/ }; | |
1337 | ||
1338 | package Qr_indirect; | |
1339 | use overload '""' => sub { $_[0][0] }; | |
1340 | ||
1341 | package main; | |
1342 | ||
1343 | for my $i (0..3) { | |
1344 | my $o = bless [], "Qr$i"; | |
1345 | if ((0,0,1,1)[$i]) { | |
1346 | eval { "A5$i" =~ /^A$o$/ }; | |
1347 | like($@, qr/Eval-group not allowed/, "Qr$i"); | |
1348 | eval { "5$i" =~ /$o/ }; | |
1349 | like($@, ($i == 3 ? qr/^$/ : qr/no method found,/), | |
1350 | "Qr$i bare"); | |
1351 | { | |
1352 | use re 'eval'; | |
1353 | ok("A5$i" =~ /^A$o$/, "Qr$i - with use re eval"); | |
1354 | eval { "5$i" =~ /$o/ }; | |
1355 | like($@, ($i == 3 ? qr/^$/ : qr/no method found,/), | |
1356 | "Qr$i bare - with use re eval"); | |
1357 | } | |
1358 | } | |
1359 | else { | |
1360 | ok("A5$i" =~ /^A$o$/, "Qr$i"); | |
1361 | ok("5$i" =~ /$o/, "Qr$i bare"); | |
1362 | } | |
1363 | } | |
1364 | ||
1365 | my $o = bless [ bless [], "Qr1" ], 'Qr_indirect'; | |
1366 | ok("A51" =~ /^A$o/, "Qr_indirect"); | |
1367 | ok("51" =~ /$o/, "Qr_indirect bare"); | |
1368 | } | |
1369 | ||
34b39fc9 KW |
1370 | { # Various flags weren't being set when a [] is optimized into an |
1371 | # EXACTish node | |
1372 | ; | |
1373 | ; | |
1374 | ok("\x{017F}\x{017F}" =~ qr/^[\x{00DF}]?$/i, "[] to EXACTish optimization"); | |
1375 | } | |
1376 | ||
5e4a1da1 KW |
1377 | { |
1378 | for my $char (":", "\x{f7}", "\x{2010}") { | |
1379 | my $utf8_char = $char; | |
1380 | utf8::upgrade($utf8_char); | |
1381 | my $display = $char; | |
1382 | $display = display($display); | |
1383 | my $utf8_display = "utf8::upgrade(\"$display\")"; | |
1384 | ||
1385 | like($char, qr/^$char?$/, "\"$display\" =~ /^$display?\$/"); | |
1386 | like($char, qr/^$utf8_char?$/, "my \$p = \"$display\"; utf8::upgrade(\$p); \"$display\" =~ /^\$p?\$/"); | |
1387 | like($utf8_char, qr/^$char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); \"\$c\" =~ /^$display?\$/"); | |
1388 | like($utf8_char, qr/^$utf8_char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); my \$p = \"$display\"; utf8::upgrade(\$p); \"\$c\" =~ /^\$p?\$/"); | |
1389 | } | |
1390 | } | |
1391 | ||
4fab19ce DM |
1392 | { |
1393 | # #116148: Pattern utf8ness sticks around globally | |
1394 | # the utf8 in the first match was sticking around for the second | |
1395 | # match | |
1396 | ||
1397 | use feature 'unicode_strings'; | |
1398 | ||
1399 | my $x = "\x{263a}"; | |
1400 | $x =~ /$x/; | |
1401 | ||
1402 | my $text = "Perl"; | |
1403 | ok("Perl" =~ /P.*$/i, '#116148'); | |
1404 | } | |
1405 | ||
182b0c3f KW |
1406 | { # 117327: Sequence (?#...) not recognized in regex |
1407 | # The space between the '(' and '?' is now deprecated; this test should | |
1408 | # be removed when the deprecation is made fatal. | |
1409 | no warnings; | |
1410 | like("ab", qr/a( ?#foo)b/x); | |
1411 | } | |
1412 | ||
b8372399 DIM |
1413 | { # 118297: Mixing up- and down-graded strings in regex |
1414 | utf8::upgrade(my $u = "\x{e5}"); | |
1415 | utf8::downgrade(my $d = "\x{e5}"); | |
1416 | my $warned; | |
1417 | local $SIG{__WARN__} = sub { $warned++ if $_[0] =~ /\AMalformed UTF-8/ }; | |
1418 | my $re = qr/$u$d/; | |
1419 | ok(!$warned, "no warnings when interpolating mixed up-/downgraded strings in pattern"); | |
1420 | my $c = "\x{e5}\x{e5}"; | |
1421 | utf8::downgrade($c); | |
1422 | like($c, $re, "mixed up-/downgraded pattern matches downgraded string"); | |
1423 | utf8::upgrade($c); | |
1424 | like($c, $re, "mixed up-/downgraded pattern matches upgraded string"); | |
1425 | } | |
4fab19ce | 1426 | |
f1e1b256 YO |
1427 | { |
1428 | # if we have 87 capture buffers defined then \87 should refer to the 87th. | |
1429 | # test that this is true for 1..100 | |
19438407 S |
1430 | # Note that this test causes the engine to recurse at runtime, and |
1431 | # hence use a lot of C stack. | |
f1e1b256 | 1432 | for my $i (1..100) { |
31108f3e YO |
1433 | my $capture= "a"; |
1434 | $capture= "($capture)" for 1 .. $i; | |
1435 | for my $mid ("","b") { | |
1436 | my $str= "a${mid}a"; | |
1437 | my $backref= "\\$i"; | |
1438 | eval { | |
1439 | ok($str=~/$capture$mid$backref/,"\\$i works with $i buffers '$str'=~/...$mid$backref/"); | |
1440 | 1; | |
1441 | } or do { | |
1442 | is("$@","","\\$i works with $i buffers works with $i buffers '$str'=~/...$mid$backref/"); | |
1443 | }; | |
1444 | } | |
f1e1b256 YO |
1445 | } |
1446 | } | |
1447 | ||
5411a0e5 DM |
1448 | # this mixture of readonly (not COWable) and COWable strings |
1449 | # messed up the capture buffers under COW. The actual test results | |
1450 | # are incidental; the issue is was an AddressSanitizer failure | |
1451 | { | |
1452 | my $c ='AB'; | |
1453 | my $res = ''; | |
1454 | for ($c, 'C', $c, 'DE') { | |
1455 | ok(/(.)/, "COWable match"); | |
1456 | $res .= $1; | |
1457 | } | |
1458 | is($res, "ACAD"); | |
1459 | } | |
1460 | ||
1461 | ||
61965f1d FC |
1462 | { |
1463 | # RT #45667 | |
1464 | # /[#$x]/x didn't interpolate the var $x. | |
1465 | my $b = 'cd'; | |
1466 | my $s = 'abcd$%#&'; | |
1467 | $s =~ s/[a#$b%]/X/g; | |
1468 | is ($s, 'XbXX$XX&', 'RT #45667 without /x'); | |
1469 | $s = 'abcd$%#&'; | |
1470 | $s =~ s/[a#$b%]/X/gx; | |
1471 | is ($s, 'XbXX$XX&', 'RT #45667 with /x'); | |
1472 | } | |
1473 | ||
0cb43d32 FC |
1474 | { |
1475 | no warnings "uninitialized"; | |
1476 | my @a; | |
1477 | $a[1]++; | |
1478 | /@a/; | |
1479 | pass('no crash with /@a/ when array has nonexistent elems'); | |
1480 | } | |
1481 | ||
475b1e90 FC |
1482 | { |
1483 | is runperl(prog => 'delete $::{qq-\cR-}; //; print qq-ok\n-'), | |
1484 | "ok\n", | |
4a2b275c | 1485 | 'deleting *^R does not result in crashes'; |
d772ce1c | 1486 | no warnings 'once'; |
4a2b275c FC |
1487 | *^R = *caretRglobwithnoscalar; |
1488 | "" =~ /(?{42})/; | |
1489 | is $^R, 42, 'assigning to *^R does not result in a crash'; | |
7e68f152 FC |
1490 | is runperl( |
1491 | stderr => 1, | |
1492 | prog => 'eval q|' | |
1493 | .' q-..- =~ /(??{undef *^R;q--})(?{42})/; ' | |
1494 | .' print qq-$^R\n-' | |
1495 | .'|' | |
1496 | ), | |
1497 | "42\n", | |
1498 | 'undefining *^R within (??{}) does not result in a crash'; | |
475b1e90 FC |
1499 | } |
1500 | ||
0b2c2a84 DM |
1501 | { |
1502 | # [perl #120446] | |
1503 | # this code should be virtually instantaneous. If it takes 10s of | |
1504 | # seconds, there a bug in intuit_start. | |
1505 | # (this test doesn't actually test for slowness - that involves | |
1506 | # too much danger of false positives on loaded machines - but by | |
1507 | # putting it here, hopefully someone might notice if it suddenly | |
1508 | # runs slowly) | |
1509 | my $s = ('a' x 1_000_000) . 'b'; | |
1510 | my $i = 0; | |
1511 | for (1..10_000) { | |
1512 | pos($s) = $_; | |
1513 | $i++ if $s =~/\Gb/g; | |
1514 | } | |
1515 | is($i, 0, "RT 120446: mustn't run slowly"); | |
1516 | } | |
1517 | ||
d6ef1678 DM |
1518 | { |
1519 | # [perl #120692] | |
1520 | # these tests should be virtually instantaneous. If they take 10s of | |
1521 | # seconds, there's a bug in intuit_start. | |
1522 | ||
1523 | my $s = 'ab' x 1_000_000; | |
1524 | utf8::upgrade($s); | |
1525 | 1 while $s =~ m/\Ga+ba+b/g; | |
1526 | pass("RT#120692 \\G mustn't run slowly"); | |
1527 | ||
1528 | $s=~ /^a{1,2}x/ for 1..10_000; | |
1529 | pass("RT#120692 a{1,2} mustn't run slowly"); | |
8e9f2289 DM |
1530 | |
1531 | $s=~ /ab.{1,2}x/; | |
1532 | pass("RT#120692 ab.{1,2} mustn't run slowly"); | |
b96863b8 DM |
1533 | |
1534 | $s = "-a-bc" x 250_000; | |
1535 | $s .= "1a1bc"; | |
1536 | utf8::upgrade($s); | |
1537 | ok($s =~ /\da\d{0,30000}bc/, "\\d{30000}"); | |
1538 | ||
ec19cf6b DM |
1539 | $s = "-ab\n" x 250_000; |
1540 | $s .= "abx"; | |
1541 | ok($s =~ /^ab.*x/m, "distant float with /m"); | |
1542 | ||
8f10278a DM |
1543 | my $r = qr/^abcd/; |
1544 | $s = "abcd-xyz\n" x 500_000; | |
1545 | $s =~ /$r\d{1,2}xyz/m for 1..200; | |
1546 | pass("BOL within //m mustn't run slowly"); | |
1547 | ||
d0d44648 DM |
1548 | $s = "abcdefg" x 1_000_000; |
1549 | $s =~ /(?-m:^)abcX?fg/m for 1..100; | |
1550 | pass("BOL within //m mustn't skip absolute anchored check"); | |
1551 | ||
e0362b86 DM |
1552 | $s = "abcdefg" x 1_000_000; |
1553 | $s =~ /^XX\d{1,10}cde/ for 1..100; | |
1554 | pass("abs anchored float string should fail quickly"); | |
1555 | ||
d6ef1678 DM |
1556 | } |
1557 | ||
749e076f KW |
1558 | # These are based on looking at the code in regcomp.c |
1559 | # We don't look for specific code, just the existence of an SSC | |
1560 | foreach my $re (qw( qr/a?c/ | |
1561 | qr/a?c/i | |
1562 | qr/[ab]?c/ | |
1563 | qr/\R?c/ | |
1564 | qr/\d?c/d | |
1565 | qr/\w?c/l | |
1566 | qr/\s?c/a | |
1567 | qr/[[:alpha:]]?c/u | |
1568 | )) { | |
d7919c41 FC |
1569 | SKIP: { |
1570 | skip "no re-debug under miniperl" if is_miniperl; | |
749e076f KW |
1571 | my $prog = <<"EOP"; |
1572 | use re qw(Debug COMPILE); | |
1573 | $re; | |
1574 | EOP | |
20e5bab4 | 1575 | fresh_perl_like($prog, qr/synthetic stclass/, { stderr=>1 }, "$re generates a synthetic start class"); |
d7919c41 | 1576 | } |
749e076f KW |
1577 | } |
1578 | ||
86897aa6 KW |
1579 | { |
1580 | like "\x{AA}", qr/a?[\W_]/d, "\\W with /d synthetic start class works"; | |
1581 | } | |
1582 | ||
1583 | ||
0b2c2a84 | 1584 | |
84281c31 A |
1585 | } # End of sub run_tests |
1586 | ||
1587 | 1; |