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