This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
05bb650a154a0b6e7fe12e45500275dcb8497f9a
[perl5.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 => 467;  # 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
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
730         local $::TODO = $::running_as_thread;
731         ok($str =~ /.\G./ && $& eq 'bc', $message);
732     }
733
734     {
735         my $message = 'pos inside (?{ })';
736         my $str = 'abcde';
737         our ($foo, $bar);
738         like($str, qr/b(?{$foo = $_; $bar = pos})c/, $message);
739         is($foo, $str, $message);
740         is($bar, 2, $message);
741         is(pos $str, undef, $message);
742
743         undef $foo;
744         undef $bar;
745         pos $str = undef;
746         ok($str =~ /b(?{$foo = $_; $bar = pos})c/g, $message);
747         is($foo, $str, $message);
748         is($bar, 2, $message);
749         is(pos $str, 3, $message);
750
751         $_ = $str;
752         undef $foo;
753         undef $bar;
754         like($_, qr/b(?{$foo = $_; $bar = pos})c/, $message);
755         is($foo, $str, $message);
756         is($bar, 2, $message);
757
758         undef $foo;
759         undef $bar;
760         ok(/b(?{$foo = $_; $bar = pos})c/g, $message);
761         is($foo, $str, $message);
762         is($bar, 2, $message);
763         is(pos, 3, $message);
764
765         undef $foo;
766         undef $bar;
767         pos = undef;
768         1 while /b(?{$foo = $_; $bar = pos})c/g;
769         is($foo, $str, $message);
770         is($bar, 2, $message);
771         is(pos, undef, $message);
772
773         undef $foo;
774         undef $bar;
775         $_ = 'abcde|abcde';
776         ok(s/b(?{$foo = $_; $bar = pos})c/x/g, $message);
777         is($foo, 'abcde|abcde', $message);
778         is($bar, 8, $message);
779         is($_, 'axde|axde', $message);
780
781         # List context:
782         $_ = 'abcde|abcde';
783         our @res;
784         () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
785         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
786         is("@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'", $message);
787
788         @res = ();
789         () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
790         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
791         is("@res", "'' 'ab' 'cde|abcde' " .
792                      "'' 'abc' 'de|abcde' " .
793                      "'abcd' 'e|' 'abcde' " .
794                      "'abcde|' 'ab' 'cde' " .
795                      "'abcde|' 'abc' 'de'", $message);
796     }
797
798     {
799         my $message = '\G anchor checks';
800         my $foo = 'aabbccddeeffgg';
801         pos ($foo) = 1;
802         {
803             local $::TODO = $::running_as_thread;
804             no warnings 'uninitialized';
805             ok($foo =~ /.\G(..)/g, $message);
806             is($1, 'ab', $message);
807
808             pos ($foo) += 1;
809             ok($foo =~ /.\G(..)/g, $message);
810             is($1, 'cc', $message);
811
812             pos ($foo) += 1;
813             ok($foo =~ /.\G(..)/g, $message);
814             is($1, 'de', $message);
815
816             ok($foo =~ /\Gef/g, $message);
817         }
818
819         undef pos $foo;
820         ok($foo =~ /\G(..)/g, $message);
821         is($1, 'aa', $message);
822
823         ok($foo =~ /\G(..)/g, $message);
824         is($1, 'bb', $message);
825
826         pos ($foo) = 5;
827         ok($foo =~ /\G(..)/g, $message);
828         is($1, 'cd', $message);
829     }
830
831     {
832         $_ = '123x123';
833         my @res = /(\d*|x)/g;
834         local $" = '|';
835         is("@res", "123||x|123|", "0 match in alternation");
836     }
837
838     {
839         my $message = "Match against temporaries (created via pp_helem())" .
840                          " is safe";
841         ok({foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g, $message);
842         is($1, "bar", $message);
843     }
844
845     {
846         my $message = 'package $i inside (?{ }), ' .
847                          'saved substrings and changing $_';
848         our @a = qw [foo bar];
849         our @b = ();
850         s/(\w)(?{push @b, $1})/,$1,/g for @a;
851         is("@b", "f o o b a r", $message);
852         is("@a", ",f,,o,,o, ,b,,a,,r,", $message);
853
854         $message = 'lexical $i inside (?{ }), ' .
855                          'saved substrings and changing $_';
856         no warnings 'closure';
857         my @c = qw [foo bar];
858         my @d = ();
859         s/(\w)(?{push @d, $1})/,$1,/g for @c;
860         is("@d", "f o o b a r", $message);
861         is("@c", ",f,,o,,o, ,b,,a,,r,", $message);
862     }
863
864     {
865         my $message = 'Brackets';
866         our $brackets;
867         $brackets = qr {
868             {  (?> [^{}]+ | (??{ $brackets }) )* }
869         }x;
870
871         ok("{{}" =~ $brackets, $message);
872         is($&, "{}", $message);
873         ok("something { long { and } hairy" =~ $brackets, $message);
874         is($&, "{ and }", $message);
875         ok("something { long { and } hairy" =~ m/((??{ $brackets }))/, $message);
876         is($&, "{ and }", $message);
877     }
878
879     {
880         $_ = "a-a\nxbb";
881         pos = 1;
882         ok(!m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg');
883     }
884
885     {
886         my $message = '\G anchor checks';
887         my $text = "aaXbXcc";
888         pos ($text) = 0;
889         ok($text !~ /\GXb*X/g, $message);
890     }
891
892     {
893         $_ = "xA\n" x 500;
894         unlike($_, qr/^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"');
895
896         my $text = "abc dbf";
897         my @res = ($text =~ /.*?(b).*?\b/g);
898         is("@res", "b b", '\b is not special');
899     }
900
901     {
902         my $message = '\S, [\S], \s, [\s]';
903         my @a = map chr, 0 .. 255;
904         my @b = grep m/\S/, @a;
905         my @c = grep m/[^\s]/, @a;
906         is("@b", "@c", $message);
907
908         @b = grep /\S/, @a;
909         @c = grep /[\S]/, @a;
910         is("@b", "@c", $message);
911
912         @b = grep /\s/, @a;
913         @c = grep /[^\S]/, @a;
914         is("@b", "@c", $message);
915
916         @b = grep /\s/, @a;
917         @c = grep /[\s]/, @a;
918         is("@b", "@c", $message);
919     }
920     {
921         my $message = '\D, [\D], \d, [\d]';
922         my @a = map chr, 0 .. 255;
923         my @b = grep /\D/, @a;
924         my @c = grep /[^\d]/, @a;
925         is("@b", "@c", $message);
926
927         @b = grep /\D/, @a;
928         @c = grep /[\D]/, @a;
929         is("@b", "@c", $message);
930
931         @b = grep /\d/, @a;
932         @c = grep /[^\D]/, @a;
933         is("@b", "@c", $message);
934
935         @b = grep /\d/, @a;
936         @c = grep /[\d]/, @a;
937         is("@b", "@c", $message);
938     }
939     {
940         my $message = '\W, [\W], \w, [\w]';
941         my @a = map chr, 0 .. 255;
942         my @b = grep /\W/, @a;
943         my @c = grep /[^\w]/, @a;
944         is("@b", "@c", $message);
945
946         @b = grep /\W/, @a;
947         @c = grep /[\W]/, @a;
948         is("@b", "@c", $message);
949
950         @b = grep /\w/, @a;
951         @c = grep /[^\W]/, @a;
952         is("@b", "@c", $message);
953
954         @b = grep /\w/, @a;
955         @c = grep /[\w]/, @a;
956         is("@b", "@c", $message);
957     }
958
959     {
960         # see if backtracking optimization works correctly
961         my $message = 'Backtrack optimization';
962         like("\n\n", qr/\n   $ \n/x, $message);
963         like("\n\n", qr/\n*  $ \n/x, $message);
964         like("\n\n", qr/\n+  $ \n/x, $message);
965         like("\n\n", qr/\n?  $ \n/x, $message);
966         like("\n\n", qr/\n*? $ \n/x, $message);
967         like("\n\n", qr/\n+? $ \n/x, $message);
968         like("\n\n", qr/\n?? $ \n/x, $message);
969         unlike("\n\n", qr/\n*+ $ \n/x, $message);
970         unlike("\n\n", qr/\n++ $ \n/x, $message);
971         like("\n\n", qr/\n?+ $ \n/x, $message);
972     }
973
974     {
975         package S;
976         use overload '""' => sub {'Object S'};
977         sub new {bless []}
978
979         my $message  = "Ref stringification";
980       ::ok(do { \my $v} =~ /^SCALAR/,   "Scalar ref stringification") or diag($message);
981       ::ok(do {\\my $v} =~ /^REF/,      "Ref ref stringification") or diag($message);
982       ::ok([]           =~ /^ARRAY/,    "Array ref stringification") or diag($message);
983       ::ok({}           =~ /^HASH/,     "Hash ref stringification") or diag($message);
984       ::ok('S' -> new   =~ /^Object S/, "Object stringification") or diag($message);
985     }
986
987     {
988         my $message = "Test result of match used as match";
989         ok('a1b' =~ ('xyz' =~ /y/), $message);
990         is($`, 'a', $message);
991         ok('a1b' =~ ('xyz' =~ /t/), $message);
992         is($`, 'a', $message);
993     }
994
995     {
996         my $message = '"1" is not \s';
997         warning_is(sub {unlike("1\n" x 102, qr/^\s*\n/m, $message)},
998                    undef, "$message (did not warn)");
999     }
1000
1001     {
1002         my $message = '\s, [[:space:]] and [[:blank:]]';
1003         my %space = (spc   => " ",
1004                      tab   => "\t",
1005                      cr    => "\r",
1006                      lf    => "\n",
1007                      ff    => "\f",
1008         # There's no \v but the vertical tabulator seems miraculously
1009         # be 11 both in ASCII and EBCDIC.
1010                      vt    => chr(11),
1011                      false => "space");
1012
1013         my @space0 = sort grep {$space {$_} =~ /\s/         } keys %space;
1014         my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space;
1015         my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space;
1016
1017         is("@space0", "cr ff lf spc tab vt", $message);
1018         is("@space1", "cr ff lf spc tab vt", $message);
1019         is("@space2", "spc tab", $message);
1020     }
1021
1022     {
1023         my $n= 50;
1024         # this must be a high number and go from 0 to N, as the bug we are looking for doesn't
1025         # seem to be predictable. Slight changes to the test make it fail earlier or later.
1026         foreach my $i (0 .. $n)
1027         {
1028             my $str= "\n" x $i;
1029             ok $str=~/.*\z/, "implicit MBOL check string disable does not break things length=$i";
1030         }
1031     }
1032     {
1033         # we are actually testing that we dont die when executing these patterns
1034         use utf8;
1035         my $e = "Böck";
1036         ok(utf8::is_utf8($e),"got a unicode string - rt75680");
1037
1038         ok($e !~ m/.*?[x]$/, "unicode string against /.*?[x]\$/ - rt75680");
1039         ok($e !~ m/.*?\p{Space}$/i, "unicode string against /.*?\\p{space}\$/i - rt75680");
1040         ok($e !~ m/.*?[xyz]$/, "unicode string against /.*?[xyz]\$/ - rt75680");
1041         ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/, "unicode string against big pattern - rt75680");
1042     }
1043     {
1044         # we are actually testing that we dont die when executing these patterns
1045         my $e = "B\x{f6}ck";
1046         ok(!utf8::is_utf8($e), "got a latin string - rt75680");
1047
1048         ok($e !~ m/.*?[x]$/, "latin string against /.*?[x]\$/ - rt75680");
1049         ok($e !~ m/.*?\p{Space}$/i, "latin string against /.*?\\p{space}\$/i - rt75680");
1050         ok($e !~ m/.*?[xyz]$/,"latin string against /.*?[xyz]\$/ - rt75680");
1051         ok($e !~ m/(.*?)[,\p{isSpace}]+((?:\p{isAlpha}[\p{isSpace}\.]{1,2})+)\p{isSpace}*$/,"latin string against big pattern - rt75680");
1052     }
1053
1054     {
1055         #
1056         # Tests for bug 77414.
1057         #
1058
1059         my $message = '\p property after empty * match';
1060         {
1061             like("1", qr/\s*\pN/, $message);
1062             like("-", qr/\s*\p{Dash}/, $message);
1063             like(" ", qr/\w*\p{Blank}/, $message);
1064         }
1065
1066         like("1", qr/\s*\pN+/, $message);
1067         like("-", qr/\s*\p{Dash}{1}/, $message);
1068         like(" ", qr/\w*\p{Blank}{1,4}/, $message);
1069
1070     }
1071
1072     SKIP: {   # Some constructs with Latin1 characters cause a utf8 string not
1073               # to match itself in non-utf8
1074         if ($::IS_EBCDIC) {
1075             skip "Needs to be customized to run on EBCDIC", 6;
1076         }
1077         my $c = "\xc0";
1078         my $pattern = my $utf8_pattern = qr/((\xc0)+,?)/;
1079         utf8::upgrade($utf8_pattern);
1080         ok $c =~ $pattern, "\\xc0 =~ $pattern; Neither pattern nor target utf8";
1081         ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; Neither pattern nor target utf8";
1082         ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; pattern utf8, target not";
1083         ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; pattern utf8, target not";
1084         utf8::upgrade($c);
1085         ok $c =~ $pattern, "\\xc0 =~ $pattern; target utf8, pattern not";
1086         ok $c =~ /$pattern/i, "\\xc0 =~ /$pattern/i; target utf8, pattern not";
1087         ok $c =~ $utf8_pattern, "\\xc0 =~ $pattern; Both target and pattern utf8";
1088         ok $c =~ /$utf8_pattern/i, "\\xc0 =~ /$pattern/i; Both target and pattern utf8";
1089     }
1090
1091     SKIP: {   # Make sure can override the formatting
1092         if ($::IS_EBCDIC) {
1093             skip "Needs to be customized to run on EBCDIC", 2;
1094         }
1095         use feature 'unicode_strings';
1096         ok "\xc0" =~ /\w/, 'Under unicode_strings: "\xc0" =~ /\w/';
1097         ok "\xc0" !~ /(?d:\w)/, 'Under unicode_strings: "\xc0" !~ /(?d:\w)/';
1098     }
1099
1100     {
1101         my $str= "\x{100}";
1102         chop $str;
1103         my $qr= qr/$str/;
1104         is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag enabled - Bug #80212");
1105         $str= "";
1106         $qr= qr/$str/;
1107         is("$qr", "(?^:)", "Empty pattern qr// stringifies to (?^:) with unicode flag disabled - Bug #80212");
1108
1109     }
1110
1111     {
1112         local $::TODO = "[perl #38133]";
1113
1114         "A" =~ /(((?:A))?)+/;
1115         my $first = $2;
1116
1117         "A" =~ /(((A))?)+/;
1118         my $second = $2;
1119
1120         is($first, $second);
1121     }
1122
1123     {
1124         # RT #3516: \G in a m//g expression causes problems
1125         my $count = 0;
1126         while ("abc" =~ m/(\G[ac])?/g) {
1127             last if $count++ > 10;
1128         }
1129         ok($count < 10, 'RT #3516 A');
1130
1131         $count = 0;
1132         while ("abc" =~ m/(\G|.)[ac]/g) {
1133             last if $count++ > 10;
1134         }
1135         ok($count < 10, 'RT #3516 B');
1136
1137         $count = 0;
1138         while ("abc" =~ m/(\G?[ac])?/g) {
1139             last if $count++ > 10;
1140         }
1141         ok($count < 10, 'RT #3516 C');
1142     }
1143     {
1144         # RT #84294: Is this a bug in the simple Perl regex?
1145         #          : Nested buffers and (?{...}) dont play nicely on partial matches
1146         our @got= ();
1147         ok("ab" =~ /((\w+)(?{ push @got, $2 })){2}/,"RT #84294: Pattern should match");
1148         my $want= "'ab', 'a', 'b'";
1149         my $got= join(", ", map { defined($_) ? "'$_'" : "undef" } @got);
1150         is($got,$want,'RT #84294: check that "ab" =~ /((\w+)(?{ push @got, $2 })){2}/ leaves @got in the correct state');
1151     }
1152
1153     {
1154         # Suppress warnings, as the non-unicode one comes out even if turn off
1155         # warnings here (because the execution is done in another scope).
1156         local $SIG{__WARN__} = sub {};
1157         my $str = "\x{110000}";
1158
1159         # No non-unicode code points match any Unicode property, even inverse
1160         # ones
1161         unlike($str, qr/\p{ASCII_Hex_Digit=True}/, "Non-Unicode doesn't match \\p{}");
1162         unlike($str, qr/\p{ASCII_Hex_Digit=False}/, "Non-Unicode doesn't match \\p{}");
1163         like($str, qr/\P{ASCII_Hex_Digit=True}/, "Non-Unicode matches \\P{}");
1164         like($str, qr/\P{ASCII_Hex_Digit=False}/, "Non-Unicode matches \\P{}");
1165     }
1166
1167     {
1168         # Test that IDstart works, but because the author (khw) knows
1169         # regexes much better than the rest of the core, it is being done here
1170         # in the context of a regex which relies on buffer names beginng with
1171         # IDStarts.
1172         use utf8;
1173         my $str = "abc";
1174         like($str, qr/(?<a>abc)/, "'a' is legal IDStart");
1175         like($str, qr/(?<_>abc)/, "'_' is legal IDStart");
1176         like($str, qr/(?<ß>abc)/, "U+00DF is legal IDStart");
1177         like($str, qr/(?<ℕ>abc)/, "U+2115' is legal IDStart");
1178
1179         # This test works on Unicode 6.0 in which U+2118 and U+212E are legal
1180         # IDStarts there, but are not Word characters, and therefore Perl
1181         # doesn't allow them to be IDStarts.  But there is no guarantee that
1182         # Unicode won't change things around in the future so that at some
1183         # future Unicode revision these tests would need to be revised.
1184         foreach my $char ("%", "×", chr(0x2118), chr(0x212E)) {
1185             my $prog = <<"EOP";
1186 use utf8;;
1187 "abc" =~ qr/(?<$char>abc)/;
1188 EOP
1189             utf8::encode($prog);
1190             fresh_perl_like($prog, qr!Group name must start with a non-digit word character!, "",
1191                         sprintf("'U+%04X not legal IDFirst'", ord($char)));
1192         }
1193     }
1194
1195     { # [perl #101710]
1196         my $pat = "b";
1197         utf8::upgrade($pat);
1198         like("\xffb", qr/$pat/i, "/i: utf8 pattern, non-utf8 string, latin1-char preceding matching char in string");
1199     }
1200
1201     { # Crash with @a =~ // warning
1202         local $SIG{__WARN__} = sub {
1203              pass 'no crash for @a =~ // warning'
1204         };
1205         eval ' sub { my @a =~ // } ';
1206     }
1207
1208     { # Concat overloading and qr// thingies
1209         my @refs;
1210         my $qr = qr//;
1211         package Cat {
1212             require overload;
1213             overload->import(
1214                 '""' => sub { ${$_[0]} },
1215                 '.' => sub {
1216                     push @refs, ref $_[1] if ref $_[1];
1217                     bless $_[2] ? \"$_[1]${$_[0]}" : \"${$_[0]}$_[1]"
1218                 }
1219             );
1220         }
1221         my $s = "foo";
1222         my $o = bless \$s, Cat::;
1223         /$o$qr/;
1224         is "@refs", "Regexp", '/$o$qr/ passes qr ref to cat overload meth';
1225     }
1226
1227     {
1228         my $count=0;
1229         my $str="\n";
1230         $count++ while $str=~/.*/g;
1231         is $count, 2, 'test that ANCH_MBOL works properly. We should get 2 from $count++ while "\n"=~/.*/g';
1232         my $class_count= 0;
1233         $class_count++ while $str=~/[^\n]*/g;
1234         is $class_count, $count, 'while "\n"=~/.*/g and while "\n"=~/[^\n]*/g should behave the same';
1235         my $anch_count= 0;
1236         $anch_count++ while $str=~/^.*/mg;
1237         is $anch_count, 1, 'while "\n"=~/^.*/mg should match only once';
1238     }
1239
1240     { # [perl #111174]
1241         use re '/u';
1242         like "\xe0", qr/(?i:\xc0)/, "(?i: shouldn't lose the passed in /u";
1243         use re '/a';
1244         unlike "\x{100}", qr/(?i:\w)/, "(?i: shouldn't lose the passed in /a";
1245         use re '/aa';
1246         unlike 'k', qr/(?i:\N{KELVIN SIGN})/, "(?i: shouldn't lose the passed in /aa";
1247     }
1248
1249     {
1250         # the test for whether the pattern should be re-compiled should
1251         # consider the UTF8ness of the previous and current pattern
1252         # string, as well as the physical bytes of the pattern string
1253
1254         for my $s ("\xc4\x80", "\x{100}") {
1255             ok($s =~ /^$s$/, "re-compile check is UTF8-aware");
1256         }
1257     }
1258
1259     #  #113682 more overloading and qr//
1260     # when doing /foo$overloaded/, if $overloaded returns
1261     # a qr/(?{})/ via qr or "" overloading, then 'use re 'eval'
1262     # shouldn't be required. Via '.', it still is.
1263     {
1264         package Qr0;
1265         use overload 'qr' => sub { qr/(??{50})/ };
1266
1267         package Qr1;
1268         use overload '""' => sub { qr/(??{51})/ };
1269
1270         package Qr2;
1271         use overload '.'  => sub { $_[1] . qr/(??{52})/ };
1272
1273         package Qr3;
1274         use overload '""' => sub { qr/(??{7})/ },
1275                      '.'  => sub { $_[1] . qr/(??{53})/ };
1276
1277         package Qr_indirect;
1278         use overload '""'  => sub { $_[0][0] };
1279
1280         package main;
1281
1282         for my $i (0..3) {
1283             my $o = bless [], "Qr$i";
1284             if ((0,0,1,1)[$i]) {
1285                 eval { "A5$i" =~ /^A$o$/ };
1286                 like($@, qr/Eval-group not allowed/, "Qr$i");
1287                 eval { "5$i" =~ /$o/ };
1288                 like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
1289                         "Qr$i bare");
1290                 {
1291                     use re 'eval';
1292                     ok("A5$i" =~ /^A$o$/, "Qr$i - with use re eval");
1293                     eval { "5$i" =~ /$o/ };
1294                     like($@, ($i == 3 ? qr/^$/ : qr/no method found,/),
1295                             "Qr$i bare - with use re eval");
1296                 }
1297             }
1298             else {
1299                 ok("A5$i" =~ /^A$o$/, "Qr$i");
1300                 ok("5$i" =~ /$o/, "Qr$i bare");
1301             }
1302         }
1303
1304         my $o = bless [ bless [], "Qr1" ], 'Qr_indirect';
1305         ok("A51" =~ /^A$o/, "Qr_indirect");
1306         ok("51" =~ /$o/, "Qr_indirect bare");
1307     }
1308
1309     {   # Various flags weren't being set when a [] is optimized into an
1310         # EXACTish node
1311         ;
1312         ;
1313         ok("\x{017F}\x{017F}" =~ qr/^[\x{00DF}]?$/i, "[] to EXACTish optimization");
1314     }
1315
1316     {
1317         for my $char (":", "\x{f7}", "\x{2010}") {
1318             my $utf8_char = $char;
1319             utf8::upgrade($utf8_char);
1320             my $display = $char;
1321             $display = display($display);
1322             my $utf8_display = "utf8::upgrade(\"$display\")";
1323
1324             like($char, qr/^$char?$/, "\"$display\" =~ /^$display?\$/");
1325             like($char, qr/^$utf8_char?$/, "my \$p = \"$display\"; utf8::upgrade(\$p); \"$display\" =~ /^\$p?\$/");
1326             like($utf8_char, qr/^$char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); \"\$c\" =~ /^$display?\$/");
1327             like($utf8_char, qr/^$utf8_char?$/, "my \$c = \"$display\"; utf8::upgrade(\$c); my \$p = \"$display\"; utf8::upgrade(\$p); \"\$c\" =~ /^\$p?\$/");
1328         }
1329     }
1330
1331     {
1332         # #116148: Pattern utf8ness sticks around globally
1333         # the utf8 in the first match was sticking around for the second
1334         # match
1335
1336         use feature 'unicode_strings';
1337
1338         my $x = "\x{263a}";
1339         $x =~ /$x/;
1340
1341         my $text = "Perl";
1342         ok("Perl" =~ /P.*$/i, '#116148');
1343     }
1344
1345     { # 117327: Sequence (?#...) not recognized in regex
1346       # The space between the '(' and '?' is now deprecated; this test should
1347       # be removed when the deprecation is made fatal.
1348         no warnings;
1349         like("ab", qr/a( ?#foo)b/x);
1350     }
1351
1352
1353 } # End of sub run_tests
1354
1355 1;