04f8b848ae792efd1a52fb148b9dc337a7a32978
[perl.git] / t / re / pat.t
1 #!./perl
2 #
3 # This is a home for regular expression tests that don't fit into
4 # the format supported by re/regexp.t.  If you want to add a test
5 # that does fit that format, add it to re/re_tests, not here.
6
7 use strict;
8 use warnings;
9 use 5.010;
10
11 sub run_tests;
12
13 $| = 1;
14
15
16 BEGIN {
17     chdir 't' if -d 't';
18     @INC = ('../lib','.');
19     require Config; import Config;
20     require './test.pl';
21 }
22
23 plan tests => 721;  # Update this when adding/deleting tests.
24
25 run_tests() unless caller;
26
27 #
28 # Tests start here.
29 #
30 sub run_tests {
31
32     {
33         my $x = "abc\ndef\n";
34         (my $x_pretty = $x) =~ s/\n/\\n/g;
35
36         ok $x =~ /^abc/,  qq ["$x_pretty" =~ /^abc/];
37         ok $x !~ /^def/,  qq ["$x_pretty" !~ /^def/];
38
39         # used to be a test for $*
40         ok $x =~ /^def/m, qq ["$x_pretty" =~ /^def/m];
41
42         ok(!($x =~ /^xxx/), qq ["$x_pretty" =~ /^xxx/]);
43         ok(!($x !~ /^abc/), qq ["$x_pretty" !~ /^abc/]);
44
45          ok $x =~ /def/, qq ["$x_pretty" =~ /def/];
46         ok(!($x !~ /def/), qq ["$x_pretty" !~ /def/]);
47
48          ok $x !~ /.def/, qq ["$x_pretty" !~ /.def/];
49         ok(!($x =~ /.def/), qq ["$x_pretty" =~ /.def/]);
50
51          ok $x =~ /\ndef/, qq ["$x_pretty" =~ /\\ndef/];
52         ok(!($x !~ /\ndef/), qq ["$x_pretty" !~ /\\ndef/]);
53     }
54
55     {
56         $_ = '123';
57         ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/];
58     }
59
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+)/];
65         unlike($_, qr/a+b?c+/, qq [\$_ = '$_'; /a+b?c+/]);
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*/];
73         unlike($_, qr/a*b+c*/, qq [\$_ = '$_'; /a*b+c*/]);
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 [\$_ = '$_'; /^\$_\$/];
80     }
81
82     {
83         # used to be a test for $*
84         ok "ab\ncd\n" =~ /^cd/m, q ["ab\ncd\n" =~ /^cd/m];
85     }
86
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)) {
92             my $e = index ($_, 'not') >= 0 ? '' : 1;
93             my $r = m?(.*)?;
94             is($r, $e, "?(.*)?");
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         }
105
106         SKIP: {
107             if ($^O eq 'VMS') {
108                 skip "Reset 'X'", 1;
109             }
110             ok !keys %XXX, "%XXX is empty";
111         }
112
113     }
114
115     {
116         my $message = "Test empty pattern";
117         my $xyz = 'xyz';
118         my $cde = 'cde';
119
120         $cde =~ /[^ab]*/;
121         $xyz =~ //;
122         is($&, $xyz, $message);
123
124         my $foo = '[^ab]*';
125         $cde =~ /$foo/;
126         $xyz =~ //;
127         is($&, $xyz, $message);
128
129         $cde =~ /$foo/;
130         my $null;
131         no warnings 'uninitialized';
132         $xyz =~ /$null/;
133         is($&, $xyz, $message);
134
135         $null = "";
136         $xyz =~ /$null/;
137         is($&, $xyz, $message);
138     }
139
140     {
141         my $message = q !Check $`, $&, $'!;
142         $_ = 'abcdefghi';
143         /def/;        # optimized up to cmd
144         is("$`:$&:$'", 'abc:def:ghi', $message);
145
146         no warnings 'void';
147         /cde/ + 0;    # optimized only to spat
148         is("$`:$&:$'", 'ab:cde:fghi', $message);
149
150         /[d][e][f]/;    # not optimized
151         is("$`:$&:$'", 'abc:def:ghi', $message);
152     }
153
154     {
155         $_ = 'now is the {time for all} good men to come to.';
156         / \{([^}]*)}/;
157         is($1, 'time for all', "Match braces");
158     }
159
160     {
161         my $message = "{N,M} quantifier";
162         $_ = 'xxx {3,4}  yyy   zzz';
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);
172     }
173
174     {
175         my $message = "Test /g";
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";
180
181         is("@words", $exp, $message);
182
183         @words = ();
184         while (/\w+/g) {
185             push (@words, $&);
186         }
187         is("@words", $exp, $message);
188
189         @words = ();
190         pos = 0;
191         while (/to/g) {
192             push(@words, $&);
193         }
194         is("@words", "to:to", $message);
195
196         pos $_ = 0;
197         @words = /to/g;
198         is("@words", "to:to", $message);
199     }
200
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";
229         is($x, '505550555', "Test /o");
230     }
231
232     {
233         my $xyz = 'xyz';
234         ok "abc" =~ /^abc$|$xyz/, "| after \$";
235
236         # perl 4.009 says "unmatched ()"
237         my $message = '$ inside ()';
238
239         my $result;
240         eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
241         is($@, "", $message);
242         is($result, "abc:bc", $message);
243     }
244
245     {
246         my $message = "Scalar /g";
247         $_ = "abcfooabcbar";
248
249         ok( /abc/g && $` eq "", $message);
250         ok( /abc/g && $` eq "abcfoo", $message);
251         ok(!/abc/g, $message);
252
253         $message = "Scalar /gi";
254         pos = 0;
255         ok( /ABC/gi && $` eq "", $message);
256         ok( /ABC/gi && $` eq "abcfoo", $message);
257         ok(!/ABC/gi, $message);
258
259         $message = "Scalar /g";
260         pos = 0;
261         ok( /abc/g && $' eq "fooabcbar", $message);
262         ok( /abc/g && $' eq "bar", $message);
263
264         $_ .= '';
265         my @x = /abc/g;
266         is(@x, 2, "/g reset after assignment");
267     }
268
269     {
270         my $message = '/g, \G and pos';
271         $_ = "abdc";
272         pos $_ = 2;
273         /\Gc/gc;
274         is(pos $_, 2, $message);
275         /\Gc/g;
276         is(pos $_, undef, $message);
277     }
278
279     {
280         my $message = '(?{ })';
281         our $out = 1;
282         'abc' =~ m'a(?{ $out = 2 })b';
283         is($out, 2, $message);
284
285         $out = 1;
286         'abc' =~ m'a(?{ $out = 3 })c';
287         is($out, 1, $message);
288     }
289
290     {
291         $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
292         my @out = /(?<!foo)bar./g;
293         is("@out", 'bar2 barf', "Negative lookbehind");
294     }
295
296     {
297         my $message = "REG_INFTY tests";
298         # Tests which depend on REG_INFTY
299
300         #  Defaults assumed if this fails
301         eval { require Config; };
302         $::reg_infty   = $Config::Config{reg_infty} // 32767;
303         $::reg_infty_m = $::reg_infty - 1;
304         $::reg_infty_p = $::reg_infty + 1;
305         $::reg_infty_m = $::reg_infty_m;   # Suppress warning.
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
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
318         eval "'aaa' =~ /a{1,$::reg_infty}/";
319         like($@, qr/^\QQuantifier in {,} bigger than/, $message);
320         eval "'aaa' =~ /a{1,$::reg_infty_p}/";
321         like($@, qr/^\QQuantifier in {,} bigger than/, $message);
322     }
323
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     }
330
331     {
332         # Long Monsters
333         for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
334             my $a = 'a' x $l;
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);
339
340             like("ba$a=", qr/b(?:a|b)+=/, $message);
341         }
342     }
343
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,
352                     'ax13876y25677y21378zbc' => 0,    # Not followed by [k-o]
353                     'ax13876y25677y21378y21378kbc' => 1,
354                     'ax13876y25677y21378y21378kcb' => 0, # Not b.
355                     'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
356                   );
357
358         for (keys %ans) {
359             my $message = "20000 nodes, const-len '$_'";
360             ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o), $message;
361
362             $message = "20000 nodes, var-len '$_'";
363             ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o,), $message;
364         }
365     }
366
367     {
368         my $message = "Complicated backtracking";
369         $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
370         my $expect = "(bla()) ((l)u((e))) (l(e)e)";
371
372         use vars '$c';
373         sub matchit {
374           m/
375              (
376                \(
377                (?{ $c = 1 })    # Initialize
378                (?:
379                  (?(?{ $c == 0 })   # PREVIOUS iteration was OK, stop the loop
380                    (?!
381                    )        # Fail: will unwind one iteration back
382                  )
383                  (?:
384                    [^()]+        # Match a big chunk
385                    (?=
386                      [()]
387                    )        # Do not try to match subchunks
388                  |
389                    \(
390                    (?{ ++$c })
391                  |
392                    \)
393                    (?{ --$c })
394                  )
395                )+        # This may not match with different subblocks
396              )
397              (?(?{ $c != 0 })
398                (?!
399                )        # Fail
400              )            # Otherwise the chunk 1 may succeed with $c>0
401            /xg;
402         }
403
404         my @ans = ();
405         my $res;
406         push @ans, $res while $res = matchit;
407         is("@ans", "1 1 1", $message);
408
409         @ans = matchit;
410         is("@ans", $expect, $message);
411
412         $message = "Recursion with (??{ })";
413         our $matched;
414         $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/;
415
416         @ans = my @ans1 = ();
417         push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g;
418
419         is("@ans", "1 1 1", $message);
420         is("@ans1", $expect, $message);
421
422         @ans = m/$matched/g;
423         is("@ans", $expect, $message);
424
425     }
426
427     {
428         ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/';
429     }
430
431     {
432         my @ans = ('a/b' =~ m%(.*/)?(.*)%);    # Stack may be bad
433         is("@ans", 'a/ b', "Stack may be bad");
434     }
435
436     {
437         my $message = "Eval-group not allowed at runtime";
438         my $code = '{$blah = 45}';
439         our $blah = 12;
440         eval { /(?$code)/ };
441         ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message);
442
443         $blah = 12;
444         my $res = eval { "xx" =~ /(?$code)/o };
445         {
446             no warnings 'uninitialized';
447             chomp $@; my $message = "$message '$@', '$res', '$blah'";
448             ok($@ && $@ =~ /not allowed at runtime/ && $blah == 12, $message);
449         }
450
451         $code = '=xx';
452         $blah = 12;
453         $res = eval { "xx" =~ /(?$code)/o };
454         {
455             no warnings 'uninitialized';
456             my $message = "$message '$@', '$res', '$blah'";
457             ok(!$@ && $res, $message);
458         }
459
460         $code = '{$blah = 45}';
461         $blah = 12;
462         eval "/(?$code)/";
463         is($blah, 45, $message);
464
465         $blah = 12;
466         /(?{$blah = 45})/;
467         is($blah, 45, $message);
468     }
469
470     {
471         my $message = "Pos checks";
472         my $x = 'banana';
473         $x =~ /.a/g;
474         is(pos $x, 2, $message);
475
476         $x =~ /.z/gc;
477         is(pos $x, 2, $message);
478
479         sub f {
480             my $p = $_[0];
481             return $p;
482         }
483
484         $x =~ /.a/g;
485         is(f (pos $x), 4, $message);
486     }
487
488     {
489         my $message = 'Checking $^R';
490         our $x = $^R = 67;
491         'foot' =~ /foo(?{$x = 12; 75})[t]/;
492         is($^R, 75, $message);
493
494         $x = $^R = 67;
495         'foot' =~ /foo(?{$x = 12; 75})[xy]/;
496         ok($^R eq '67' && $x eq '12', $message);
497
498         $x = $^R = 67;
499         'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
500         ok($^R eq '79' && $x eq '12', $message);
501     }
502
503     {
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$/');
510     }
511
512     {   # Test that charset modifier work, and are interpolated
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');
518
519         my $dual = qr/\b\v$/;
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         }
534
535         use feature 'unicode_strings';
536         my $unicode = qr/\b\v$/;
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');
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         }
545
546         no feature 'unicode_strings';
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
553         is(qr/def$unicode/,    '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings');
554
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         }
566     }
567
568     {
569         my $message = "Look around";
570         $_ = 'xabcx';
571         foreach my $ans ('', 'c') {
572             ok(/(?<=(?=a)..)((?=c)|.)/g, $message);
573             is($1, $ans, $message);
574         }
575     }
576
577     {
578         my $message = "Empty clause";
579         $_ = 'a';
580         foreach my $ans ('', 'a', '') {
581             ok(/^|a|$/g, $message);
582             is($&, $ans, $message);
583         }
584     }
585
586     {
587         sub prefixify {
588         my $message = "Prefixify";
589             {
590                 my ($v, $a, $b, $res) = @_;
591                 ok($v =~ s/\Q$a\E/$b/, $message);
592                 is($v, $res, $message);
593             }
594         }
595
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     }
599
600     {
601         $_ = 'var="foo"';
602         /(\")/;
603         ok $1 && /$1/, "Capture a quote";
604     }
605
606     {
607         no warnings 'closure';
608         my $message = '(?{ $var } refers to package vars';
609         package aa;
610         our $c = 2;
611         $::c = 3;
612         '' =~ /(?{ $c = 4 })/;
613         main::is($c, 4, $message);
614         main::is($::c, 3, $message);
615     }
616
617     {
618         is(eval 'q(a:[b]:) =~ /[x[:foo:]]/', undef);
619         like ($@, qr/POSIX class \[:[^:]+:\] unknown in regex/,
620               'POSIX class [: :] must have valid name');
621
622         for my $d (qw [= .]) {
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");
626         }
627     }
628
629     {
630         # test if failure of patterns returns empty list
631         my $message = "Failed pattern returns empty list";
632         $_ = 'aaa';
633         @_ = /bbb/;
634         is("@_", "", $message);
635
636         @_ = /bbb/g;
637         is("@_", "", $message);
638
639         @_ = /(bbb)/;
640         is("@_", "", $message);
641
642         @_ = /(bbb)/g;
643         is("@_", "", $message);
644     }
645
646     {
647         my $message = '@- and @+ tests';
648
649         /a(?=.$)/;
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);
656
657         /a(a)(a)/;
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);
668
669         # Exists has a special check for @-/@+ - bug 45147
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);
682
683         /.(a)(b)?(a)/;
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);
692
693         /.(a)/;
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);
702
703         /.(a)(ba*)?/;
704         is($#+, 2, $message);
705         is($#-, 1, $message);
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';
714     }
715
716     foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)',
717              '@- = qw (foo bar)', '$^N = 42') {
718         is(eval $_, undef);
719         like($@, qr/^Modification of a read-only value attempted/,
720              '$^N, @- and @+ are read-only');
721     }
722
723     {
724         my $message = '\G testing';
725         $_ = 'aaa';
726         pos = 1;
727         my @a = /\Ga/g;
728         is("@a", "a a", $message);
729
730         my $str = 'abcde';
731         pos $str = 2;
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);
737         ok($str =~ /.\G./ && $& eq 'bc', $message);
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);
758         pos = 3;
759         ok($_ =~ /..\GX?def/, $message);
760     }
761
762     {
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     {
771         my $message = 'pos inside (?{ })';
772         my $str = 'abcde';
773         our ($foo, $bar);
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);
778
779         undef $foo;
780         undef $bar;
781         pos $str = undef;
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);
786
787         $_ = $str;
788         undef $foo;
789         undef $bar;
790         like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message);
791         is($foo, $str, $message);
792         is($bar, 2, $message);
793
794         undef $foo;
795         undef $bar;
796         ok(/b(?{$foo = $_; $bar = pos})c/g, $message);
797         is($foo, $str, $message);
798         is($bar, 2, $message);
799         is(pos, 3, $message);
800
801         undef $foo;
802         undef $bar;
803         pos = undef;
804         1 while /b(?{$foo = $_; $bar = pos})c/g;
805         is($foo, $str, $message);
806         is($bar, 2, $message);
807         is(pos, undef, $message);
808
809         undef $foo;
810         undef $bar;
811         $_ = 'abcde|abcde';
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);
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;
822         is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message);
823
824         @res = ();
825         () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
826         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
827         is("@res", "'' 'ab' 'cde|abcde' " .
828                      "'' 'abc' 'de|abcde' " .
829                      "'abcd' 'e|' 'abcde' " .
830                      "'abcde|' 'ab' 'cde' " .
831                      "'abcde|' 'abc' 'de'", $message);
832     }
833
834     {
835         my $message = '\G anchor checks';
836         my $foo = 'aabbccddeeffgg';
837         pos ($foo) = 1;
838
839         ok($foo =~ /.\G(..)/g, $message);
840         is($1, 'ab', $message);
841
842         pos ($foo) += 1;
843         ok($foo =~ /.\G(..)/g, $message);
844         is($1, 'cc', $message);
845
846         pos ($foo) += 1;
847         ok($foo =~ /.\G(..)/g, $message);
848         is($1, 'de', $message);
849
850         ok($foo =~ /\Gef/g, $message);
851
852         undef pos $foo;
853         ok($foo =~ /\G(..)/g, $message);
854         is($1, 'aa', $message);
855
856         ok($foo =~ /\G(..)/g, $message);
857         is($1, 'bb', $message);
858
859         pos ($foo) = 5;
860         ok($foo =~ /\G(..)/g, $message);
861         is($1, 'cd', $message);
862     }
863
864     {
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     {
895         $_ = '123x123';
896         my @res = /(\d*|x)/g;
897         local $" = '|';
898         is("@res", "123||x|123|", "0 match in alternation");
899     }
900
901     {
902         my $message = "Match against temporaries (created via pp_helem())" .
903                          " is safe";
904         ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message);
905         is($1, "bar", $message);
906     }
907
908     {
909         my $message = 'package $i inside (?{ }), ' .
910                          'saved substrings and changing $_';
911         our @a = qw [foo bar];
912         our @b = ();
913         s/(\w)(?{push @b, $1})/,$1,/g for @a;
914         is("@b", "f o o b a r", $message);
915         is("@a", ",f,,o,,o, ,b,,a,,r,", $message);
916
917         $message = 'lexical $i inside (?{ }), ' .
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;
923         is("@d", "f o o b a r", $message);
924         is("@c", ",f,,o,,o, ,b,,a,,r,", $message);
925     }
926
927     {
928         my $message = 'Brackets';
929         our $brackets;
930         $brackets = qr {
931             {  (?> [^{}]+ | (??{ $brackets }) )* }
932         }x;
933
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);
940     }
941
942     {
943         $_ = "a-a\nxbb";
944         pos = 1;
945         ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg');
946     }
947
948     {
949         my $message = '\G anchor checks';
950         my $text = "aaXbXcc";
951         pos ($text) = 0;
952         ok($text !~ /\GXb*X/g, $message);
953     }
954
955     {
956         $_ = "xA\n" x 500;
957         unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"');
958
959         my $text = "abc dbf";
960         my @res = ($text =~ /.*?(b).*?\b/g);
961         is("@res", "b b", '\b is not special');
962     }
963
964     {
965         my $message = '\S, [\S], \s, [\s]';
966         my @a = map chr, 0 .. 255;
967         my @b = grep m/\S/, @a;
968         my @c = grep m/[^\s]/, @a;
969         is("@b", "@c", $message);
970
971         @b = grep /\S/, @a;
972         @c = grep /[\S]/, @a;
973         is("@b", "@c", $message);
974
975         @b = grep /\s/, @a;
976         @c = grep /[^\S]/, @a;
977         is("@b", "@c", $message);
978
979         @b = grep /\s/, @a;
980         @c = grep /[\s]/, @a;
981         is("@b", "@c", $message);
982     }
983     {
984         my $message = '\D, [\D], \d, [\d]';
985         my @a = map chr, 0 .. 255;
986         my @b = grep /\D/, @a;
987         my @c = grep /[^\d]/, @a;
988         is("@b", "@c", $message);
989
990         @b = grep /\D/, @a;
991         @c = grep /[\D]/, @a;
992         is("@b", "@c", $message);
993
994         @b = grep /\d/, @a;
995         @c = grep /[^\D]/, @a;
996         is("@b", "@c", $message);
997
998         @b = grep /\d/, @a;
999         @c = grep /[\d]/, @a;
1000         is("@b", "@c", $message);
1001     }
1002     {
1003         my $message = '\W, [\W], \w, [\w]';
1004         my @a = map chr, 0 .. 255;
1005         my @b = grep /\W/, @a;
1006         my @c = grep /[^\w]/, @a;
1007         is("@b", "@c", $message);
1008
1009         @b = grep /\W/, @a;
1010         @c = grep /[\W]/, @a;
1011         is("@b", "@c", $message);
1012
1013         @b = grep /\w/, @a;
1014         @c = grep /[^\W]/, @a;
1015         is("@b", "@c", $message);
1016
1017         @b = grep /\w/, @a;
1018         @c = grep /[\w]/, @a;
1019         is("@b", "@c", $message);
1020     }
1021
1022     {
1023         # see if backtracking optimization works correctly
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);
1035     }
1036
1037     {
1038         package S;
1039         use overload '""' => sub {'Object S'};
1040         sub new {bless []}
1041
1042         my $message  = "Ref stringification";
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);
1048     }
1049
1050     {
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);
1056     }
1057
1058     {
1059         my $message = '"1" is not \s';
1060         warning_is(sub {unlike("1\n" x 102, qr/^\s*\n/m, $message)},
1061                    undef, "$message (did not warn)");
1062     }
1063
1064     {
1065         my $message = '\s, [[:space:]] and [[:blank:]]';
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
1080         is("@space0", "cr ff lf spc tab vt", $message);
1081         is("@space1", "cr ff lf spc tab vt", $message);
1082         is("@space2", "spc tab", $message);
1083     }
1084
1085     {
1086         my $n= 50;
1087         # this must be a high number and go from 0 to N, as the bug we are looking for doesn't
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;
1092             ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i";
1093         }
1094     }
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     }
1116
1117     {
1118         #
1119         # Tests for bug 77414.
1120         #
1121
1122         my $message = '\p property after empty * match';
1123         {
1124             like("1", qr/\s*\pN/, $message);
1125             like("-", qr/\s*\p{Dash}/, $message);
1126             like(" ", qr/\w*\p{Blank}/, $message);
1127         }
1128
1129         like("1", qr/\s*\pN+/, $message);
1130         like("-", qr/\s*\p{Dash}{1}/, $message);
1131         like(" ", qr/\w*\p{Blank}{1,4}/, $message);
1132
1133     }
1134
1135     SKIP: {   # Some constructs with Latin1 characters cause a utf8 string not
1136               # to match itself in non-utf8
1137         if ($::IS_EBCDIC) {
1138             skip "Needs to be customized to run on EBCDIC", 6;
1139         }
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";
1144         ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8";
1145         ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not";
1146         ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not";
1147         utf8::upgrade($c);
1148         ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not";
1149         ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not";
1150         ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8";
1151         ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8";
1152     }
1153
1154     SKIP: {   # Make sure can override the formatting
1155         if ($::IS_EBCDIC) {
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
1163     {
1164         my $str= "\x{100}";
1165         chop $str;
1166         my $qr= qr/$str/;
1167         is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212");
1168         $str= "";
1169         $qr= qr/$str/;
1170         is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212");
1171
1172     }
1173
1174     {
1175         local $::TODO = "[perl #38133]";
1176
1177         "A" =~ /(((?:A))?)+/;
1178         my $first = $2;
1179
1180         "A" =~ /(((A))?)+/;
1181         my $second = $2;
1182
1183         is($first, $second);
1184     }
1185
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     }
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");
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
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
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}");
1226     }
1227
1228     {
1229         # Test that IDstart works, but because the author (khw) knows
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);
1251             fresh_perl_like($prog, qr!Group name must start with a non-digit word character!, {},
1252                         sprintf("'U+%04X not legal IDFirst'", ord($char)));
1253         }
1254     }
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
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
1269     { # Concat overloading and qr// thingies
1270         my @refs;
1271         my $qr = qr//;
1272         package Cat {
1273             require overload;
1274             overload->import(
1275                 '""' => sub { ${$_[0]} },
1276                 '.' => sub {
1277                     push @refs, ref $_[1] if ref $_[1];
1278                     bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]"
1279                 }
1280             );
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
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     }
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     }
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
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
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
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
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
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
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     }
1426
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
1430         # Note that this test causes the engine to recurse at runtime, and
1431         # hence use a lot of C stack.
1432         for my $i (1..100) {
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             }
1445         }
1446     }
1447
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
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
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
1482     {
1483         is runperl(prog => 'delete $::{qq-\cR-}; //; print qq-ok\n-'),
1484            "ok\n",
1485            'deleting *^R does not result in crashes';
1486         no warnings 'once';
1487         *^R = *caretRglobwithnoscalar;
1488         "" =~ /(?{42})/;
1489         is $^R, 42, 'assigning to *^R does not result in a crash';
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';
1499     }
1500
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
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");
1530
1531         $s=~ /ab.{1,2}x/;
1532         pass("RT#120692 ab.{1,2} mustn't run slowly");
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
1539         $s = "-ab\n" x 250_000;
1540         $s .= "abx";
1541         ok($s =~ /^ab.*x/m, "distant float with /m");
1542
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
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
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
1556     }
1557
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     )) {
1569       SKIP: {
1570         skip "no re-debug under miniperl" if is_miniperl;
1571         my $prog = <<"EOP";
1572 use re qw(Debug COMPILE);
1573 $re;
1574 EOP
1575         fresh_perl_like($prog, qr/synthetic stclass/, { stderr=>1 }, "$re generates a synthetic start class");
1576       }
1577     }
1578
1579     {
1580         like "\x{AA}", qr/a?[\W_]/d, "\\W with /d synthetic start class works";
1581     }
1582
1583
1584
1585 } # End of sub run_tests
1586
1587 1;