770a45a1253c5bc27a7203b865b7127147ed6946
[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','.','../ext/re');
19     require Config; import Config;
20     require './test.pl';
21 }
22
23 plan tests => 738;  # 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             use locale;
526             $locale = qr/\b\v$/;
527             is($locale,    '(?^l:\b\v$)', 'Verify has l modifier when compiled under use locale');
528             no locale;
529         }
530
531         use feature 'unicode_strings';
532         my $unicode = qr/\b\v$/;
533         is($unicode,    '(?^u:\b\v$)', 'Verify has u modifier when compiled under unicode_strings');
534         is(qr/abc$dual/,    '(?^u:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale');
535
536       SKIP: {
537             skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale});
538
539             is(qr/abc$locale/,    '(?^u:abc(?^l:\b\v$))', 'Verify retains l when interpolated under unicode_strings');
540         }
541
542         no feature 'unicode_strings';
543       SKIP: {
544             skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale});
545
546             is(qr/abc$locale/,    '(?^:abc(?^l:\b\v$))', 'Verify retains l when interpolated outside locale and unicode strings');
547         }
548
549         is(qr/def$unicode/,    '(?^:def(?^u:\b\v$))', 'Verify retains u when interpolated outside locale and unicode strings');
550
551       SKIP: {
552             skip 'No locale testing without d_setlocale', 2 if(!$Config{d_setlocale});
553
554              use locale;
555             is(qr/abc$dual/,    '(?^l:abc(?^:\b\v$))', 'Verify retains d meaning when interpolated under locale');
556             is(qr/abc$unicode/,    '(?^l:abc(?^u:\b\v$))', 'Verify retains u when interpolated under locale');
557         }
558     }
559
560     {
561         my $message = "Look around";
562         $_ = 'xabcx';
563         foreach my $ans ('', 'c') {
564             ok(/(?<=(?=a)..)((?=c)|.)/g, $message);
565             is($1, $ans, $message);
566         }
567     }
568
569     {
570         my $message = "Empty clause";
571         $_ = 'a';
572         foreach my $ans ('', 'a', '') {
573             ok(/^|a|$/g, $message);
574             is($&, $ans, $message);
575         }
576     }
577
578     {
579         sub prefixify {
580         my $message = "Prefixify";
581             {
582                 my ($v, $a, $b, $res) = @_;
583                 ok($v =~ s/\Q$a\E/$b/, $message);
584                 is($v, $res, $message);
585             }
586         }
587
588         prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch');
589         prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch');
590     }
591
592     {
593         $_ = 'var="foo"';
594         /(\")/;
595         ok $1 && /$1/, "Capture a quote";
596     }
597
598     {
599         no warnings 'closure';
600         my $message = '(?{ $var } refers to package vars';
601         package aa;
602         our $c = 2;
603         $::c = 3;
604         '' =~ /(?{ $c = 4 })/;
605         main::is($c, 4, $message);
606         main::is($::c, 3, $message);
607     }
608
609     {
610         is(eval 'q(a:[b]:) =~ /[x[:foo:]]/', undef);
611         like ($@, qr/POSIX class \[:[^:]+:\] unknown in regex/,
612               'POSIX class [: :] must have valid name');
613
614         for my $d (qw [= .]) {
615             is(eval "/[[${d}foo${d}]]/", undef);
616             like ($@, qr/\QPOSIX syntax [$d $d] is reserved for future extensions/,
617                   "POSIX syntax [[$d $d]] is an error");
618         }
619     }
620
621     {
622         # test if failure of patterns returns empty list
623         my $message = "Failed pattern returns empty list";
624         $_ = 'aaa';
625         @_ = /bbb/;
626         is("@_", "", $message);
627
628         @_ = /bbb/g;
629         is("@_", "", $message);
630
631         @_ = /(bbb)/;
632         is("@_", "", $message);
633
634         @_ = /(bbb)/g;
635         is("@_", "", $message);
636     }
637
638     {
639         my $message = '@- and @+ tests';
640
641         /a(?=.$)/;
642         is($#+, 0, $message);
643         is($#-, 0, $message);
644         is($+ [0], 2, $message);
645         is($- [0], 1, $message);
646         ok(!defined $+ [1] && !defined $- [1] &&
647            !defined $+ [2] && !defined $- [2], $message);
648
649         /a(a)(a)/;
650         is($#+, 2, $message);
651         is($#-, 2, $message);
652         is($+ [0], 3, $message);
653         is($- [0], 0, $message);
654         is($+ [1], 2, $message);
655         is($- [1], 1, $message);
656         is($+ [2], 3, $message);
657         is($- [2], 2, $message);
658         ok(!defined $+ [3] && !defined $- [3] &&
659            !defined $+ [4] && !defined $- [4], $message);
660
661         # Exists has a special check for @-/@+ - bug 45147
662         ok(exists $-[0], $message);
663         ok(exists $+[0], $message);
664         ok(exists $-[2], $message);
665         ok(exists $+[2], $message);
666         ok(!exists $-[3], $message);
667         ok(!exists $+[3], $message);
668         ok(exists $-[-1], $message);
669         ok(exists $+[-1], $message);
670         ok(exists $-[-3], $message);
671         ok(exists $+[-3], $message);
672         ok(!exists $-[-4], $message);
673         ok(!exists $+[-4], $message);
674
675         /.(a)(b)?(a)/;
676         is($#+, 3, $message);
677         is($#-, 3, $message);
678         is($+ [1], 2, $message);
679         is($- [1], 1, $message);
680         is($+ [3], 3, $message);
681         is($- [3], 2, $message);
682         ok(!defined $+ [2] && !defined $- [2] &&
683            !defined $+ [4] && !defined $- [4], $message);
684
685         /.(a)/;
686         is($#+, 1, $message);
687         is($#-, 1, $message);
688         is($+ [0], 2, $message);
689         is($- [0], 0, $message);
690         is($+ [1], 2, $message);
691         is($- [1], 1, $message);
692         ok(!defined $+ [2] && !defined $- [2] &&
693            !defined $+ [3] && !defined $- [3], $message);
694
695         /.(a)(ba*)?/;
696         is($#+, 2, $message);
697         is($#-, 1, $message);
698
699         # Check that values don’t stick
700         "     "=~/()()()(.)(..)/;
701         my($m,$p) = (\$-[5], \$+[5]);
702         () = "$$_" for $m, $p; # FETCH (or eqv.)
703         " " =~ /()/;
704         is $$m, undef, 'values do not stick to @- elements';
705         is $$p, undef, 'values do not stick to @+ elements';
706     }
707
708     foreach ('$+[0] = 13', '$-[0] = 13', '@+ = (7, 6, 5)',
709              '@- = qw (foo bar)', '$^N = 42') {
710         is(eval $_, undef);
711         like($@, qr/^Modification of a read-only value attempted/,
712              '$^N, @- and @+ are read-only');
713     }
714
715     {
716         my $message = '\G testing';
717         $_ = 'aaa';
718         pos = 1;
719         my @a = /\Ga/g;
720         is("@a", "a a", $message);
721
722         my $str = 'abcde';
723         pos $str = 2;
724         unlike($str, qr/^\G/, $message);
725         unlike($str, qr/^.\G/, $message);
726         like($str, qr/^..\G/, $message);
727         unlike($str, qr/^...\G/, $message);
728         ok($str =~ /\G../ && $& eq 'cd', $message);
729         ok($str =~ /.\G./ && $& eq 'bc', $message);
730
731     }
732
733     {
734         my $message = '\G and intuit and anchoring';
735         $_ = "abcdef";
736         pos = 0;
737         ok($_ =~ /\Gabc/, $message);
738         ok($_ =~ /^\Gabc/, $message);
739
740         pos = 3;
741         ok($_ =~ /\Gdef/, $message);
742         pos = 3;
743         ok($_ =~ /\Gdef$/, $message);
744         pos = 3;
745         ok($_ =~ /abc\Gdef$/, $message);
746         pos = 3;
747         ok($_ =~ /^abc\Gdef$/, $message);
748         pos = 3;
749         ok($_ =~ /c\Gd/, $message);
750         pos = 3;
751         ok($_ =~ /..\GX?def/, $message);
752     }
753
754     {
755         my $s = '123';
756         pos($s) = 1;
757         my @a = $s =~ /(\d)\G/g; # this infinitely looped up till 5.19.1
758         is("@a", "1", '\G looping');
759     }
760
761
762     {
763         my $message = 'pos inside (?{ })';
764         my $str = 'abcde';
765         our ($foo, $bar);
766         like($str, qr/b(?{$foo = $_; $bar = pos})c/, $message);
767         is($foo, $str, $message);
768         is($bar, 2, $message);
769         is(pos $str, undef, $message);
770
771         undef $foo;
772         undef $bar;
773         pos $str = undef;
774         ok($str =~ /b(?{$foo = $_; $bar = pos})c/g, $message);
775         is($foo, $str, $message);
776         is($bar, 2, $message);
777         is(pos $str, 3, $message);
778
779         $_ = $str;
780         undef $foo;
781         undef $bar;
782         like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message);
783         is($foo, $str, $message);
784         is($bar, 2, $message);
785
786         undef $foo;
787         undef $bar;
788         ok(/b(?{$foo = $_; $bar = pos})c/g, $message);
789         is($foo, $str, $message);
790         is($bar, 2, $message);
791         is(pos, 3, $message);
792
793         undef $foo;
794         undef $bar;
795         pos = undef;
796         1 while /b(?{$foo = $_; $bar = pos})c/g;
797         is($foo, $str, $message);
798         is($bar, 2, $message);
799         is(pos, undef, $message);
800
801         undef $foo;
802         undef $bar;
803         $_ = 'abcde|abcde';
804         ok(s/b(?{$foo = $_; $bar = pos})c/x/g, $message);
805         is($foo, 'abcde|abcde', $message);
806         is($bar, 8, $message);
807         is($_, 'axde|axde', $message);
808
809         # List context:
810         $_ = 'abcde|abcde';
811         our @res;
812         () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
813         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
814         is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message);
815
816         @res = ();
817         () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
818         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
819         is("@res", "'' 'ab' 'cde|abcde' " .
820                      "'' 'abc' 'de|abcde' " .
821                      "'abcd' 'e|' 'abcde' " .
822                      "'abcde|' 'ab' 'cde' " .
823                      "'abcde|' 'abc' 'de'", $message);
824     }
825
826     {
827         my $message = '\G anchor checks';
828         my $foo = 'aabbccddeeffgg';
829         pos ($foo) = 1;
830
831         ok($foo =~ /.\G(..)/g, $message);
832         is($1, 'ab', $message);
833
834         pos ($foo) += 1;
835         ok($foo =~ /.\G(..)/g, $message);
836         is($1, 'cc', $message);
837
838         pos ($foo) += 1;
839         ok($foo =~ /.\G(..)/g, $message);
840         is($1, 'de', $message);
841
842         ok($foo =~ /\Gef/g, $message);
843
844         undef pos $foo;
845         ok($foo =~ /\G(..)/g, $message);
846         is($1, 'aa', $message);
847
848         ok($foo =~ /\G(..)/g, $message);
849         is($1, 'bb', $message);
850
851         pos ($foo) = 5;
852         ok($foo =~ /\G(..)/g, $message);
853         is($1, 'cd', $message);
854     }
855
856     {
857         my $message = 'basic \G floating checks';
858         my $foo = 'aabbccddeeffgg';
859         pos ($foo) = 1;
860
861         ok($foo =~ /a+\G(..)/g, "$message: a+\\G");
862         is($1, 'ab', "$message: ab");
863
864         pos ($foo) += 1;
865         ok($foo =~ /b+\G(..)/g, "$message: b+\\G");
866         is($1, 'cc', "$message: cc");
867
868         pos ($foo) += 1;
869         ok($foo =~ /d+\G(..)/g, "$message: d+\\G");
870         is($1, 'de', "$message: de");
871
872         ok($foo =~ /\Gef/g, "$message: \\Gef");
873
874         pos ($foo) = 1;
875
876         ok($foo =~ /(?=a+\G)(..)/g, "$message: (?a+\\G)");
877         is($1, 'aa', "$message: aa");
878
879         pos ($foo) = 2;
880
881         ok($foo =~ /a(?=a+\G)(..)/g, "$message: a(?=a+\\G)");
882         is($1, 'ab', "$message: ab");
883
884     }
885
886     {
887         $_ = '123x123';
888         my @res = /(\d*|x)/g;
889         local $" = '|';
890         is("@res", "123||x|123|", "0 match in alternation");
891     }
892
893     {
894         my $message = "Match against temporaries (created via pp_helem())" .
895                          " is safe";
896         ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message);
897         is($1, "bar", $message);
898     }
899
900     {
901         my $message = 'package $i inside (?{ }), ' .
902                          'saved substrings and changing $_';
903         our @a = qw [foo bar];
904         our @b = ();
905         s/(\w)(?{push @b, $1})/,$1,/g for @a;
906         is("@b", "f o o b a r", $message);
907         is("@a", ",f,,o,,o, ,b,,a,,r,", $message);
908
909         $message = 'lexical $i inside (?{ }), ' .
910                          'saved substrings and changing $_';
911         no warnings 'closure';
912         my @c = qw [foo bar];
913         my @d = ();
914         s/(\w)(?{push @d, $1})/,$1,/g for @c;
915         is("@d", "f o o b a r", $message);
916         is("@c", ",f,,o,,o, ,b,,a,,r,", $message);
917     }
918
919     {
920         my $message = 'Brackets';
921         our $brackets;
922         $brackets = qr {
923             {  (?> [^{}]+ | (??{ $brackets }) )* }
924         }x;
925
926         ok("{{}" =~ $brackets, $message);
927         is($&, "{}", $message);
928         ok("something { long { and } hairy" =~ $brackets, $message);
929         is($&, "{ and }", $message);
930         ok("something { long { and } hairy" =~ m/((??{ $brackets }))/, $message);
931         is($&, "{ and }", $message);
932     }
933
934     {
935         $_ = "a-a\nxbb";
936         pos = 1;
937         ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg');
938     }
939
940     {
941         my $message = '\G anchor checks';
942         my $text = "aaXbXcc";
943         pos ($text) = 0;
944         ok($text !~ /\GXb*X/g, $message);
945     }
946
947     {
948         $_ = "xA\n" x 500;
949         unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"');
950
951         my $text = "abc dbf";
952         my @res = ($text =~ /.*?(b).*?\b/g);
953         is("@res", "b b", '\b is not special');
954     }
955
956     {
957         my $message = '\S, [\S], \s, [\s]';
958         my @a = map chr, 0 .. 255;
959         my @b = grep m/\S/, @a;
960         my @c = grep m/[^\s]/, @a;
961         is("@b", "@c", $message);
962
963         @b = grep /\S/, @a;
964         @c = grep /[\S]/, @a;
965         is("@b", "@c", $message);
966
967         @b = grep /\s/, @a;
968         @c = grep /[^\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     {
976         my $message = '\D, [\D], \d, [\d]';
977         my @a = map chr, 0 .. 255;
978         my @b = grep /\D/, @a;
979         my @c = grep /[^\d]/, @a;
980         is("@b", "@c", $message);
981
982         @b = grep /\D/, @a;
983         @c = grep /[\D]/, @a;
984         is("@b", "@c", $message);
985
986         @b = grep /\d/, @a;
987         @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     {
995         my $message = '\W, [\W], \w, [\w]';
996         my @a = map chr, 0 .. 255;
997         my @b = grep /\W/, @a;
998         my @c = grep /[^\w]/, @a;
999         is("@b", "@c", $message);
1000
1001         @b = grep /\W/, @a;
1002         @c = grep /[\W]/, @a;
1003         is("@b", "@c", $message);
1004
1005         @b = grep /\w/, @a;
1006         @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
1014     {
1015         # see if backtracking optimization works correctly
1016         my $message = 'Backtrack optimization';
1017         like("\n\n", qr/\n   $ \n/x, $message);
1018         like("\n\n", qr/\n*  $ \n/x, $message);
1019         like("\n\n", qr/\n+  $ \n/x, $message);
1020         like("\n\n", qr/\n?  $ \n/x, $message);
1021         like("\n\n", qr/\n*? $ \n/x, $message);
1022         like("\n\n", qr/\n+? $ \n/x, $message);
1023         like("\n\n", qr/\n?? $ \n/x, $message);
1024         unlike("\n\n", qr/\n*+ $ \n/x, $message);
1025         unlike("\n\n", qr/\n++ $ \n/x, $message);
1026         like("\n\n", qr/\n?+ $ \n/x, $message);
1027     }
1028
1029     {
1030         package S;
1031         use overload '""' => sub {'Object S'};
1032         sub new {bless []}
1033
1034         my $message  = "Ref stringification";
1035       ::ok(do { \my $v} =~ /^SCALAR/,   "Scalar ref stringification") or diag($message);
1036       ::ok(do {\\my $v} =~ /^REF/,      "Ref ref stringification") or diag($message);
1037       ::ok([]           =~ /^ARRAY/,    "Array ref stringification") or diag($message);
1038       ::ok({}           =~ /^HASH/,     "Hash ref stringification") or diag($message);
1039       ::ok('S' -> new   =~ /^Object S/, "Object stringification") or diag($message);
1040     }
1041
1042     {
1043         my $message = "Test result of match used as match";
1044         ok('a1b' =~ ('xyz' =~ /y/), $message);
1045         is($`, 'a', $message);
1046         ok('a1b' =~ ('xyz' =~ /t/), $message);
1047         is($`, 'a', $message);
1048     }
1049
1050     {
1051         my $message = '"1" is not \s';
1052         warning_is(sub {unlike("1\n" x 102, qr/^\s*\n/m, $message)},
1053                    undef, "$message (did not warn)");
1054     }
1055
1056     {
1057         my $message = '\s, [[:space:]] and [[:blank:]]';
1058         my %space = (spc   => " ",
1059                      tab   => "\t",
1060                      cr    => "\r",
1061                      lf    => "\n",
1062                      ff    => "\f",
1063         # There's no \v but the vertical tabulator seems miraculously
1064         # be 11 both in ASCII and EBCDIC.
1065                      vt    => chr(11),
1066                      false => "space");
1067
1068         my @space0 = sort grep {$space {$_} =~ /\s/         } keys %space;
1069         my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space;
1070         my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space;
1071
1072         is("@space0", "cr ff lf spc tab vt", $message);
1073         is("@space1", "cr ff lf spc tab vt", $message);
1074         is("@space2", "spc tab", $message);
1075     }
1076
1077     {
1078         my $n= 50;
1079         # this must be a high number and go from 0 to N, as the bug we are looking for doesn't
1080         # seem to be predictable. Slight changes to the test make it fail earlier or later.
1081         foreach my $i (0 .. $n)
1082         {
1083             my $str= "\n" x $i;
1084             ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i";
1085         }
1086     }
1087     {
1088         # we are actually testing that we dont die when executing these patterns
1089         use utf8;
1090         my $e = "Böck";
1091         ok(utf8::is_utf8($e),"got a unicode string - rt75680");
1092
1093         ok($e !~ m/.*?[x]$/, "unicode string against /.*?[x]\$/ - rt75680");
1094         ok($e !~ m/.*?\p{Space}$/i, "unicode string against /.*?\\p{space}\$/i - rt75680");
1095         ok($e !~ m/.*?[xyz]$/, "unicode string against /.*?[xyz]\$/ - rt75680");
1096         ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/, "unicode string against big pattern - rt75680");
1097     }
1098     {
1099         # we are actually testing that we dont die when executing these patterns
1100         my $e = "B\x{f6}ck";
1101         ok(!utf8::is_utf8($e), "got a latin string - rt75680");
1102
1103         ok($e !~ m/.*?[x]$/, "latin string against /.*?[x]\$/ - rt75680");
1104         ok($e !~ m/.*?\p{Space}$/i, "latin string against /.*?\\p{space}\$/i - rt75680");
1105         ok($e !~ m/.*?[xyz]$/,"latin string against /.*?[xyz]\$/ - rt75680");
1106         ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/,"latin string against big pattern - rt75680");
1107     }
1108
1109     {
1110         #
1111         # Tests for bug 77414.
1112         #
1113
1114         my $message = '\p property after empty * match';
1115         {
1116             like("1", qr/\s*\pN/, $message);
1117             like("-", qr/\s*\p{Dash}/, $message);
1118             like(" ", qr/\w*\p{Blank}/, $message);
1119         }
1120
1121         like("1", qr/\s*\pN+/, $message);
1122         like("-", qr/\s*\p{Dash}{1}/, $message);
1123         like(" ", qr/\w*\p{Blank}{1,4}/, $message);
1124
1125     }
1126
1127     SKIP: {   # Some constructs with Latin1 characters cause a utf8 string not
1128               # to match itself in non-utf8
1129         if ($::IS_EBCDIC) {
1130             skip "Needs to be customized to run on EBCDIC", 6;
1131         }
1132         my $c = "\xc0";
1133         my $pattern = my $utf8_pattern = qr/((\xc0)+,?)/;
1134         utf8::upgrade($utf8_pattern);
1135         ok $c =~ $pattern, "\\xc0 =~ $pattern; Neither pattern nor target utf8";
1136         ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8";
1137         ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not";
1138         ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not";
1139         utf8::upgrade($c);
1140         ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not";
1141         ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not";
1142         ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8";
1143         ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8";
1144     }
1145
1146     SKIP: {   # Make sure can override the formatting
1147         if ($::IS_EBCDIC) {
1148             skip "Needs to be customized to run on EBCDIC", 2;
1149         }
1150         use feature 'unicode_strings';
1151         ok "\xc0" =~ /\w/, 'Under unicode_strings: "\xc0" =~ /\w/';
1152         ok "\xc0" !~ /(?d:\w)/, 'Under unicode_strings: "\xc0" !~ /(?d:\w)/';
1153     }
1154
1155     {
1156         my $str= "\x{100}";
1157         chop $str;
1158         my $qr= qr/$str/;
1159         is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212");
1160         $str= "";
1161         $qr= qr/$str/;
1162         is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212");
1163
1164     }
1165
1166     {
1167         local $::TODO = "[perl #38133]";
1168
1169         "A" =~ /(((?:A))?)+/;
1170         my $first = $2;
1171
1172         "A" =~ /(((A))?)+/;
1173         my $second = $2;
1174
1175         is($first, $second);
1176     }
1177
1178     {
1179         # RT #3516: \G in a m//g expression causes problems
1180         my $count = 0;
1181         while ("abc" =~ m/(\G[ac])?/g) {
1182             last if $count++ > 10;
1183         }
1184         ok($count < 10, 'RT #3516 A');
1185
1186         $count = 0;
1187         while ("abc" =~ m/(\G|.)[ac]/g) {
1188             last if $count++ > 10;
1189         }
1190         ok($count < 10, 'RT #3516 B');
1191
1192         $count = 0;
1193         while ("abc" =~ m/(\G?[ac])?/g) {
1194             last if $count++ > 10;
1195         }
1196         ok($count < 10, 'RT #3516 C');
1197     }
1198     {
1199         # RT #84294: Is this a bug in the simple Perl regex?
1200         #          : Nested buffers and (?{...}) dont play nicely on partial matches
1201         our @got= ();
1202         ok("ab" =~ /((\w+)(?{ push @got, $2 })){2}/,"RT #84294: Pattern should match");
1203         my $want= "'ab', 'a', 'b'";
1204         my $got= join(", ", map { defined($_) ? "'$_'" : "undef" } @got);
1205         is($got,$want,'RT #84294: check that "ab" =~ /((\w+)(?{ push @got, $2 })){2}/ leaves @got in the correct state');
1206     }
1207
1208     {
1209         # Suppress warnings, as the non-unicode one comes out even if turn off
1210         # warnings here (because the execution is done in another scope).
1211         local $SIG{__WARN__} = sub {};
1212         my $str = "\x{110000}";
1213
1214         unlike($str, qr/\p{ASCII_Hex_Digit=True}/, "Non-Unicode doesn't match \\p{AHEX=True}");
1215         like($str, qr/\p{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\p{AHEX=False}");
1216         like($str, qr/\P{ASCII_Hex_Digit=True}/, "Non-Unicode matches \\P{AHEX=True}");
1217         unlike($str, qr/\P{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\P{AHEX=FALSE}");
1218     }
1219
1220     {
1221         # Test that IDstart works, but because the author (khw) knows
1222         # regexes much better than the rest of the core, it is being done here
1223         # in the context of a regex which relies on buffer names beginng with
1224         # IDStarts.
1225         use utf8;
1226         my $str = "abc";
1227         like($str, qr/(?<a>abc)/, "'a' is legal IDStart");
1228         like($str, qr/(?<_>abc)/, "'_' is legal IDStart");
1229         like($str, qr/(?<ß>abc)/, "U+00DF is legal IDStart");
1230         like($str, qr/(?<ℕ>abc)/, "U+2115' is legal IDStart");
1231
1232         # This test works on Unicode 6.0 in which U+2118 and U+212E are legal
1233         # IDStarts there, but are not Word characters, and therefore Perl
1234         # doesn't allow them to be IDStarts.  But there is no guarantee that
1235         # Unicode won't change things around in the future so that at some
1236         # future Unicode revision these tests would need to be revised.
1237         foreach my $char ("%", "×", chr(0x2118), chr(0x212E)) {
1238             my $prog = <<"EOP";
1239 use utf8;;
1240 "abc" =~ qr/(?<$char>abc)/;
1241 EOP
1242             utf8::encode($prog);
1243             fresh_perl_like($prog, qr!Group name must start with a non-digit word character!, {},
1244                         sprintf("'U+%04X not legal IDFirst'", ord($char)));
1245         }
1246     }
1247
1248     { # [perl #101710]
1249         my $pat = "b";
1250         utf8::upgrade($pat);
1251         like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string");
1252     }
1253
1254     { # Crash with @a =~ // warning
1255         local $SIG{__WARN__} = sub {
1256              pass 'no crash for @a =~ // warning'
1257         };
1258         eval ' sub { my @a =~ // } ';
1259     }
1260
1261     { # Concat overloading and qr// thingies
1262         my @refs;
1263         my $qr = qr//;
1264         package Cat {
1265             require overload;
1266             overload->import(
1267                 '""' => sub { ${$_[0]} },
1268                 '.' => sub {
1269                     push @refs, ref $_[1] if ref $_[1];
1270                     bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]"
1271                 }
1272             );
1273         }
1274         my $s = "foo";
1275         my $o = bless \$s, Cat::;
1276         /$o$qr/;
1277         is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth';
1278     }
1279
1280     {
1281         my $count=0;
1282         my $str="\n";
1283         $count++ while $str=~/.*/g;
1284         is $count, 2, 'test that ANCH_MBOL works properly. We should get 2 from $count++ while "\n"=~/.*/g';
1285         my $class_count= 0;
1286         $class_count++ while $str=~/[^\n]*/g;
1287         is $class_count, $count, 'while "\n"=~/.*/g and while "\n"=~/[^\n]*/g should behave the same';
1288         my $anch_count= 0;
1289         $anch_count++ while $str=~/^.*/mg;
1290         is $anch_count, 1, 'while "\n"=~/^.*/mg should match only once';
1291     }
1292
1293     { # [perl #111174]
1294         use re '/u';
1295         like "\xe0", qr/(?i:\xc0)/, "(?i: shouldn't lose the passed in /u";
1296         use re '/a';
1297         unlike "\x{100}", qr/(?i:\w)/, "(?i: shouldn't lose the passed in /a";
1298         use re '/aa';
1299         unlike 'k', qr/(?i:\N{KELVIN SIGN})/, "(?i: shouldn't lose the passed in /aa";
1300     }
1301
1302     {
1303         # the test for whether the pattern should be re-compiled should
1304         # consider the UTF8ness of the previous and current pattern
1305         # string, as well as the physical bytes of the pattern string
1306
1307         for my $s ("\xc4\x80", "\x{100}") {
1308             ok($s =~ /^$s$/, "re-compile check is UTF8-aware");
1309         }
1310     }
1311
1312     #  #113682 more overloading and qr//
1313     # when doing /foo$overloaded/, if $overloaded returns
1314     # a qr/(?{})/ via qr or "" overloading, then 'use re 'eval'
1315     # shouldn't be required. Via '.', it still is.
1316     {
1317         package Qr0;
1318         use overload 'qr' => sub { qr/(??{50})/ };
1319
1320         package Qr1;
1321         use overload '""' => sub { qr/(??{51})/ };
1322
1323         package Qr2;
1324         use overload '.'  => sub { $_[1] . qr/(??{52})/ };
1325
1326         package Qr3;
1327         use overload '""' => sub { qr/(??{7})/ },
1328                      '.'  => sub { $_[1] . qr/(??{53})/ };
1329
1330         package Qr_indirect;
1331         use overload '""'  => sub { $_[0][0] };
1332
1333         package main;
1334
1335         for my $i (0..3) {
1336             my $o = bless [], "Qr$i";
1337             if ((0,0,1,1)[$i]) {
1338                 eval { "A5$i" =~ /^A$o$/ };
1339                 like($@, qr/Eval-group not allowed/, "Qr$i");
1340                 eval { "5$i" =~ /$o/ };
1341                 like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
1342                         "Qr$i bare");
1343                 {
1344                     use re 'eval';
1345                     ok("A5$i" =~ /^A$o$/, "Qr$i - with use re eval");
1346                     eval { "5$i" =~ /$o/ };
1347                     like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
1348                             "Qr$i bare - with use re eval");
1349                 }
1350             }
1351             else {
1352                 ok("A5$i" =~ /^A$o$/, "Qr$i");
1353                 ok("5$i" =~ /$o/, "Qr$i bare");
1354             }
1355         }
1356
1357         my $o = bless [ bless [], "Qr1" ], 'Qr_indirect';
1358         ok("A51" =~ /^A$o/, "Qr_indirect");
1359         ok("51" =~ /$o/, "Qr_indirect bare");
1360     }
1361
1362     {   # Various flags weren't being set when a [] is optimized into an
1363         # EXACTish node
1364         ;
1365         ;
1366         ok("\x{017F}\x{017F}" =~ qr/^[\x{00DF}]?$/i, "[] to EXACTish optimization");
1367     }
1368
1369     {
1370         for my $char (":", "\x{f7}", "\x{2010}") {
1371             my $utf8_char = $char;
1372             utf8::upgrade($utf8_char);
1373             my $display = $char;
1374             $display = display($display);
1375             my $utf8_display = "utf8::upgrade(\"$display\")";
1376
1377             like($char, qr/^$char?$/, "\"$display\" =~ /^$display?\$/");
1378             like($char, qr/^$utf8_char?$/, "my \$p = \"$display\"; utf8::upgrade(\$p); \"$display\" =~ /^\$p?\$/");
1379             like($utf8_char, qr/^$char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); \"\$c\" =~ /^$display?\$/");
1380             like($utf8_char, qr/^$utf8_char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); my \$p = \"$display\"; utf8::upgrade(\$p); \"\$c\" =~ /^\$p?\$/");
1381         }
1382     }
1383
1384     {
1385         # #116148: Pattern utf8ness sticks around globally
1386         # the utf8 in the first match was sticking around for the second
1387         # match
1388
1389         use feature 'unicode_strings';
1390
1391         my $x = "\x{263a}";
1392         $x =~ /$x/;
1393
1394         my $text = "Perl";
1395         ok("Perl" =~ /P.*$/i, '#116148');
1396     }
1397
1398     { # 118297: Mixing up- and down-graded strings in regex
1399         utf8::upgrade(my $u = "\x{e5}");
1400         utf8::downgrade(my $d = "\x{e5}");
1401         my $warned;
1402         local $SIG{__WARN__} = sub { $warned++ if $_[0] =~ /\AMalformed UTF-8/ };
1403         my $re = qr/$u$d/;
1404         ok(!$warned, "no warnings when interpolating mixed up-/downgraded strings in pattern");
1405         my $c = "\x{e5}\x{e5}";
1406         utf8::downgrade($c);
1407         like($c, $re, "mixed up-/downgraded pattern matches downgraded string");
1408         utf8::upgrade($c);
1409         like($c, $re, "mixed up-/downgraded pattern matches upgraded string");
1410     }
1411
1412     {
1413         # if we have 87 capture buffers defined then \87 should refer to the 87th.
1414         # test that this is true for 1..100
1415         # Note that this test causes the engine to recurse at runtime, and
1416         # hence use a lot of C stack.
1417         for my $i (1..100) {
1418             my $capture= "a";
1419             $capture= "($capture)" for 1 .. $i;
1420             for my $mid ("","b") {
1421                 my $str= "a${mid}a";
1422                 my $backref= "\\$i";
1423                 eval {
1424                     ok($str=~/$capture$mid$backref/,"\\$i works with $i buffers '$str'=~/...$mid$backref/");
1425                     1;
1426                 } or do {
1427                     is("$@","","\\$i works with $i buffers works with $i buffers '$str'=~/...$mid$backref/");
1428                 };
1429             }
1430         }
1431     }
1432
1433     # this mixture of readonly (not COWable) and COWable strings
1434     # messed up the capture buffers under COW. The actual test results
1435     # are incidental; the issue is was an AddressSanitizer failure
1436     {
1437         my $c ='AB';
1438         my $res = '';
1439         for ($c, 'C', $c, 'DE') {
1440             ok(/(.)/, "COWable match");
1441             $res .= $1;
1442         }
1443         is($res, "ACAD");
1444     }
1445
1446
1447     {
1448         # RT #45667
1449         # /[#$x]/x didn't interpolate the var $x.
1450         my $b = 'cd';
1451         my $s = 'abcd$%#&';
1452         $s =~ s/[a#$b%]/X/g;
1453         is ($s, 'XbXX$XX&', 'RT #45667 without /x');
1454         $s = 'abcd$%#&';
1455         $s =~ s/[a#$b%]/X/gx;
1456         is ($s, 'XbXX$XX&', 'RT #45667 with /x');
1457     }
1458
1459     {
1460         no warnings "uninitialized";
1461         my @a;
1462         $a[1]++;
1463         /@a/;
1464         pass('no crash with /@a/ when array has nonexistent elems');
1465     }
1466
1467     {
1468         is runperl(prog => 'delete $::{qq-\cR-}; //; print qq-ok\n-'),
1469            "ok\n",
1470            'deleting *^R does not result in crashes';
1471         no warnings 'once';
1472         *^R = *caretRglobwithnoscalar;
1473         "" =~ /(?{42})/;
1474         is $^R, 42, 'assigning to *^R does not result in a crash';
1475         is runperl(
1476              stderr => 1,
1477              prog => 'eval q|'
1478                     .' q-..- =~ /(??{undef *^R;q--})(?{42})/; '
1479                     .' print qq-$^R\n-'
1480                     .'|'
1481            ),
1482            "42\n",
1483            'undefining *^R within (??{}) does not result in a crash';
1484     }
1485
1486     {
1487         # [perl #120446]
1488         # this code should be virtually instantaneous. If it takes 10s of
1489         # seconds, there a bug in intuit_start.
1490         # (this test doesn't actually test for slowness - that involves
1491         # too much danger of false positives on loaded machines - but by
1492         # putting it here, hopefully someone might notice if it suddenly
1493         # runs slowly)
1494         my $s = ('a' x 1_000_000) . 'b';
1495         my $i = 0;
1496         for (1..10_000) {
1497             pos($s) = $_;
1498             $i++ if $s =~/\Gb/g;
1499         }
1500         is($i, 0, "RT 120446: mustn't run slowly");
1501     }
1502
1503     {
1504         # [perl #120692]
1505         # these tests should be virtually instantaneous. If they take 10s of
1506         # seconds, there's a bug in intuit_start.
1507
1508         my $s = 'ab' x 1_000_000;
1509         utf8::upgrade($s);
1510         1 while $s =~ m/\Ga+ba+b/g;
1511         pass("RT#120692 \\G mustn't run slowly");
1512
1513         $s=~ /^a{1,2}x/ for  1..10_000;
1514         pass("RT#120692 a{1,2} mustn't run slowly");
1515
1516         $s=~ /ab.{1,2}x/;
1517         pass("RT#120692 ab.{1,2} mustn't run slowly");
1518
1519         $s = "-a-bc" x 250_000;
1520         $s .= "1a1bc";
1521         utf8::upgrade($s);
1522         ok($s =~ /\da\d{0,30000}bc/, "\\d{30000}");
1523
1524         $s = "-ab\n" x 250_000;
1525         $s .= "abx";
1526         ok($s =~ /^ab.*x/m, "distant float with /m");
1527
1528         my $r = qr/^abcd/;
1529         $s = "abcd-xyz\n" x 500_000;
1530         $s =~ /$r\d{1,2}xyz/m for 1..200;
1531         pass("BOL within //m  mustn't run slowly");
1532
1533         $s = "abcdefg" x 1_000_000;
1534         $s =~ /(?-m:^)abcX?fg/m for 1..100;
1535         pass("BOL within //m  mustn't skip absolute anchored check");
1536
1537         $s = "abcdefg" x 1_000_000;
1538         $s =~ /^XX\d{1,10}cde/ for 1..100;
1539         pass("abs anchored float string should fail quickly");
1540
1541     }
1542
1543     # These are based on looking at the code in regcomp.c
1544     # We don't look for specific code, just the existence of an SSC
1545     foreach my $re (qw(     qr/a?c/
1546                             qr/a?c/i
1547                             qr/[ab]?c/
1548                             qr/\R?c/
1549                             qr/\d?c/d
1550                             qr/\w?c/l
1551                             qr/\s?c/a
1552                             qr/[[:alpha:]]?c/u
1553     )) {
1554       SKIP: {
1555         skip "no re-debug under miniperl" if is_miniperl;
1556         my $prog = <<"EOP";
1557 use re qw(Debug COMPILE);
1558 $re;
1559 EOP
1560         fresh_perl_like($prog, qr/synthetic stclass/, { stderr=>1 }, "$re generates a synthetic start class");
1561       }
1562     }
1563
1564     {
1565         like "\x{AA}", qr/a?[\W_]/d, "\\W with /d synthetic start class works";
1566     }
1567
1568     {
1569         # Verify that the very last Latin-1 U+00FF
1570         # (LATIN SMALL LETTER Y WITH DIAERESIS)
1571         # and its UPPER counterpart (U+0178 which is pure Unicode),
1572         # and likewise for the very first pure Unicode
1573         # (LATIN CAPITAL LETTER A WITH MACRON) fold-match properly,
1574         # and there are no off-by-one logic errors in the transition zone.
1575
1576         ok("\xFF" =~ /\xFF/i, "Y WITH DIAERESIS l =~ l");
1577         ok("\xFF" =~ /\x{178}/i, "Y WITH DIAERESIS l =~ u");
1578         ok("\x{178}" =~ /\xFF/i, "Y WITH DIAERESIS u =~ l");
1579         ok("\x{178}" =~ /\x{178}/i, "Y WITH DIAERESIS u =~ u");
1580
1581         # U+00FF with U+05D0 (non-casing Hebrew letter).
1582         ok("\xFF\x{5D0}" =~ /\xFF\x{5D0}/i, "Y WITH DIAERESIS l =~ l");
1583         ok("\xFF\x{5D0}" =~ /\x{178}\x{5D0}/i, "Y WITH DIAERESIS l =~ u");
1584         ok("\x{178}\x{5D0}" =~ /\xFF\x{5D0}/i, "Y WITH DIAERESIS u =~ l");
1585         ok("\x{178}\x{5D0}" =~ /\x{178}\x{5D0}/i, "Y WITH DIAERESIS u =~ u");
1586
1587         # U+0100.
1588         ok("\x{100}" =~ /\x{100}/i, "A WITH MACRON u =~ u");
1589         ok("\x{100}" =~ /\x{101}/i, "A WITH MACRON u =~ l");
1590         ok("\x{101}" =~ /\x{100}/i, "A WITH MACRON l =~ u");
1591         ok("\x{101}" =~ /\x{101}/i, "A WITH MACRON l =~ l");
1592     }
1593
1594     {
1595         use utf8;
1596         ok("abc" =~ /a\85b\85c/x, "NEL is white-space under /x");
1597     }
1598
1599     {
1600         ok('a(b)c' =~ qr(a\(b\)c), "'\\(' is a literal in qr(...)");
1601         ok('a[b]c' =~ qr[a\[b\]c], "'\\[' is a literal in qr[...]");
1602         ok('a{3}c' =~ qr{a\{3\}c},  # Only failed when { could be a meta
1603               "'\\{' is a literal in qr{...}, where it could be a quantifier");
1604
1605         # This one is for completeness
1606         ok('a<b>c' =~ qr<a\<b\>c>, "'\\<' is a literal in qr<...>)");
1607     }
1608
1609     {   # Was getting optimized into EXACT (non-folding node)
1610         my $x = qr/[x]/i;
1611         utf8::upgrade($x);
1612         like("X", qr/$x/, "UTF-8 of /[x]/i matches upper case");
1613     }
1614
1615 } # End of sub run_tests
1616
1617 1;