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