This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Skip t/re/pat_{advanced,rt_report}.t under minitest, as they use %- and %+
[perl5.git] / t / re / pat_rt_report.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
12 sub run_tests;
13
14 $| = 1;
15
16
17 BEGIN {
18     if (!defined &DynaLoader::boot_DynaLoader) {
19         print "1..0 # Skip miniperl can't load Tie::Hash::NamedCapture, need for %+ and %-\n";
20         exit 0;
21     }
22     chdir 't' if -d 't';
23     @INC = ('../lib','.');
24     do "re/ReTest.pl" or die $@;
25 }
26
27
28 plan tests => 2514;  # Update this when adding/deleting tests.
29
30 run_tests() unless caller;
31
32 #
33 # Tests start here.
34 #
35 sub run_tests {
36
37
38     {
39         local $BugId = '20000731.001';
40         ok "A \x{263a} B z C" =~ /A . B (??{ "z" }) C/,
41            "Match UTF-8 char in presence of (??{ })";
42     }
43
44
45     {
46         local $BugId = '20001021.005';
47         no warnings 'uninitialized';
48         ok undef =~ /^([^\/]*)(.*)$/, "Used to cause a SEGV";
49     }
50
51     {
52         local $Message = 'bug id 20001008.001';
53
54         my @x = ("stra\337e 138", "stra\337e 138");
55         for (@x) {
56             ok s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
57             ok my ($latin) = /^(.+)(?:\s+\d)/;
58             iseq $latin, "stra\337e";
59             ok $latin =~ s/stra\337e/straße/;
60             #
61             # Previous code follows, but outcommented - there were no tests.
62             #
63             # $latin =~ s/stra\337e/straße/; # \303\237 after the 2nd a
64             # use utf8; # needed for the raw UTF-8
65             # $latin =~ s!(s)tr(?:aß|s+e)!$1tr.!; # \303\237 after the a
66         }
67     }
68
69
70     {
71         local $BugId   = '20001028.003';
72
73         # Fist half of the bug.
74         local $Message = 'HEBREW ACCENT QADMA matched by .*';
75         my $X = chr (1448);
76         ok my ($Y) = $X =~ /(.*)/;
77         iseq $Y, v1448;
78         iseq length ($Y), 1;
79
80         # Second half of the bug.
81         $Message = 'HEBREW ACCENT QADMA in replacement';
82         $X = '';
83         $X =~ s/^/chr(1488)/e;
84         iseq length $X, 1;
85         iseq ord ($X), 1488;
86     }
87
88
89     {   
90         local $BugId   = '20001108.001';
91         local $Message = 'Repeated s///';
92         my $X = "Szab\x{f3},Bal\x{e1}zs";
93         my $Y = $X;
94         $Y =~ s/(B)/$1/ for 0 .. 3;
95         iseq $Y, $X;
96         iseq $X, "Szab\x{f3},Bal\x{e1}zs";
97     }
98
99
100     {
101         local $BugId   = '20000517.001';
102         local $Message = 's/// on UTF-8 string';
103         my $x = "\x{100}A";
104         $x =~ s/A/B/;
105         iseq $x, "\x{100}B";
106         iseq length $x, 2;
107     }
108
109
110     {
111         local $BugId   = '20001230.002';
112         local $Message = '\C and É';
113         ok "École" =~ /^\C\C(.)/ && $1 eq 'c';
114         ok "École" =~ /^\C\C(c)/;
115     }
116
117
118     {
119         # The original bug report had 'no utf8' here but that was irrelevant.
120         local $BugId   = '20010306.008';
121         local $Message = "Don't dump core";
122         my $a = "a\x{1234}";
123         ok $a =~ m/\w/;  # used to core dump.
124     }
125
126
127     {
128         local $BugId = '20010410.006';
129         local $Message = '/g in scalar context';
130         for my $rx ('/(.*?)\{(.*?)\}/csg',
131                     '/(.*?)\{(.*?)\}/cg',
132                     '/(.*?)\{(.*?)\}/sg',
133                     '/(.*?)\{(.*?)\}/g',
134                     '/(.+?)\{(.+?)\}/csg',) {
135             my $i = 0;
136             my $input = "a{b}c{d}";
137             eval <<"            --";
138                 while (eval \$input =~ $rx) {
139                     \$i ++;
140                 }
141             --
142             iseq $i, 2;
143         }
144     }
145
146     {
147         local $BugId = "20010619.003";
148         # Amazingly vertical tabulator is the same in ASCII and EBCDIC.
149         for ("\n", "\t", "\014", "\r") {
150             ok !/[[:print:]]/, "'$_' not in [[:print:]]";
151         }
152         for (" ") {
153             ok  /[[:print:]]/, "'$_' in [[:print:]]";
154         }
155     }
156
157
158
159     {
160         # [ID 20010814.004] pos() doesn't work when using =~m// in list context
161         local $BugId = '20010814.004';
162         $_ = "ababacadaea";
163         my $a = join ":", /b./gc;
164         my $b = join ":", /a./gc;
165         my $c = pos;
166         iseq "$a $b $c", 'ba:ba ad:ae 10', "pos() works with () = m//";
167     }
168
169
170     {
171         # [ID 20010407.006] matching utf8 return values from
172         # functions does not work
173         local $BugId   = '20010407.006';
174         local $Message = 'UTF-8 return values from functions';
175         package ID_20010407_006;
176         sub x {"a\x{1234}"}
177         my $x = x;
178         my $y;
179       ::ok $x =~ /(..)/;
180         $y = $1;
181       ::ok length ($y) == 2 && $y eq $x;
182       ::ok x =~ /(..)/;
183         $y = $1;
184       ::ok length ($y) == 2 && $y eq $x;
185     }
186
187     {
188         # High bit bug -- japhy
189         my $x = "ab\200d";
190         ok $x =~ /.*?\200/, "High bit fine";
191     }
192
193
194     {
195         local $Message = 'UTF-8 hash keys and /$/';
196         # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters
197         #                                         /2002-01/msg01327.html
198
199         my $u = "a\x{100}";
200         my $v = substr ($u, 0, 1);
201         my $w = substr ($u, 1, 1);
202         my %u = ($u => $u, $v => $v, $w => $w);
203         for (keys %u) {
204             my $m1 =            /^\w*$/ ? 1 : 0;
205             my $m2 = $u {$_} =~ /^\w*$/ ? 1 : 0;
206             iseq $m1, $m2;
207         }
208     }
209
210
211     {
212         local $BugId   = "20020124.005";
213         local $PatchId = "14795";
214         local $Message = "s///eg";
215
216         for my $char ("a", "\x{df}", "\x{100}") {
217             my $x = "$char b $char";
218             $x =~ s{($char)}{
219                   "c" =~ /c/;
220                   "x";
221             }ge;
222             iseq substr ($x, 0, 1), substr ($x, -1, 1);
223         }
224     }
225
226
227     {
228         local $BugId = "20020412.005";
229         local $Message = "Correct pmop flags checked when empty pattern";
230
231         # Requires reuse of last successful pattern.
232         my $num = 123;
233         $num =~ /\d/;
234         for (0 .. 1) {
235             my $match = m?? + 0;
236             ok $match != $_, $Message, 
237                 sprintf "'match one' %s on %s iteration" =>
238                                $match ? 'succeeded' : 'failed',
239                                $_     ? 'second'    : 'first';
240         }
241         $num =~ /(\d)/;
242         my $result = join "" => $num =~ //g;
243         iseq $result, $num;
244     }
245
246
247     {
248         local $BugId   = '20020630.002';
249         local $Message = 'UTF-8 regex matches above 32k';
250         for (['byte', "\x{ff}"], ['utf8', "\x{1ff}"]) {
251             my ($type, $char) = @$_;
252             for my $len (32000, 32768, 33000) {
253                 my  $s = $char . "f" x $len;
254                 my  $r = $s =~ /$char([f]*)/gc;
255                 ok  $r, $Message, "<$type x $len>";
256                 ok !$r || pos ($s) == $len + 1, $Message,
257                         "<$type x $len>; pos = @{[pos $s]}";
258             }
259         }
260     }
261
262     {
263         local $PatchId = '18179';
264         my $s = "\x{100}" x 5;
265         my $ok = $s =~ /(\x{100}{4})/;
266         my ($ord, $len) = (ord $1, length $1);
267         ok $ok && $ord == 0x100 && $len == 4, "No panic: end_shift";
268     }
269
270
271     {
272         local $BugId = '15763';
273         our $a = "x\x{100}";
274         chop $a;    # Leaves the UTF-8 flag
275         $a .= "y";  # 1 byte before 'y'.
276
277         ok $a =~ /^\C/,        'match one \C on 1-byte UTF-8';
278         ok $a =~ /^\C{1}/,     'match \C{1}';
279
280         ok $a =~ /^\Cy/,       'match \Cy';
281         ok $a =~ /^\C{1}y/,    'match \C{1}y';
282
283         ok $a !~ /^\C\Cy/,     q {don't match two \Cy};
284         ok $a !~ /^\C{2}y/,    q {don't match \C{2}y};
285
286         $a = "\x{100}y"; # 2 bytes before "y"
287
288         ok $a =~ /^\C/,        'match one \C on 2-byte UTF-8';
289         ok $a =~ /^\C{1}/,     'match \C{1}';
290         ok $a =~ /^\C\C/,      'match two \C';
291         ok $a =~ /^\C{2}/,     'match \C{2}';
292
293         ok $a =~ /^\C\C\C/,    'match three \C on 2-byte UTF-8 and a byte';
294         ok $a =~ /^\C{3}/,     'match \C{3}';
295
296         ok $a =~ /^\C\Cy/,     'match two \C';
297         ok $a =~ /^\C{2}y/,    'match \C{2}';
298
299         ok $a !~ /^\C\C\Cy/,   q {don't match three \Cy};
300         ok $a !~ /^\C{2}\Cy/,  q {don't match \C{2}\Cy};
301         ok $a !~ /^\C{3}y/,    q {don't match \C{3}y};
302
303         $a = "\x{1000}y"; # 3 bytes before "y"
304
305         ok $a =~ /^\C/,        'match one \C on three-byte UTF-8';
306         ok $a =~ /^\C{1}/,     'match \C{1}';
307         ok $a =~ /^\C\C/,      'match two \C';
308         ok $a =~ /^\C{2}/,     'match \C{2}';
309         ok $a =~ /^\C\C\C/,    'match three \C';
310         ok $a =~ /^\C{3}/,     'match \C{3}';
311
312         ok $a =~ /^\C\C\C\C/,  'match four \C on three-byte UTF-8 and a byte';
313         ok $a =~ /^\C{4}/,     'match \C{4}';
314
315         ok $a =~ /^\C\C\Cy/,   'match three \Cy';
316         ok $a =~ /^\C{3}y/,    'match \C{3}y';
317
318         ok $a !~ /^\C\C\C\Cy/, q {don't match four \Cy};
319         ok $a !~ /^\C{4}y/,    q {don't match \C{4}y};
320     }
321
322     
323     {
324         local $BugId   = '15397';
325         local $Message = 'UTF-8 matching';
326         ok "\x{100}" =~ /\x{100}/;
327         ok "\x{100}" =~ /(\x{100})/;
328         ok "\x{100}" =~ /(\x{100}){1}/;
329         ok "\x{100}\x{100}" =~ /(\x{100}){2}/;
330         ok "\x{100}\x{100}" =~ /(\x{100})(\x{100})/;
331     }
332
333
334     {
335         local $BugId   = '7471';
336         local $Message = 'Neither ()* nor ()*? sets $1 when matched 0 times';
337         local $_       = 'CD';
338         ok /(AB)*?CD/ && !defined $1;
339         ok /(AB)*CD/  && !defined $1;
340     }
341
342
343     {
344         local $BugId   = '3547';
345         local $Message = "Caching shouldn't prevent match";
346         my $pattern = "^(b+?|a){1,2}c";
347         ok "bac"    =~ /$pattern/ && $1 eq 'a';
348         ok "bbac"   =~ /$pattern/ && $1 eq 'a';
349         ok "bbbac"  =~ /$pattern/ && $1 eq 'a';
350         ok "bbbbac" =~ /$pattern/ && $1 eq 'a';
351     }
352
353
354
355     {
356         local $BugId   = '18232';
357         local $Message = '$1 should keep UTF-8 ness';
358         ok "\x{100}" =~ /(.)/;
359         iseq  $1, "\x{100}",  '$1 is UTF-8';
360         { 'a' =~ /./; }
361         iseq  $1, "\x{100}",  '$1 is still UTF-8';
362         isneq $1, "\xC4\x80", '$1 is not non-UTF-8';
363     }
364
365
366     {
367         local $BugId   = '19767';
368         local $Message = "Optimizer doesn't prematurely reject match";
369         use utf8;
370
371         my $attr = 'Name-1';
372         my $NormalChar      = qr /[\p{IsDigit}\p{IsLower}\p{IsUpper}]/;
373         my $NormalWord      = qr /${NormalChar}+?/;
374         my $PredNameHyphen  = qr /^${NormalWord}(\-${NormalWord})*?$/;
375
376         $attr =~ /^$/;
377         ok $attr =~ $PredNameHyphen;  # Original test.
378
379         "a" =~ m/[b]/;
380         ok "0" =~ /\p{N}+\z/;         # Variant.
381     }
382
383
384     {
385         local $BugId   = '20683';
386         local $Message = "(??{ }) doesn't return stale values";
387         our $p = 1;
388         foreach (1, 2, 3, 4) {
389             $p ++ if /(??{ $p })/
390         }
391         iseq $p, 5;
392
393         {
394             package P;
395             $a = 1;
396             sub TIESCALAR {bless []}
397             sub FETCH     {$a ++}
398         }
399         tie $p, "P";
400         foreach (1, 2, 3, 4) {
401             /(??{ $p })/
402         }
403         iseq $p, 5;
404     }
405
406
407     {
408         # Subject: Odd regexp behavior
409         # From: Markus Kuhn <Markus.Kuhn@cl.cam.ac.uk>
410         # Date: Wed, 26 Feb 2003 16:53:12 +0000
411         # Message-Id: <E18o4nw-0008Ly-00@wisbech.cl.cam.ac.uk>
412         # To: perl-unicode@perl.org
413
414         local $Message = 'Markus Kuhn 2003-02-26';
415     
416         my $x = "\x{2019}\nk";
417         ok $x =~ s/(\S)\n(\S)/$1 $2/sg;
418         ok $x eq "\x{2019} k";
419
420         $x = "b\nk";
421         ok $x =~ s/(\S)\n(\S)/$1 $2/sg;
422         ok $x eq "b k";
423
424         ok "\x{2019}" =~ /\S/;
425     }
426
427
428     {
429         local $BugId = '21411';
430         local $Message = "(??{ .. }) in split doesn't corrupt its stack";
431         our $i;
432         ok '-1-3-5-' eq join '', split /((??{$i++}))/, '-1-3-5-';
433         no warnings 'syntax';
434         @_ = split /(?{'WOW'})/, 'abc';
435         local $" = "|";
436         iseq "@_", "a|b|c";
437     }
438
439
440     {
441         # XXX DAPM 13-Apr-06. Recursive split is still broken. It's only luck it
442         # hasn't been crashing. Disable this test until it is fixed properly.
443         # XXX also check what it returns rather than just doing ok(1,...)
444         # split /(?{ split "" })/, "abc";
445         local $TODO = "Recursive split is still broken";
446         ok 0, 'cache_re & "(?{": it dumps core in 5.6.1 & 5.8.0';
447     }
448
449
450     {
451         local $BugId = '17757';
452         $_ = "code:   'x' { '...' }\n"; study;
453         my @x; push @x, $& while m/'[^\']*'/gx;
454         local $" = ":";
455         iseq "@x", "'x':'...'", "Parse::RecDescent triggered infinite loop";
456     }
457
458
459     {
460         local $BugId = '22354';
461         sub func ($) {
462             ok "a\nb" !~ /^b/,  "Propagated modifier; $_[0]";
463             ok "a\nb" =~ /^b/m, "Propagated modifier; $_[0] - with /m";
464         }
465         func "standalone";
466         $_ = "x"; s/x/func "in subst"/e;
467         $_ = "x"; s/x/func "in multiline subst"/em;
468         $_ = "x"; /x(?{func "in regexp"})/;
469         $_ = "x"; /x(?{func "in multiline regexp"})/m;
470     }
471
472
473     {
474         local $BugId = '19049';
475         $_    = "abcdef\n";
476         my @x = m/./g;
477         iseq "abcde", $`, 'Global match sets $`';
478     }
479
480
481     {
482         # [perl #23769] Unicode regex broken on simple example
483         # regrepeat() didn't handle UTF-8 EXACT case right.
484         local $BugId   = '23769';
485         my $Mess       = 'regrepeat() handles UTF-8 EXACT case right';
486         local $Message = $Mess;
487
488         my $s = "\x{a0}\x{a0}\x{a0}\x{100}"; chop $s;
489
490         ok $s =~ /\x{a0}/;
491         ok $s =~ /\x{a0}+/;
492         ok $s =~ /\x{a0}\x{a0}/;
493
494         $Message = "$Mess (easy variant)";
495         ok "aaa\x{100}" =~ /(a+)/;
496         iseq $1, "aaa";
497
498         $Message = "$Mess (easy invariant)";
499         ok "aaa\x{100}     " =~ /(a+?)/;
500         iseq $1, "a";
501
502         $Message = "$Mess (regrepeat variant)";
503         ok "\xa0\xa0\xa0\x{100}    " =~ /(\xa0+?)/;
504         iseq $1, "\xa0";
505
506         $Message = "$Mess (regrepeat invariant)";
507         ok "\xa0\xa0\xa0\x{100}" =~ /(\xa0+)/;
508         iseq $1, "\xa0\xa0\xa0";
509
510         $Message = "$Mess (hard variant)";
511         ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+?)/;
512         iseq $1, "\xa0\xa1";
513
514         $Message = "$Mess (hard invariant)";
515         ok "ababab\x{100}  " =~ /((?:ab)+)/;
516         iseq $1, 'ababab';
517
518         ok "\xa0\xa1\xa0\xa1\xa0\xa1\x{100}" =~ /((?:\xa0\xa1)+)/;
519         iseq $1, "\xa0\xa1\xa0\xa1\xa0\xa1";
520
521         ok "ababab\x{100}  " =~ /((?:ab)+?)/;
522         iseq $1, "ab";
523
524         $Message = "Don't match first byte of UTF-8 representation";
525         ok "\xc4\xc4\xc4" !~ /(\x{100}+)/;
526         ok "\xc4\xc4\xc4" !~ /(\x{100}+?)/;
527         ok "\xc4\xc4\xc4" !~ /(\x{100}++)/;
528     }
529
530
531     {
532         # perl panic: pp_match start/end pointers
533         local $BugId = '25269';
534         iseq "a-bc", eval {my ($x, $y) = "bca" =~ /^(?=.*(a)).*(bc)/; "$x-$y"},
535              'Captures can move backwards in string';
536     }
537
538
539     {
540         local $BugId   = '27940'; # \cA not recognized in character classes
541         ok "a\cAb" =~ /\cA/, '\cA in pattern';
542         ok "a\cAb" =~ /[\cA]/, '\cA in character class';
543         ok "a\cAb" =~ /[\cA-\cB]/, '\cA in character class range';
544         ok "abc" =~ /[^\cA-\cB]/, '\cA in negated character class range';
545         ok "a\cBb" =~ /[\cA-\cC]/, '\cB in character class range';
546         ok "a\cCbc" =~ /[^\cA-\cB]/, '\cC in negated character class range';
547         ok "a\cAb" =~ /(??{"\cA"})/, '\cA in ??{} pattern';
548         ok "ab" !~ /a\cIb/x, '\cI in pattern';
549     }
550
551
552     {
553         # perl #28532: optional zero-width match at end of string is ignored
554         local $BugId = '28532';
555         ok "abc" =~ /^abc(\z)?/ && defined($1),
556            'Optional zero-width match at end of string';
557         ok "abc" =~ /^abc(\z)??/ && !defined($1),
558            'Optional zero-width match at end of string';
559     }
560
561
562
563     {
564         local $BugId = '36207';
565         my $utf8 = "\xe9\x{100}"; chop $utf8;
566         my $latin1 = "\xe9";
567
568         ok $utf8 =~ /\xe9/i, "utf8/latin";
569         ok $utf8 =~ /$latin1/i, "utf8/latin runtime";
570         ok $utf8 =~ /(abc|\xe9)/i, "utf8/latin trie";
571         ok $utf8 =~ /(abc|$latin1)/i, "utf8/latin trie runtime";
572
573         ok "\xe9" =~ /$utf8/i, "latin/utf8";
574         ok "\xe9" =~ /(abc|$utf8)/i, "latin/utf8 trie";
575         ok $latin1 =~ /$utf8/i, "latin/utf8 runtime";
576         ok $latin1 =~ /(abc|$utf8)/i, "latin/utf8 trie runtime";
577     }
578
579
580     {
581         local $BugId = '37038';
582         my $s = "abcd";
583         $s =~ /(..)(..)/g;
584         $s = $1;
585         $s = $2;
586         iseq $2, 'cd',
587              "Assigning to original string does not corrupt match vars";
588     }
589
590
591     {
592         local $PatchId = '26410';
593         {
594             package wooosh;
595             sub gloople {"!"}
596         }
597         my $aeek = bless {} => 'wooosh';
598         eval_ok sub {$aeek -> gloople () =~ /(.)/g},
599                "//g match against return value of sub";
600
601         sub gloople {"!"}
602         eval_ok sub {gloople () =~ /(.)/g},
603                "26410 didn't affect sub calls for some reason";
604     }
605
606
607     {
608         local $TODO = "See changes 26925-26928, which reverted change 26410";
609         {
610             package lv;
611             our $var = "abc";
612             sub variable : lvalue {$var}
613         }
614         my $o = bless [] => 'lv';
615         my $f = "";
616         my $r = eval {
617             for (1 .. 2) {
618                 $f .= $1 if $o -> variable =~ /(.)/g;
619             }
620             1;
621         };
622         if ($r) {
623             iseq $f, "ab", "pos() retained between calls";
624         }
625         else {
626             local $TODO;
627             ok 0, "Code failed: $@";
628         }
629
630         our $var = "abc";
631         sub variable : lvalue {$var}
632         my $g = "";
633         my $s = eval {
634             for (1 .. 2) {
635                 $g .= $1 if variable =~ /(.)/g;
636             }
637             1;
638         };
639         if ($s) {
640             iseq $g, "ab", "pos() retained between calls";
641         }
642         else {
643             local $TODO;
644             ok 0, "Code failed: $@";
645         }
646     }
647
648
649   SKIP:
650     {
651         local $BugId = '37836';
652         skip "In EBCDIC" if $IS_EBCDIC;
653         no warnings 'utf8';
654         $_ = pack 'U0C2', 0xa2, 0xf8;  # Ill-formed UTF-8
655         my $ret = 0;
656         eval_ok sub {!($ret = s/[\0]+//g)},
657                 "Ill-formed UTF-8 doesn't match NUL in class";
658     }
659
660
661     {
662         # chr(65535) should be allowed in regexes
663         local $BugId = '38293';
664         no warnings 'utf8'; # To allow non-characters
665         my ($c, $r, $s);
666
667         $c = chr 0xffff;
668         $c =~ s/$c//g;
669         ok $c eq "", "U+FFFF, parsed as atom";
670
671         $c = chr 0xffff;
672         $r = "\\$c";
673         $c =~ s/$r//g;
674         ok $c eq "", "U+FFFF backslashed, parsed as atom";
675
676         $c = chr 0xffff;
677         $c =~ s/[$c]//g;
678         ok $c eq "", "U+FFFF, parsed in class";
679
680         $c = chr 0xffff;
681         $r = "[\\$c]";
682         $c =~ s/$r//g;
683         ok $c eq "", "U+FFFF backslashed, parsed in class";
684
685         $s = "A\x{ffff}B";
686         $s =~ s/\x{ffff}//i;
687         ok $s eq "AB", "U+FFFF, EXACTF";
688
689         $s = "\x{ffff}A";
690         $s =~ s/\bA//;
691         ok $s eq "\x{ffff}", "U+FFFF, BOUND";
692
693         $s = "\x{ffff}!";
694         $s =~ s/\B!//;
695         ok $s eq "\x{ffff}", "U+FFFF, NBOUND";
696     }
697
698
699     {
700         local $BugId = '39583';
701         
702         # The printing characters
703         my @chars = ("A" .. "Z");
704         my $delim = ",";
705         my $size = 32771 - 4;
706         my $str = '';
707
708         # Create some random junk. Inefficient, but it works.
709         for (my $i = 0; $i < $size; $ i++) {
710             $str .= $chars [rand @chars];
711         }
712
713         $str .= ($delim x 4);
714         my $res;
715         my $matched;
716         ok $str =~ s/^(.*?)${delim}{4}//s, "Pattern matches";
717         iseq $str, "", "Empty string";
718         ok defined $1 && length ($1) == $size, '$1 is correct size';
719     }
720
721
722     {
723         local $BugId = '27940';
724         ok "\0-A"  =~ /\c@-A/, '@- should not be interpolated in a pattern';
725         ok "\0\0A" =~ /\c@+A/, '@+ should not be interpolated in a pattern';
726         ok "X\@-A"  =~ /X@-A/, '@- should not be interpolated in a pattern';
727         ok "X\@\@A" =~ /X@+A/, '@+ should not be interpolated in a pattern';
728
729         ok "X\0A" =~ /X\c@?A/,  '\c@?';
730         ok "X\0A" =~ /X\c@*A/,  '\c@*';
731         ok "X\0A" =~ /X\c@(A)/, '\c@(';
732         ok "X\0A" =~ /X(\c@)A/, '\c@)';
733         ok "X\0A" =~ /X\c@|ZA/, '\c@|';
734
735         ok "X\@A" =~ /X@?A/,  '@?';
736         ok "X\@A" =~ /X@*A/,  '@*';
737         ok "X\@A" =~ /X@(A)/, '@(';
738         ok "X\@A" =~ /X(@)A/, '@)';
739         ok "X\@A" =~ /X@|ZA/, '@|';
740
741         local $" = ','; # non-whitespace and non-RE-specific
742         ok 'abc' =~ /(.)(.)(.)/, 'The last successful match is bogus';
743         ok "A@+B"  =~ /A@{+}B/,  'Interpolation of @+ in /@{+}/';
744         ok "A@-B"  =~ /A@{-}B/,  'Interpolation of @- in /@{-}/';
745         ok "A@+B"  =~ /A@{+}B/x, 'Interpolation of @+ in /@{+}/x';
746         ok "A@-B"  =~ /A@{-}B/x, 'Interpolation of @- in /@{-}/x';
747     }
748
749
750     {
751         local $BugId = '50496';
752         my $s = 'foo bar baz';
753         my (@k, @v, @fetch, $res);
754         my $count = 0;
755         my @names = qw ($+{A} $+{B} $+{C});
756         if ($s =~ /(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/) {
757             while (my ($k, $v) = each (%+)) {
758                 $count++;
759             }
760             @k = sort keys   (%+);
761             @v = sort values (%+);
762             $res = 1;
763             push @fetch,
764                 ["$+{A}", "$1"],
765                 ["$+{B}", "$2"],
766                 ["$+{C}", "$3"],
767             ;
768         } 
769         foreach (0 .. 2) {
770             if ($fetch [$_]) {
771                 iseq $fetch [$_] [0], $fetch [$_] [1], $names [$_];
772             } else {
773                 ok 0, $names[$_];
774             }
775         }
776         iseq $res, 1, "'$s' =~ /(?<A>foo)\\s+(?<B>bar)?\\s+(?<C>baz)/";
777         iseq $count, 3, "Got 3 keys in %+ via each";
778         iseq 0 + @k, 3, 'Got 3 keys in %+ via keys';
779         iseq "@k", "A B C", "Got expected keys";
780         iseq "@v", "bar baz foo", "Got expected values";
781         eval '
782             no warnings "uninitialized";
783             print for $+ {this_key_doesnt_exist};
784         ';
785         ok !$@, 'lvalue $+ {...} should not throw an exception';
786     }
787
788
789     {
790         #
791         # Almost the same as the block above, except that the capture is nested.
792         #
793         local $BugId = '50496';
794         my $s = 'foo bar baz';
795         my (@k, @v, @fetch, $res);
796         my $count = 0;
797         my @names = qw ($+{A} $+{B} $+{C} $+{D});
798         if ($s =~ /(?<D>(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz))/) {
799             while (my ($k,$v) = each(%+)) {
800                 $count++;
801             }
802             @k = sort keys   (%+);
803             @v = sort values (%+);
804             $res = 1;
805             push @fetch,
806                 ["$+{A}", "$2"],
807                 ["$+{B}", "$3"],
808                 ["$+{C}", "$4"],
809                 ["$+{D}", "$1"],
810             ;
811         }
812         foreach (0 .. 3) {
813             if ($fetch [$_]) {
814                 iseq $fetch [$_] [0], $fetch [$_] [1], $names [$_];
815             } else {
816                 ok 0, $names [$_];
817             }
818         }
819         iseq $res, 1, "'$s' =~ /(?<D>(?<A>foo)\\s+(?<B>bar)?\\s+(?<C>baz))/";
820         iseq $count, 4, "Got 4 keys in %+ via each";
821         iseq @k, 4, 'Got 4 keys in %+ via keys';
822         iseq "@k", "A B C D", "Got expected keys";
823         iseq "@v", "bar baz foo foo bar baz", "Got expected values";
824         eval '
825             no warnings "uninitialized";
826             print for $+ {this_key_doesnt_exist};
827         ';
828         ok !$@,'lvalue $+ {...} should not throw an exception';
829     }
830
831
832     {
833         local $BugId = '36046';
834         my $str = 'abc'; 
835         my $count = 0;
836         my $mval = 0;
837         my $pval = 0;
838         while ($str =~ /b/g) {$mval = $#-; $pval = $#+; $count ++}
839         iseq $mval,  0, '@- should be empty';
840         iseq $pval,  0, '@+ should be empty';
841         iseq $count, 1, 'Should have matched once only';
842     }
843
844
845
846
847     {
848         local $BugId = '40684';
849         local $Message = '/m in precompiled regexp';
850         my $s = "abc\ndef";
851         my $rex = qr'^abc$'m;
852         ok $s =~ m/$rex/;
853         ok $s =~ m/^abc$/m;
854     }
855
856
857     {
858         local $BugId   = '36909';
859         local $Message = '(?: ... )? should not lose $^R';
860         $^R = 'Nothing';
861         {
862             local $^R = "Bad";
863             ok 'x foofoo y' =~ m {
864                       (foo) # $^R correctly set
865                       (?{ "last regexp code result" })
866             }x;
867             iseq $^R, 'last regexp code result';
868         }
869         iseq $^R, 'Nothing';
870
871         {
872             local $^R = "Bad";
873
874             ok 'x foofoo y' =~ m {
875                       (?:foo|bar)+ # $^R correctly set
876                       (?{ "last regexp code result" })
877             }x;
878             iseq $^R, 'last regexp code result';
879         }
880         iseq $^R, 'Nothing';
881
882         {
883             local $^R = "Bad";
884             ok 'x foofoo y' =~ m {
885                       (foo|bar)\1+ # $^R undefined
886                       (?{ "last regexp code result" })
887             }x;
888             iseq $^R, 'last regexp code result';
889         }
890         iseq $^R, 'Nothing';
891
892         {
893             local $^R = "Bad";
894             ok 'x foofoo y' =~ m {
895                       (foo|bar)\1 # This time without the +
896                       (?{"last regexp code result"})
897             }x;
898             iseq $^R, 'last regexp code result';
899         }
900         iseq $^R, 'Nothing';
901     }
902
903
904     {
905         local $BugId   = '22395';
906         local $Message = 'Match is linear, not quadratic';
907         our $count;
908         for my $l (10, 100, 1000) {
909             $count = 0;
910             ('a' x $l) =~ /(.*)(?{$count++})[bc]/;
911             local $TODO = "Should be L+1 not L*(L+3)/2 (L=$l)";
912             iseq $count, $l + 1;
913         }
914     }
915
916
917     {
918         local $BugId   = '22614';
919         local $Message = '@-/@+ should not have undefined values';
920         local $_ = 'ab';
921         our @len = ();
922         /(.){1,}(?{push @len,0+@-})(.){1,}(?{})^/;
923         iseq "@len", "2 2 2";
924     }
925
926
927     {
928         local $BugId   = '18209';
929         local $Message = '$& set on s///';
930         my $text = ' word1 word2 word3 word4 word5 word6 ';
931
932         my @words = ('word1', 'word3', 'word5');
933         my $count;
934         foreach my $word (@words) {
935             $text =~ s/$word\s//gi; # Leave a space to separate words
936                                     # in the resultant str.
937             # The following block is not working.
938             if ($&) {
939                 $count ++;
940             }
941             # End bad block
942         }
943         iseq $count, 3;
944         iseq $text, ' word2 word4 word6 ';
945     }
946
947
948     {
949         # RT#6893
950         local $BugId = '6893';
951         local $_ = qq (A\nB\nC\n); 
952         my @res;
953         while (m#(\G|\n)([^\n]*)\n#gsx) { 
954             push @res, "$2"; 
955             last if @res > 3;
956         }
957         iseq "@res", "A B C", "/g pattern shouldn't infinite loop";
958     }
959
960
961
962     {
963         local $BugId   = '41010';
964         local $Message = 'No optimizer bug';
965         my @tails  = ('', '(?(1))', '(|)', '()?');    
966         my @quants = ('*','+');
967         my $doit = sub {
968             my $pats = shift;
969             for (@_) {
970                 for my $pat (@$pats) {
971                     for my $quant (@quants) {
972                         for my $tail (@tails) {
973                             my $re = "($pat$quant\$)$tail";
974                             ok /$re/  && $1 eq $_, "'$_' =~ /$re/";
975                             ok /$re/m && $1 eq $_, "'$_' =~ /$re/m";
976                         }
977                     }
978                 }
979             }
980         };    
981         
982         my @dpats = ('\d',
983                      '[1234567890]',
984                      '(1|[23]|4|[56]|[78]|[90])',
985                      '(?:1|[23]|4|[56]|[78]|[90])',
986                      '(1|2|3|4|5|6|7|8|9|0)',
987                      '(?:1|2|3|4|5|6|7|8|9|0)');
988         my @spats = ('[ ]', ' ', '( |\t)', '(?: |\t)', '[ \t]', '\s');
989         my @sstrs = ('  ');
990         my @dstrs = ('12345');
991         $doit -> (\@spats, @sstrs);
992         $doit -> (\@dpats, @dstrs);
993     }
994
995
996
997     {
998         local $BugId = '45605';
999         # [perl #45605] Regexp failure with utf8-flagged and byte-flagged string
1000
1001         my $utf_8 = "\xd6schel";
1002         utf8::upgrade ($utf_8);
1003         $utf_8 =~ m {(\xd6|&Ouml;)schel};
1004         iseq $1, "\xd6", "Upgrade error";
1005     }
1006
1007     {
1008         # Regardless of utf8ness any character matches itself when 
1009         # doing a case insensitive match. See also [perl #36207] 
1010         local $BugId = '36207';
1011         for my $o (0 .. 255) {
1012             my @ch = (chr ($o), chr ($o));
1013             utf8::upgrade ($ch [1]);
1014             for my $u_str (0, 1) {
1015                 for my $u_pat (0, 1) {
1016                     ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E/i,
1017                     "\$c =~ /\$c/i : chr ($o) : u_str = $u_str u_pat = $u_pat";
1018                     ok $ch [$u_str] =~ /\Q$ch[$u_pat]\E|xyz/i,
1019                     "\$c=~/\$c|xyz/i : chr($o) : u_str = $u_str u_pat = $u_pat";
1020                 }
1021             }
1022         }
1023     }
1024
1025
1026     {
1027          local $BugId   = '49190';
1028          local $Message = '$REGMARK in replacement';
1029          our $REGMARK;
1030          my $_ = "A";
1031          ok s/(*:B)A/$REGMARK/;
1032          iseq $_, "B";
1033          $_ = "CCCCBAA";
1034          ok s/(*:X)A+|(*:Y)B+|(*:Z)C+/$REGMARK/g;
1035          iseq $_, "ZYX";
1036     }
1037
1038
1039     {
1040         local $BugId   = '52658';
1041         local $Message = 'Substitution evaluation in list context';
1042         my $reg = '../xxx/';
1043         my @te  = ($reg =~ m{^(/?(?:\.\./)*)},
1044                    $reg =~ s/(x)/'b'/eg > 1 ? '##' : '++');
1045         iseq $reg, '../bbb/';
1046         iseq $te [0], '../';
1047     }
1048
1049     {
1050         local $BugId =  '60034';
1051         my $a = "xyzt" x 8192;
1052         ok $a =~ /\A(?>[a-z])*\z/,
1053                 '(?>) does not cause wrongness on long string';
1054         my $b = $a . chr 256;
1055         chop $b;
1056         {
1057             iseq $a, $b;
1058         }
1059         ok $b =~ /\A(?>[a-z])*\z/,
1060            '(?>) does not cause wrongness on long string with UTF-8';
1061     }
1062
1063
1064     #
1065     # Keep the following tests last -- they may crash perl
1066     #
1067     print "# Tests that follow may crash perl\n";
1068     {   
1069         local $BugId   = '19049/38869';
1070         local $Message = 'Pattern in a loop, failure should not ' .
1071                          'affect previous success';
1072         my @list = (
1073             'ab cdef',             # Matches regex
1074             ('e' x 40000 ) .'ab c' # Matches not, but 'ab c' matches part of it
1075         );
1076         my $y;
1077         my $x;
1078         foreach (@list) {
1079             m/ab(.+)cd/i; # The ignore-case seems to be important
1080             $y = $1;      # Use $1, which might not be from the last match!
1081             $x = substr ($list [0], $- [0], $+ [0] - $- [0]);
1082         }
1083         iseq $y, ' ';
1084         iseq $x, 'ab cd';
1085     }
1086
1087
1088     {
1089         local $BugId = '24274';
1090
1091         ok (("a" x (2 ** 15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker");
1092         ok ((q(a)x 100) =~ /^(??{'(.)'x 100})/, 
1093             "Regexp /^(??{'(.)'x 100})/ crashes older perls");
1094     }
1095
1096
1097     {
1098         # [perl #45337] utf8 + "[a]a{2}" + /$.../ = panic: sv_len_utf8 cache
1099         local $BugId = '45337';
1100         local ${^UTF8CACHE} = -1;
1101         local $Message = "Shouldn't panic";
1102         my $s = "[a]a{2}";
1103         utf8::upgrade $s;
1104         ok "aaa" =~ /$s/;
1105     }
1106     {
1107         local $BugId = '57042';
1108         local $Message = "Check if tree logic breaks \$^R";
1109         my $cond_re = qr/\s*
1110             \s* (?:
1111                    \( \s* A  (?{1})
1112                  | \( \s* B  (?{2})
1113                )
1114            /x;
1115         my @res;
1116         for my $line ("(A)","(B)") {
1117            if ($line =~ m/$cond_re/) {
1118                push @res, $^R ? "#$^R" : "UNDEF";
1119            }
1120         }
1121         iseq "@res","#1 #2";
1122     }
1123     {
1124         no warnings 'closure';
1125         my $re = qr/A(??{"1"})/;
1126         ok "A1B" =~ m/^((??{ $re }))((??{"B"}))$/;
1127         ok $1 eq "A1";
1128         ok $2 eq "B";
1129     }
1130
1131
1132
1133     # This only works under -DEBUGGING because it relies on an assert().
1134     {
1135         local $BugId = '60508';
1136         local $Message = "Check capture offset re-entrancy of utf8 code.";
1137
1138         sub fswash { $_[0] =~ s/([>X])//g; }
1139
1140         my $k1 = "." x 4 . ">>";
1141         fswash($k1);
1142
1143         my $k2 = "\x{f1}\x{2022}";
1144         $k2 =~ s/([\360-\362])/>/g;
1145         fswash($k2);
1146
1147         iseq($k2, "\x{2022}", "utf8::SWASHNEW doesn't cause capture leaks");
1148     }
1149
1150
1151     {
1152         local $BugId = 65372;   # minimal CURLYM limited to 32767 matches
1153         my @pat = (
1154             qr{a(x|y)*b},       # CURLYM
1155             qr{a(x|y)*?b},      # .. with minmod
1156             qr{a([wx]|[yz])*b}, # .. and without tries
1157             qr{a([wx]|[yz])*?b},
1158         );
1159         my $len = 32768;
1160         my $s = join '', 'a', 'x' x $len, 'b';
1161         for my $pat (@pat) {
1162             ok($s =~ $pat, $pat);
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         iseq($first, $second);
1176     }    
1177
1178     {
1179        local $BugId = 70998;
1180        local $Message
1181         = 'utf8 =~ /trie/ where trie matches a continuation octet';
1182
1183        # Catch warnings:
1184        my $w;
1185        local $SIG{__WARN__} = sub { $w .= shift };
1186
1187        # This bug can be reduced to
1188        qq{\x{30ab}} =~ /\xab|\xa9/;
1189        # but it's nice to have a more 'real-world' test. The original test
1190        # case from the RT ticket follows:
1191
1192        my %conv = (
1193                    "\xab"     => "&lt;",
1194                    "\xa9"     => "(c)",
1195                   );
1196        my $conv_rx = '(' . join('|', map { quotemeta } keys %conv) . ')';
1197        $conv_rx = qr{$conv_rx};
1198
1199        my $x
1200         = qq{\x{3042}\x{304b}\x{3055}\x{305f}\x{306a}\x{306f}\x{307e}}
1201         . qq{\x{3084}\x{3089}\x{308f}\x{3093}\x{3042}\x{304b}\x{3055}}
1202         . qq{\x{305f}\x{306a}\x{306f}\x{307e}\x{3084}\x{3089}\x{308f}}
1203         . qq{\x{3093}\x{30a2}\x{30ab}\x{30b5}\x{30bf}\x{30ca}\x{30cf}}
1204         . qq{\x{30de}\x{30e4}\x{30e9}\x{30ef}\x{30f3}\x{30a2}\x{30ab}}
1205         . qq{\x{30b5}\x{30bf}\x{30ca}\x{30cf}\x{30de}\x{30e4}\x{30e9}}
1206         . qq{\x{30ef}\x{30f3}\x{30a2}\x{30ab}\x{30b5}\x{30bf}\x{30ca}}
1207         . qq{\x{30cf}\x{30de}\x{30e4}\x{30e9}\x{30ef}\x{30f3}};
1208
1209        $x =~ s{$conv_rx}{$conv{$1}}eg;
1210
1211        iseq($w,undef);
1212     }
1213
1214     {
1215         local $BugId = 68564;   # minimal CURLYM limited to 32767 matches
1216         local $Message = "stclass optimisation does not break + inside (?=)";
1217         iseq join("-", "   abc   def  " =~ /(?=(\S+))/g),
1218              "abc-bc-c-def-ef-f",
1219     }
1220
1221 } # End of sub run_tests
1222
1223 1;