This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Prune redundant blank lines.
[perl5.git] / t / re / pat.t
CommitLineData
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
ff3f963a
KW
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
A
9use strict;
10use warnings;
11use 5.010;
12
13
14sub run_tests;
15
9133bbab 16$| = 1;
3568d838 17
8d37f932 18
e4d48cc9
GS
19BEGIN {
20 chdir 't' if -d 't';
9d45b377
YO
21 @INC = ('../lib','.');
22 do "re/ReTest.pl" or die $@;
e4d48cc9 23}
84281c31 24
84281c31 25
7bd6b0e6 26plan tests => 426; # Update this when adding/deleting tests.
b7a35066 27
9d45b377 28run_tests() unless caller;
b7a35066 29
84281c31
A
30#
31# Tests start here.
32#
33sub run_tests {
0ef3e39e 34
84281c31 35 {
84281c31 36 my $x = "abc\ndef\n";
5895685f 37 (my $x_pretty = $x) =~ s/\n/\\n/g;
fd291da9 38
5895685f
NC
39 ok $x =~ /^abc/, qq ["$x_pretty" =~ /^abc/];
40 ok $x !~ /^def/, qq ["$x_pretty" !~ /^def/];
fd291da9 41
84281c31 42 # used to be a test for $*
5895685f 43 ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m];
fd291da9 44
b33825c4
NC
45 ok(!($x =~ /^xxx/), qq ["$x_pretty" =~ /^xxx/]);
46 ok(!($x !~ /^abc/), qq ["$x_pretty" !~ /^abc/]);
fd291da9 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 !~ /.def/, qq ["$x_pretty" !~ /.def/];
b33825c4 52 ok(!($x =~ /.def/), qq ["$x_pretty" =~ /.def/]);
4765795a 53
5895685f 54 ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/];
b33825c4 55 ok(!($x !~ /\ndef/), qq ["$x_pretty" !~ /\\ndef/]);
84281c31 56 }
4765795a 57
84281c31
A
58 {
59 $_ = '123';
60 ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/];
61 }
f9969324 62
84281c31
A
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+)/];
b33825c4 68 unlike($_, qr/a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]);
84281c31
A
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*/];
b33825c4 76 unlike($_, qr/a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]);
84281c31
A
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
A
85 {
86 # used to be a test for $*
5895685f 87 ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m];
84281c31 88 }
4765795a 89
84281c31
A
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)) {
b33825c4 95 my $e = index ($_, 'not') >= 0 ? '' : 1;
725a61d7 96 my $r = m?(.*)?;
b33825c4 97 is($r, $e, "?(.*)?");
84281c31
A
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
A
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 {
4f890a30 119 my $message = "Test empty pattern";
84281c31
A
120 my $xyz = 'xyz';
121 my $cde = 'cde';
122
123 $cde =~ /[^ab]*/;
124 $xyz =~ //;
4f890a30 125 is($&, $xyz, $message);
84281c31
A
126
127 my $foo = '[^ab]*';
128 $cde =~ /$foo/;
129 $xyz =~ //;
4f890a30 130 is($&, $xyz, $message);
84281c31
A
131
132 $cde =~ /$foo/;
133 my $null;
134 no warnings 'uninitialized';
135 $xyz =~ /$null/;
4f890a30 136 is($&, $xyz, $message);
84281c31
A
137
138 $null = "";
139 $xyz =~ /$null/;
4f890a30 140 is($&, $xyz, $message);
84281c31 141 }
4765795a 142
84281c31 143 {
4f890a30 144 my $message = q !Check $`, $&, $'!;
84281c31 145 $_ = 'abcdefghi';
0f289c68 146 /def/; # optimized up to cmd
4f890a30 147 is("$`:$&:$'", 'abc:def:ghi', $message);
4765795a 148
84281c31 149 no warnings 'void';
0f289c68 150 /cde/ + 0; # optimized only to spat
4f890a30 151 is("$`:$&:$'", 'ab:cde:fghi', $message);
4765795a 152
0f289c68 153 /[d][e][f]/; # not optimized
4f890a30 154 is("$`:$&:$'", 'abc:def:ghi', $message);
84281c31 155 }
4765795a 156
84281c31
A
157 {
158 $_ = 'now is the {time for all} good men to come to.';
159 / {([^}]*)}/;
de26e0cc 160 is($1, 'time for all', "Match braces");
84281c31 161 }
4765795a 162
84281c31 163 {
4f890a30 164 my $message = "{N,M} quantifier";
84281c31 165 $_ = 'xxx {3,4} yyy zzz';
4f890a30
NC
166 ok(/( {3,4})/, $message);
167 is($1, ' ', $message);
168 unlike($_, qr/( {4,})/, $message);
169 ok(/( {2,3}.)/, $message);
170 is($1, ' y', $message);
171 ok(/(y{2,3}.)/, $message);
172 is($1, 'yyy ', $message);
173 unlike($_, qr/x {3,4}/, $message);
174 unlike($_, qr/^xxx {3,4}/, $message);
84281c31 175 }
4765795a 176
84281c31 177 {
4f890a30 178 my $message = "Test /g";
84281c31
A
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
4f890a30 184 is("@words", $exp, $message);
4765795a 185
84281c31
A
186 @words = ();
187 while (/\w+/g) {
188 push (@words, $&);
189 }
4f890a30 190 is("@words", $exp, $message);
4765795a 191
84281c31
A
192 @words = ();
193 pos = 0;
194 while (/to/g) {
195 push(@words, $&);
196 }
4f890a30 197 is("@words", "to:to", $message);
4765795a 198
84281c31
A
199 pos $_ = 0;
200 @words = /to/g;
4f890a30 201 is("@words", "to:to", $message);
84281c31 202 }
4765795a 203
84281c31
A
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";
de26e0cc 232 is($x, '505550555', "Test /o");
84281c31 233 }
4765795a 234
4f890a30 235 {
84281c31
A
236 my $xyz = 'xyz';
237 ok "abc" =~ /^abc$|$xyz/, "| after \$";
4765795a 238
84281c31 239 # perl 4.009 says "unmatched ()"
4f890a30 240 my $message = '$ inside ()';
4765795a 241
84281c31
A
242 my $result;
243 eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
4f890a30
NC
244 is($@, "", $message);
245 is($result, "abc:bc", $message);
84281c31 246 }
4765795a 247
84281c31 248 {
4f890a30 249 my $message = "Scalar /g";
84281c31
A
250 $_ = "abcfooabcbar";
251
4f890a30
NC
252 ok( /abc/g && $` eq "", $message);
253 ok( /abc/g && $` eq "abcfoo", $message);
254 ok(!/abc/g, $message);
84281c31 255
4f890a30 256 $message = "Scalar /gi";
84281c31 257 pos = 0;
4f890a30
NC
258 ok( /ABC/gi && $` eq "", $message);
259 ok( /ABC/gi && $` eq "abcfoo", $message);
260 ok(!/ABC/gi, $message);
84281c31 261
4f890a30 262 $message = "Scalar /g";
84281c31 263 pos = 0;
4f890a30
NC
264 ok( /abc/g && $' eq "fooabcbar", $message);
265 ok( /abc/g && $' eq "bar", $message);
84281c31
A
266
267 $_ .= '';
268 my @x = /abc/g;
de26e0cc 269 is(@x, 2, "/g reset after assignment");
4765795a 270 }
4765795a 271
84281c31 272 {
4f890a30 273 my $message = '/g, \G and pos';
84281c31
A
274 $_ = "abdc";
275 pos $_ = 2;
276 /\Gc/gc;
4f890a30 277 is(pos $_, 2, $message);
84281c31 278 /\Gc/g;
4f890a30 279 is(pos $_, undef, $message);
84281c31 280 }
4765795a 281
84281c31 282 {
4f890a30 283 my $message = '(?{ })';
84281c31
A
284 our $out = 1;
285 'abc' =~ m'a(?{ $out = 2 })b';
4f890a30 286 is($out, 2, $message);
84281c31
A
287
288 $out = 1;
289 'abc' =~ m'a(?{ $out = 3 })c';
4f890a30 290 is($out, 1, $message);
84281c31 291 }
4765795a 292
84281c31
A
293 {
294 $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
295 my @out = /(?<!foo)bar./g;
de26e0cc 296 is("@out", 'bar2 barf', "Negative lookbehind");
84281c31 297 }
4765795a 298
84281c31 299 {
4f890a30 300 my $message = "REG_INFTY tests";
84281c31
A
301 # Tests which depend on REG_INFTY
302 $::reg_infty = $Config {reg_infty} // 32767;
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
4f890a30
NC
311 eval_ok q (('aaa' =~ /(a{1,$::reg_infty_m})/)[0] eq 'aaa'), $message;
312 eval_ok q (('a' x $::reg_infty_m) =~ /a{$::reg_infty_m}/), $message;
313 eval_ok q (('a' x ($::reg_infty_m - 1)) !~ /a{$::reg_infty_m}/), $message;
84281c31 314 eval "'aaa' =~ /a{1,$::reg_infty}/";
4f890a30 315 like($@, /^\QQuantifier in {,} bigger than/, $message);
84281c31 316 eval "'aaa' =~ /a{1,$::reg_infty_p}/";
4f890a30 317 like($@, qr/^\QQuantifier in {,} bigger than/, $message);
4765795a 318 }
8269fa76 319
84281c31
A
320 {
321 # Poke a couple more parse failures
322 my $context = 'x' x 256;
323 eval qq("${context}y" =~ /(?<=$context)y/);
324 ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit";
325 }
8269fa76 326
84281c31
A
327 {
328 # Long Monsters
84281c31
A
329 for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
330 my $a = 'a' x $l;
4f890a30
NC
331 my $message = "Long monster, length = $l";
332 like("ba$a=", qr/a$a=/, $message);
333 unlike("b$a=", qr/a$a=/, $message);
334 like("b$a=", qr/ba+=/, $message);
84281c31 335
4f890a30 336 like("ba$a=", /b(?:a|b)+=/, $message);
84281c31
A
337 }
338 }
8269fa76 339
84281c31
A
340 {
341 # 20000 nodes, each taking 3 words per string, and 1 per branch
342 my $long_constant_len = join '|', 12120 .. 32645;
343 my $long_var_len = join '|', 8120 .. 28645;
344 my %ans = ( 'ax13876y25677lbc' => 1,
345 'ax13876y25677mcb' => 0, # not b.
346 'ax13876y35677nbc' => 0, # Num too big
347 'ax13876y25677y21378obc' => 1,
0f289c68 348 'ax13876y25677y21378zbc' => 0, # Not followed by [k-o]
84281c31
A
349 'ax13876y25677y21378y21378kbc' => 1,
350 'ax13876y25677y21378y21378kcb' => 0, # Not b.
351 'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
352 );
353
84281c31 354 for (keys %ans) {
4f890a30
NC
355 my $message = "20000 nodes, const-len '$_'";
356 ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o), $message;
84281c31 357
4f890a30
NC
358 $message = "20000 nodes, var-len '$_'";
359 ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o,), $message;
84281c31 360 }
b8ef571c 361 }
209a9bc1 362
84281c31 363 {
4f890a30 364 my $message = "Complicated backtracking";
84281c31
A
365 $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
366 my $expect = "(bla()) ((l)u((e))) (l(e)e)";
367
368 use vars '$c';
369 sub matchit {
370 m/
371 (
372 \(
0f289c68 373 (?{ $c = 1 }) # Initialize
84281c31
A
374 (?:
375 (?(?{ $c == 0 }) # PREVIOUS iteration was OK, stop the loop
376 (?!
0f289c68
YO
377 ) # Fail: will unwind one iteration back
378 )
84281c31 379 (?:
0f289c68 380 [^()]+ # Match a big chunk
84281c31
A
381 (?=
382 [()]
0f289c68 383 ) # Do not try to match subchunks
84281c31
A
384 |
385 \(
386 (?{ ++$c })
387 |
388 \)
389 (?{ --$c })
390 )
0f289c68 391 )+ # This may not match with different subblocks
84281c31
A
392 )
393 (?(?{ $c != 0 })
394 (?!
0f289c68
YO
395 ) # Fail
396 ) # Otherwise the chunk 1 may succeed with $c>0
84281c31
A
397 /xg;
398 }
3568d838 399
84281c31
A
400 my @ans = ();
401 my $res;
402 push @ans, $res while $res = matchit;
4f890a30 403 is("@ans", "1 1 1", $message);
3568d838 404
84281c31 405 @ans = matchit;
4f890a30 406 is("@ans", $expect, $message);
3568d838 407
4f890a30 408 $message = "Recursion with (??{ })";
84281c31
A
409 our $matched;
410 $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/;
3568d838 411
84281c31
A
412 @ans = my @ans1 = ();
413 push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g;
3568d838 414
4f890a30
NC
415 is("@ans", "1 1 1", $message);
416 is("@ans1", $expect, $message);
3568d838 417
84281c31 418 @ans = m/$matched/g;
4f890a30 419 is("@ans", $expect, $message);
3568d838 420
84281c31 421 }
3568d838 422
84281c31
A
423 {
424 ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/';
425 }
3568d838 426
84281c31 427 {
0f289c68 428 my @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad
de26e0cc 429 is("@ans", 'a/ b', "Stack may be bad");
84281c31 430 }
3568d838 431
84281c31 432 {
4f890a30 433 my $message = "Eval-group not allowed at runtime";
84281c31
A
434 my $code = '{$blah = 45}';
435 our $blah = 12;
436 eval { /(?$code)/ };
4f890a30 437 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message);
84281c31 438
3044771b
NC
439 $blah = 12;
440 my $res = eval { "xx" =~ /(?$code)/o };
441 {
442 no warnings 'uninitialized';
5895685f 443 chomp $@; my $message = "$message '$@', '$res', '$blah'";
4f890a30 444 ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message);
3044771b
NC
445 }
446
447 $code = '=xx';
448 $blah = 12;
449 $res = eval { "xx" =~ /(?$code)/o };
450 {
451 no warnings 'uninitialized';
4f890a30
NC
452 my $message = "$message '$@', '$res', '$blah'";
453 ok(!$@ && $res, $message);
3044771b 454 }
3568d838 455
84281c31
A
456 $code = '{$blah = 45}';
457 $blah = 12;
458 eval "/(?$code)/";
4f890a30 459 is($blah, 45, $message);
3568d838 460
84281c31
A
461 $blah = 12;
462 /(?{$blah = 45})/;
4f890a30 463 is($blah, 45, $message);
84281c31 464 }
3568d838 465
84281c31 466 {
4f890a30 467 my $message = "Pos checks";
84281c31
A
468 my $x = 'banana';
469 $x =~ /.a/g;
4f890a30 470 is(pos $x, 2, $message);
3568d838 471
84281c31 472 $x =~ /.z/gc;
4f890a30 473 is(pos $x, 2, $message);
3568d838 474
84281c31
A
475 sub f {
476 my $p = $_[0];
477 return $p;
478 }
3568d838 479
84281c31 480 $x =~ /.a/g;
4f890a30 481 is(f (pos $x), 4, $message);
84281c31 482 }
3568d838 483
84281c31 484 {
4f890a30 485 my $message = 'Checking $^R';
84281c31
A
486 our $x = $^R = 67;
487 'foot' =~ /foo(?{$x = 12; 75})[t]/;
4f890a30 488 is($^R, 75, $message);
84281c31
A
489
490 $x = $^R = 67;
491 'foot' =~ /foo(?{$x = 12; 75})[xy]/;
4f890a30 492 ok($^R eq '67' && $x eq '12', $message);
84281c31
A
493
494 $x = $^R = 67;
495 'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
4f890a30 496 ok($^R eq '79' && $x eq '12', $message);
84281c31 497 }
3568d838 498
84281c31 499 {
de26e0cc
NC
500 is(qr/\b\v$/i, '(?^i:\b\v$)', 'qr/\b\v$/i');
501 is(qr/\b\v$/s, '(?^s:\b\v$)', 'qr/\b\v$/s');
502 is(qr/\b\v$/m, '(?^m:\b\v$)', 'qr/\b\v$/m');
503 is(qr/\b\v$/x, '(?^x:\b\v$)', 'qr/\b\v$/x');
504 is(qr/\b\v$/xism, '(?^msix:\b\v$)', 'qr/\b\v$/xism');
505 is(qr/\b\v$/, '(?^:\b\v$)', 'qr/\b\v$/');
84281c31 506 }
3568d838 507
9de15fec 508 { # Test that charset modifier work, and are interpolated
de26e0cc
NC
509 is(qr/\b\v$/, '(?^:\b\v$)', 'Verify no locale, no unicode_strings gives default modifier');
510 is(qr/(?l:\b\v$)/, '(?^:(?l:\b\v$))', 'Verify infix l modifier compiles');
511 is(qr/(?u:\b\v$)/, '(?^:(?u:\b\v$))', 'Verify infix u modifier compiles');
512 is(qr/(?l)\b\v$/, '(?^:(?l)\b\v$)', 'Verify (?l) compiles');
513 is(qr/(?u)\b\v$/, '(?^:(?u)\b\v$)', 'Verify (?u) compiles');
9de15fec
KW
514
515 my $dual = qr/\b\v$/;
516 use locale;
517 my $locale = qr/\b\v$/;
de26e0cc 518 is($locale, '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale');
9de15fec
KW
519 no locale;
520
521 use feature 'unicode_strings';
522 my $unicode = qr/\b\v$/;
de26e0cc
NC
523 is($unicode, '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings');
524 is(qr/abc$dual/, '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale');
525 is(qr/abc$locale/, '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings');
9de15fec
KW
526
527 no feature 'unicode_strings';
de26e0cc
NC
528 is(qr/abc$locale/, '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings');
529 is(qr/def$unicode/, '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings');
9de15fec
KW
530
531 use locale;
de26e0cc
NC
532 is(qr/abc$dual/, '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale');
533 is(qr/abc$unicode/, '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale');
9de15fec
KW
534 }
535
84281c31 536 {
4f890a30 537 my $message = "Look around";
84281c31 538 $_ = 'xabcx';
84281c31 539 foreach my $ans ('', 'c') {
4f890a30
NC
540 ok(/(?<=(?=a)..)((?=c)|.)/g, $message);
541 is($1, $ans, $message);
84281c31
A
542 }
543 }
3568d838 544
84281c31 545 {
4f890a30 546 my $message = "Empty clause";
84281c31
A
547 $_ = 'a';
548 foreach my $ans ('', 'a', '') {
4f890a30
NC
549 ok(/^|a|$/g, $message);
550 is($&, $ans, $message);
84281c31
A
551 }
552 }
3568d838 553
84281c31 554 {
84281c31 555 sub prefixify {
4f890a30
NC
556 my $message = "Prefixify";
557 {
84281c31 558 my ($v, $a, $b, $res) = @_;
4f890a30
NC
559 ok($v =~ s/\Q$a\E/$b/, $message);
560 is($v, $res, $message);
84281c31
A
561 }
562 }
3568d838 563
84281c31
A
564 prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch');
565 prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch');
566 }
3568d838 567
84281c31
A
568 {
569 $_ = 'var="foo"';
570 /(\")/;
571 ok $1 && /$1/, "Capture a quote";
572 }
3568d838 573
84281c31 574 {
84281c31 575 no warnings 'closure';
4f890a30 576 my $message = '(?{ $var } refers to package vars';
84281c31
A
577 package aa;
578 our $c = 2;
579 $::c = 3;
580 '' =~ /(?{ $c = 4 })/;
4f890a30
NC
581 main::is($c, 4, $message);
582 main::is($::c, 3, $message);
84281c31 583 }
3568d838 584
84281c31
A
585 {
586 must_die 'q(a:[b]:) =~ /[x[:foo:]]/',
88743d87 587 qr/POSIX class \[:[^:]+:\] unknown in regex/,
84281c31
A
588 'POSIX class [: :] must have valid name';
589
590 for my $d (qw [= .]) {
591 must_die "/[[${d}foo${d}]]/",
88743d87 592 qr/\QPOSIX syntax [$d $d] is reserved for future extensions/,
84281c31
A
593 "POSIX syntax [[$d $d]] is an error";
594 }
595 }
3568d838 596
84281c31
A
597 {
598 # test if failure of patterns returns empty list
4f890a30 599 my $message = "Failed pattern returns empty list";
84281c31
A
600 $_ = 'aaa';
601 @_ = /bbb/;
4f890a30 602 is("@_", "", $message);
3568d838 603
84281c31 604 @_ = /bbb/g;
4f890a30 605 is("@_", "", $message);
a72deede 606
84281c31 607 @_ = /(bbb)/;
4f890a30 608 is("@_", "", $message);
a72deede 609
84281c31 610 @_ = /(bbb)/g;
4f890a30 611 is("@_", "", $message);
84281c31 612 }
a72deede 613
84281c31 614 {
4f890a30 615 my $message = '@- and @+ tests';
84281c31
A
616
617 /a(?=.$)/;
4f890a30
NC
618 is($#+, 0, $message);
619 is($#-, 0, $message);
620 is($+ [0], 2, $message);
621 is($- [0], 1, $message);
622 ok(!defined $+ [1] && !defined $- [1] &&
623 !defined $+ [2] && !defined $- [2], $message);
84281c31
A
624
625 /a(a)(a)/;
4f890a30
NC
626 is($#+, 2, $message);
627 is($#-, 2, $message);
628 is($+ [0], 3, $message);
629 is($- [0], 0, $message);
630 is($+ [1], 2, $message);
631 is($- [1], 1, $message);
632 is($+ [2], 3, $message);
633 is($- [2], 2, $message);
634 ok(!defined $+ [3] && !defined $- [3] &&
635 !defined $+ [4] && !defined $- [4], $message);
84281c31 636
54a4274e 637 # Exists has a special check for @-/@+ - bug 45147
4f890a30
NC
638 ok(exists $-[0], $message);
639 ok(exists $+[0], $message);
640 ok(exists $-[2], $message);
641 ok(exists $+[2], $message);
642 ok(!exists $-[3], $message);
643 ok(!exists $+[3], $message);
644 ok(exists $-[-1], $message);
645 ok(exists $+[-1], $message);
646 ok(exists $-[-3], $message);
647 ok(exists $+[-3], $message);
648 ok(!exists $-[-4], $message);
649 ok(!exists $+[-4], $message);
84281c31
A
650
651 /.(a)(b)?(a)/;
4f890a30
NC
652 is($#+, 3, $message);
653 is($#-, 3, $message);
654 is($+ [1], 2, $message);
655 is($- [1], 1, $message);
656 is($+ [3], 3, $message);
657 is($- [3], 2, $message);
658 ok(!defined $+ [2] && !defined $- [2] &&
659 !defined $+ [4] && !defined $- [4], $message);
84281c31 660
84281c31 661 /.(a)/;
4f890a30
NC
662 is($#+, 1, $message);
663 is($#-, 1, $message);
664 is($+ [0], 2, $message);
665 is($- [0], 0, $message);
666 is($+ [1], 2, $message);
667 is($- [1], 1, $message);
668 ok(!defined $+ [2] && !defined $- [2] &&
669 !defined $+ [3] && !defined $- [3], $message);
84281c31
A
670
671 /.(a)(ba*)?/;
4f890a30
NC
672 is($#+, 2, $message);
673 is($#-, 1, $message);
84281c31 674 }
a72deede 675
88743d87
NC
676 foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)', '@- = qw (foo bar)') {
677 must_die($_, qr/^Modification of a read-only value attempted/,
678 'Elements of @- and @+ are read-only');
84281c31 679 }
a72deede 680
84281c31 681 {
4f890a30 682 my $message = '\G testing';
84281c31
A
683 $_ = 'aaa';
684 pos = 1;
685 my @a = /\Ga/g;
4f890a30 686 is("@a", "a a", $message);
84281c31
A
687
688 my $str = 'abcde';
689 pos $str = 2;
4f890a30
NC
690 unlike($str, qr/^\G/, $message);
691 unlike($str, qr/^.\G/, $message);
692 like($str, qr/^..\G/, $message);
693 unlike($str, qr/^...\G/, $message);
694 ok($str =~ /\G../ && $& eq 'cd', $message);
84281c31 695
04934b6d 696 local $::TODO = $::running_as_thread;
4f890a30 697 ok($str =~ /.\G./ && $& eq 'bc', $message);
84281c31 698 }
a72deede 699
84281c31 700 {
4f890a30 701 my $message = 'pos inside (?{ })';
84281c31
A
702 my $str = 'abcde';
703 our ($foo, $bar);
4f890a30
NC
704 like($str, qr/b(?{$foo = $_; $bar = pos})c/, $message);
705 is($foo, $str, $message);
706 is($bar, 2, $message);
707 is(pos $str, undef, $message);
84281c31
A
708
709 undef $foo;
710 undef $bar;
711 pos $str = undef;
4f890a30
NC
712 ok($str =~ /b(?{$foo = $_; $bar = pos})c/g, $message);
713 is($foo, $str, $message);
714 is($bar, 2, $message);
715 is(pos $str, 3, $message);
84281c31
A
716
717 $_ = $str;
718 undef $foo;
719 undef $bar;
4f890a30
NC
720 like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message);
721 is($foo, $str, $message);
722 is($bar, 2, $message);
84281c31
A
723
724 undef $foo;
725 undef $bar;
4f890a30
NC
726 ok(/b(?{$foo = $_; $bar = pos})c/g, $message);
727 is($foo, $str, $message);
728 is($bar, 2, $message);
729 is(pos, 3, $message);
84281c31
A
730
731 undef $foo;
732 undef $bar;
733 pos = undef;
734 1 while /b(?{$foo = $_; $bar = pos})c/g;
4f890a30
NC
735 is($foo, $str, $message);
736 is($bar, 2, $message);
737 is(pos, undef, $message);
84281c31
A
738
739 undef $foo;
740 undef $bar;
741 $_ = 'abcde|abcde';
4f890a30
NC
742 ok(s/b(?{$foo = $_; $bar = pos})c/x/g, $message);
743 is($foo, 'abcde|abcde', $message);
744 is($bar, 8, $message);
745 is($_, 'axde|axde', $message);
84281c31
A
746
747 # List context:
748 $_ = 'abcde|abcde';
749 our @res;
750 () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
751 @res = map {defined $_ ? "'$_'" : 'undef'} @res;
4f890a30 752 is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message);
84281c31
A
753
754 @res = ();
755 () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
756 @res = map {defined $_ ? "'$_'" : 'undef'} @res;
4f890a30 757 is("@res", "'' 'ab' 'cde|abcde' " .
84281c31
A
758 "'' 'abc' 'de|abcde' " .
759 "'abcd' 'e|' 'abcde' " .
760 "'abcde|' 'ab' 'cde' " .
4f890a30 761 "'abcde|' 'abc' 'de'", $message);
84281c31 762 }
f33976b4 763
84281c31 764 {
4f890a30 765 my $message = '\G anchor checks';
84281c31
A
766 my $foo = 'aabbccddeeffgg';
767 pos ($foo) = 1;
768 {
04934b6d 769 local $::TODO = $::running_as_thread;
84281c31 770 no warnings 'uninitialized';
4f890a30
NC
771 ok($foo =~ /.\G(..)/g, $message);
772 is($1, 'ab', $message);
cce850e4 773
84281c31 774 pos ($foo) += 1;
4f890a30
NC
775 ok($foo =~ /.\G(..)/g, $message);
776 is($1, 'cc', $message);
cce850e4 777
84281c31 778 pos ($foo) += 1;
4f890a30
NC
779 ok($foo =~ /.\G(..)/g, $message);
780 is($1, 'de', $message);
cce850e4 781
4f890a30 782 ok($foo =~ /\Gef/g, $message);
84281c31 783 }
cce850e4 784
84281c31 785 undef pos $foo;
4f890a30
NC
786 ok($foo =~ /\G(..)/g, $message);
787 is($1, 'aa', $message);
cce850e4 788
4f890a30
NC
789 ok($foo =~ /\G(..)/g, $message);
790 is($1, 'bb', $message);
cce850e4 791
84281c31 792 pos ($foo) = 5;
4f890a30
NC
793 ok($foo =~ /\G(..)/g, $message);
794 is($1, 'cd', $message);
84281c31 795 }
cce850e4 796
84281c31
A
797 {
798 $_ = '123x123';
799 my @res = /(\d*|x)/g;
800 local $" = '|';
de26e0cc 801 is("@res", "123||x|123|", "0 match in alternation");
84281c31 802 }
cce850e4 803
84281c31 804 {
4f890a30 805 my $message = "Match against temporaries (created via pp_helem())" .
84281c31 806 " is safe";
4f890a30
NC
807 ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message);
808 is($1, "bar", $message);
84281c31 809 }
75685a94 810
84281c31 811 {
4f890a30 812 my $message = 'package $i inside (?{ }), ' .
84281c31
A
813 'saved substrings and changing $_';
814 our @a = qw [foo bar];
815 our @b = ();
816 s/(\w)(?{push @b, $1})/,$1,/g for @a;
4f890a30
NC
817 is("@b", "f o o b a r", $message);
818 is("@a", ",f,,o,,o, ,b,,a,,r,", $message);
84281c31 819
4f890a30 820 $message = 'lexical $i inside (?{ }), ' .
84281c31
A
821 'saved substrings and changing $_';
822 no warnings 'closure';
823 my @c = qw [foo bar];
824 my @d = ();
825 s/(\w)(?{push @d, $1})/,$1,/g for @c;
4f890a30
NC
826 is("@d", "f o o b a r", $message);
827 is("@c", ",f,,o,,o, ,b,,a,,r,", $message);
d9f424b2
JH
828 }
829
84281c31 830 {
4f890a30 831 my $message = 'Brackets';
84281c31
A
832 our $brackets;
833 $brackets = qr {
834 { (?> [^{}]+ | (??{ $brackets }) )* }
835 }x;
836
4f890a30
NC
837 ok("{{}" =~ $brackets, $message);
838 is($&, "{}", $message);
839 ok("something { long { and } hairy" =~ $brackets, $message);
840 is($&, "{ and }", $message);
841 ok("something { long { and } hairy" =~ m/((??{ $brackets }))/, $message);
842 is($&, "{ and }", $message);
84281c31 843 }
a4c04bdc 844
84281c31
A
845 {
846 $_ = "a-a\nxbb";
847 pos = 1;
b33825c4 848 ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg');
84281c31 849 }
a4c04bdc 850
84281c31 851 {
4f890a30 852 my $message = '\G anchor checks';
84281c31
A
853 my $text = "aaXbXcc";
854 pos ($text) = 0;
4f890a30 855 ok($text !~ /\GXb*X/g, $message);
84281c31 856 }
a4c04bdc 857
84281c31
A
858 {
859 $_ = "xA\n" x 500;
b33825c4 860 unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"');
a4c04bdc 861
84281c31
A
862 my $text = "abc dbf";
863 my @res = ($text =~ /.*?(b).*?\b/g);
de26e0cc 864 is("@res", "b b", '\b is not special');
987aaf07 865 }
a4c04bdc 866
84281c31 867 {
4f890a30 868 my $message = '\S, [\S], \s, [\s]';
84281c31 869 my @a = map chr, 0 .. 255;
9d45b377
YO
870 my @b = grep m/\S/, @a;
871 my @c = grep m/[^\s]/, @a;
4f890a30 872 is("@b", "@c", $message);
84281c31
A
873
874 @b = grep /\S/, @a;
875 @c = grep /[\S]/, @a;
4f890a30 876 is("@b", "@c", $message);
84281c31
A
877
878 @b = grep /\s/, @a;
879 @c = grep /[^\S]/, @a;
4f890a30 880 is("@b", "@c", $message);
84281c31
A
881
882 @b = grep /\s/, @a;
883 @c = grep /[\s]/, @a;
4f890a30 884 is("@b", "@c", $message);
84281c31
A
885 }
886 {
4f890a30 887 my $message = '\D, [\D], \d, [\d]';
84281c31
A
888 my @a = map chr, 0 .. 255;
889 my @b = grep /\D/, @a;
890 my @c = grep /[^\d]/, @a;
4f890a30 891 is("@b", "@c", $message);
84281c31
A
892
893 @b = grep /\D/, @a;
894 @c = grep /[\D]/, @a;
4f890a30 895 is("@b", "@c", $message);
84281c31
A
896
897 @b = grep /\d/, @a;
898 @c = grep /[^\D]/, @a;
4f890a30 899 is("@b", "@c", $message);
84281c31
A
900
901 @b = grep /\d/, @a;
902 @c = grep /[\d]/, @a;
4f890a30 903 is("@b", "@c", $message);
84281c31
A
904 }
905 {
4f890a30 906 my $message = '\W, [\W], \w, [\w]';
84281c31
A
907 my @a = map chr, 0 .. 255;
908 my @b = grep /\W/, @a;
909 my @c = grep /[^\w]/, @a;
4f890a30 910 is("@b", "@c", $message);
84281c31
A
911
912 @b = grep /\W/, @a;
913 @c = grep /[\W]/, @a;
4f890a30 914 is("@b", "@c", $message);
84281c31
A
915
916 @b = grep /\w/, @a;
917 @c = grep /[^\W]/, @a;
4f890a30 918 is("@b", "@c", $message);
84281c31
A
919
920 @b = grep /\w/, @a;
921 @c = grep /[\w]/, @a;
4f890a30 922 is("@b", "@c", $message);
84281c31 923 }
a4c04bdc 924
84281c31
A
925 {
926 # see if backtracking optimization works correctly
4f890a30
NC
927 my $message = 'Backtrack optimization';
928 like("\n\n", qr/\n $ \n/x, $message);
929 like("\n\n", qr/\n* $ \n/x, $message);
930 like("\n\n", qr/\n+ $ \n/x, $message);
931 like("\n\n", qr/\n? $ \n/x, $message);
932 like("\n\n", qr/\n*? $ \n/x, $message);
933 like("\n\n", qr/\n+? $ \n/x, $message);
934 like("\n\n", qr/\n?? $ \n/x, $message);
935 unlike("\n\n", qr/\n*+ $ \n/x, $message);
936 unlike("\n\n", qr/\n++ $ \n/x, $message);
937 like("\n\n", qr/\n?+ $ \n/x, $message);
84281c31 938 }
a4c04bdc 939
84281c31
A
940 {
941 package S;
942 use overload '""' => sub {'Object S'};
943 sub new {bless []}
0f289c68 944
4f890a30 945 my $message = "Ref stringification";
5895685f
NC
946 ::ok(do { \my $v} =~ /^SCALAR/, "Scalar ref stringification") or diag($message);
947 ::ok(do {\\my $v} =~ /^REF/, "Ref ref stringification") or diag($message);
948 ::ok([] =~ /^ARRAY/, "Array ref stringification") or diag($message);
949 ::ok({} =~ /^HASH/, "Hash ref stringification") or diag($message);
950 ::ok('S' -> new =~ /^Object S/, "Object stringification") or diag($message);
84281c31 951 }
a4c04bdc 952
84281c31 953 {
4f890a30
NC
954 my $message = "Test result of match used as match";
955 ok('a1b' =~ ('xyz' =~ /y/), $message);
956 is($`, 'a', $message);
957 ok('a1b' =~ ('xyz' =~ /t/), $message);
958 is($`, 'a', $message);
84281c31 959 }
a4c04bdc 960
84281c31 961 {
d728c370
NC
962 my $message = '"1" is not \s';
963 may_not_warn sub {ok ("1\n" x 102 !~ /^\s*\n/m, $message)}, "$message (did not warn)";
84281c31 964 }
a4c04bdc 965
84281c31 966 {
4f890a30 967 my $message = '\s, [[:space:]] and [[:blank:]]';
84281c31
A
968 my %space = (spc => " ",
969 tab => "\t",
970 cr => "\r",
971 lf => "\n",
972 ff => "\f",
973 # There's no \v but the vertical tabulator seems miraculously
974 # be 11 both in ASCII and EBCDIC.
975 vt => chr(11),
976 false => "space");
977
978 my @space0 = sort grep {$space {$_} =~ /\s/ } keys %space;
979 my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space;
980 my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space;
981
4f890a30
NC
982 is("@space0", "cr ff lf spc tab", $message);
983 is("@space1", "cr ff lf spc tab vt", $message);
984 is("@space2", "spc tab", $message);
84281c31 985 }
a4c04bdc 986
ff3f963a
KW
987 {
988 use charnames ":full";
4f890a30 989 # Delayed interpolation of \N'
ff3f963a
KW
990 my $r1 = qr/\N{THAI CHARACTER SARA I}/;
991 my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}";
992
993 # Bug #56444
994 ok $s1 =~ /$r1+/, 'my $r1 = qr/\N{THAI CHARACTER SARA I}/; my $s1 = "\x{E34}\x{E34}\x{E34}\x{E34}; $s1 =~ /$r1+/';
995
996 # Bug #62056
997 ok "${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/, '"${s1}A" =~ m/$s1\N{LATIN CAPITAL LETTER A}/';
998
999 ok "abbbbc" =~ m/\N{1}/ && $& eq "a", '"abbbbc" =~ m/\N{1}/ && $& eq "a"';
1000 ok "abbbbc" =~ m/\N{3,4}/ && $& eq "abbb", '"abbbbc" =~ m/\N{3,4}/ && $& eq "abbb"';
1001 }
1002
37820adc
KW
1003 {
1004 use charnames ":full";
4f890a30
NC
1005 my $message = '[perl #74982] Period coming after \N{}';
1006 ok("\x{ff08}." =~ m/\N{FULLWIDTH LEFT PARENTHESIS}./ && $& eq "\x{ff08}.", $message);
1007 ok("\x{ff08}." =~ m/[\N{FULLWIDTH LEFT PARENTHESIS}]./ && $& eq "\x{ff08}.", $message);
37820adc 1008 }
c9415951
YO
1009 {
1010 my $n= 50;
93f09d7b 1011 # this must be a high number and go from 0 to N, as the bug we are looking for doesn't
c9415951
YO
1012 # seem to be predictable. Slight changes to the test make it fail earlier or later.
1013 foreach my $i (0 .. $n)
1014 {
1015 my $str= "\n" x $i;
93f09d7b 1016 ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i";
c9415951
YO
1017 }
1018 }
92f3d482
YO
1019 {
1020 # we are actually testing that we dont die when executing these patterns
1021 use utf8;
1022 my $e = "Böck";
1023 ok(utf8::is_utf8($e),"got a unicode string - rt75680");
1024
1025 ok($e !~ m/.*?[x]$/, "unicode string against /.*?[x]\$/ - rt75680");
1026 ok($e !~ m/.*?\p{Space}$/i, "unicode string against /.*?\\p{space}\$/i - rt75680");
1027 ok($e !~ m/.*?[xyz]$/, "unicode string against /.*?[xyz]\$/ - rt75680");
1028 ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/, "unicode string against big pattern - rt75680");
1029 }
1030 {
1031 # we are actually testing that we dont die when executing these patterns
1032 my $e = "B\x{f6}ck";
1033 ok(!utf8::is_utf8($e), "got a latin string - rt75680");
1034
1035 ok($e !~ m/.*?[x]$/, "latin string against /.*?[x]\$/ - rt75680");
1036 ok($e !~ m/.*?\p{Space}$/i, "latin string against /.*?\\p{space}\$/i - rt75680");
1037 ok($e !~ m/.*?[xyz]$/,"latin string against /.*?[xyz]\$/ - rt75680");
1038 ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/,"latin string against big pattern - rt75680");
1039 }
c920e018
A
1040
1041 {
1042 #
1043 # Tests for bug 77414.
1044 #
1045
4f890a30 1046 my $message = '\p property after empty * match';
c920e018 1047 {
04934b6d 1048 local $::TODO = "Bug 77414";
4f890a30
NC
1049 like("1", qr/\s*\pN/, $message);
1050 like("-", qr/\s*\p{Dash}/, $message);
1051 like(" ", qr/\w*\p{Blank}/, $message);
c920e018
A
1052 }
1053
4f890a30
NC
1054 like("1", qr/\s*\pN+/, $message);
1055 like("-", qr/\s*\p{Dash}{1}/, $message);
1056 like(" ", qr/\w*\p{Blank}{1,4}/, $message);
c920e018
A
1057
1058 }
1059
7c17ea2f
KW
1060 SKIP: { # Some constructs with Latin1 characters cause a utf8 string not
1061 # to match itself in non-utf8
1062 if ($IS_EBCDIC) {
1063 skip "Needs to be customized to run on EBCDIC", 6;
1064 }
634c83a2
KW
1065 my $c = "\xc0";
1066 my $pattern = my $utf8_pattern = qr/((\xc0)+,?)/;
1067 utf8::upgrade($utf8_pattern);
1068 ok $c =~ $pattern, "\\xc0 =~ $pattern; Neither pattern nor target utf8";
d4e0b827 1069 ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8";
634c83a2 1070 ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not";
d4e0b827 1071 ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not";
634c83a2
KW
1072 utf8::upgrade($c);
1073 ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not";
d4e0b827 1074 ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not";
634c83a2 1075 ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8";
d4e0b827 1076 ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8";
634c83a2
KW
1077 }
1078
8cc86590
KW
1079 SKIP: { # Make sure can override the formatting
1080 if ($IS_EBCDIC) {
1081 skip "Needs to be customized to run on EBCDIC", 2;
1082 }
1083 use feature 'unicode_strings';
1084 ok "\xc0" =~ /\w/, 'Under unicode_strings: "\xc0" =~ /\w/';
1085 ok "\xc0" !~ /(?d:\w)/, 'Under unicode_strings: "\xc0" !~ /(?d:\w)/';
1086 }
1087
704f71be
B
1088 {
1089 # Test that a regex followed by an operator and/or a statement modifier work
1090 # These tests use string-eval so that it reports a clean error when it fails
1091 # (without the string eval the test script might be unparseable)
1092
1093 # Note: these test check the behaviour that currently is valid syntax
93f09d7b 1094 # If a new regex modifier is added and a test fails then there is a backwards-compatibility issue
704f71be
B
1095 # Note-2: a new deprecate warning was added for this with commit e6897b1a5db0410e387ccbf677e89fc4a1d8c97a
1096 # which indicate that this syntax will be removed in 5.16.
1097 # When this happens the tests can be removed
1098
1099 no warnings 'syntax';
de26e0cc
NC
1100 is(eval q#my $r = "a" =~ m/a/lt 2;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by lt");
1101 is(eval q#my $r = "a" =~ m/a/le 1;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by le");
1102 is(eval q#my $r = "a" =~ m/a/eq 1;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by eq");
1103 is(eval q#my $r = "a" =~ m/a/ne 0;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by ne");
1104 is(eval q#my $r = "a" =~ m/a/and 1;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by and");
1105 is(eval q#my $r = "a" =~ m/a/unless 0;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by unless");
1106 is(eval q#my $c = 1; my $r; $r = "a" =~ m/a/while $c--;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by while");
1107 is(eval q#my $c = 0; my $r; $r = "a" =~ m/a/until $c++;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by until");
1108 is(eval q#my $r; $r = "a" =~ m/a/for 1;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by for");
1109 is(eval q#my $r; $r = "a" =~ m/a/foreach 1;"eval_ok $r"#, "eval_ok 1", "regex (m//) followed by foreach");
1110
1111 is(eval q#my $t = "a"; my $r = $t =~ s/a//lt 2;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by lt");
1112 is(eval q#my $t = "a"; my $r = $t =~ s/a//le 1;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by le");
1113 is(eval q#my $t = "a"; my $r = $t =~ s/a//ne 0;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by ne");
1114 is(eval q#my $t = "a"; my $r = $t =~ s/a//and 1;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by and");
1115 is(eval q#my $t = "a"; my $r = $t =~ s/a//unless 0;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by unless");
1116
1117 is(eval q#my $c = 1; my $r; my $t = "a"; $r = $t =~ s/a//while $c--;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by while");
1118 is(eval q#my $c = 0; my $r; my $t = "a"; $r = $t =~ s/a//until $c++;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by until");
1119 is(eval q#my $r; my $t = "a"; $r = $t =~ s/a//for 1;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by for");
1120 is(eval q#my $r; my $t = "a"; $r = $t =~ s/a//for 1;"eval_ok $r"#, "eval_ok 1", "regex (s///) followed by foreach");
704f71be
B
1121 }
1122
5b6010b3
YO
1123 {
1124 my $str= "\x{100}";
1125 chop $str;
1126 my $qr= qr/$str/;
de26e0cc 1127 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212");
5b6010b3
YO
1128 $str= "";
1129 $qr= qr/$str/;
de26e0cc 1130 is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212");
5b6010b3
YO
1131
1132 }
1133
72aa120d 1134 {
04934b6d 1135 local $::TODO = "[perl #38133]";
72aa120d
KW
1136
1137 "A" =~ /(((?:A))?)+/;
1138 my $first = $2;
1139
1140 "A" =~ /(((A))?)+/;
1141 my $second = $2;
1142
de26e0cc 1143 is($first, $second);
72aa120d
KW
1144 }
1145
99ca48e1
DM
1146 {
1147 # RT #3516: \G in a m//g expression causes problems
1148 my $count = 0;
1149 while ("abc" =~ m/(\G[ac])?/g) {
1150 last if $count++ > 10;
1151 }
1152 ok($count < 10, 'RT #3516 A');
1153
1154 $count = 0;
1155 while ("abc" =~ m/(\G|.)[ac]/g) {
1156 last if $count++ > 10;
1157 }
1158 ok($count < 10, 'RT #3516 B');
1159
1160 $count = 0;
1161 while ("abc" =~ m/(\G?[ac])?/g) {
1162 last if $count++ > 10;
1163 }
1164 ok($count < 10, 'RT #3516 C');
1165 }
84281c31
A
1166} # End of sub run_tests
1167
11681;