t/re/pat.t

   1 #!./perl
   2 #
   3 # This is a home for regular expression tests that don't fit into
   4 # the format supported by re/regexp.t.  If you want to add a test
   5 # that does fit that format, add it to re/re_tests, not here.
   6
   7 use strict;
   8 use warnings;
   9 use 5.010;
  10
  11
  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 => 293;  # 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         my $x = "abc\ndef\n";
  36
  37         ok $x =~ /^abc/,  qq ["$x" =~ /^abc/];
  38         ok $x !~ /^def/,  qq ["$x" !~ /^def/];
  39
  40         # used to be a test for $*
  41         ok $x =~ /^def/m, qq ["$x" =~ /^def/m];
  42
  43         nok $x =~ /^xxx/, qq ["$x" =~ /^xxx/];
  44         nok $x !~ /^abc/, qq ["$x" !~ /^abc/];
  45
  46          ok $x =~ /def/, qq ["$x" =~ /def/];
  47         nok $x !~ /def/, qq ["$x" !~ /def/];
  48
  49          ok $x !~ /.def/, qq ["$x" !~ /.def/];
  50         nok $x =~ /.def/, qq ["$x" =~ /.def/];
  51
  52          ok $x =~ /\ndef/, qq ["$x" =~ /\ndef/];
  53         nok $x !~ /\ndef/, qq ["$x" !~ /\ndef/];
  54     }
  55
  56     {
  57         $_ = '123';
  58         ok /^([0-9][0-9]*)/, qq [\$_ = '$_'; /^([0-9][0-9]*)/];
  59     }
  60
  61     {
  62         $_ = 'aaabbbccc';
  63          ok /(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc',
  64                                              qq [\$_ = '$_'; /(a*b*)(c*)/];
  65          ok /(a+b+c+)/ && $1 eq 'aaabbbccc', qq [\$_ = '$_'; /(a+b+c+)/];
  66         nok /a+b?c+/,                        qq [\$_ = '$_'; /a+b?c+/];
  67
  68         $_ = 'aaabccc';
  69          ok /a+b?c+/, qq [\$_ = '$_'; /a+b?c+/];
  70          ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/];
  71
  72         $_ = 'aaaccc';
  73          ok /a*b?c*/, qq [\$_ = '$_'; /a*b?c*/];
  74         nok /a*b+c*/, qq [\$_ = '$_'; /a*b+c*/];
  75
  76         $_ = 'abcdef';
  77          ok /bcd|xyz/, qq [\$_ = '$_'; /bcd|xyz/];
  78          ok /xyz|bcd/, qq [\$_ = '$_'; /xyz|bcd/];
  79          ok m|bc/*d|,  qq [\$_ = '$_'; m|bc/*d|];
  80          ok /^$_$/,    qq [\$_ = '$_'; /^\$_\$/];
  81     }
  82
  83     {
  84         # used to be a test for $*
  85         ok "ab\ncd\n" =~ /^cd/m, qq ["ab\ncd\n" =~ /^cd/m];
  86     }
  87
  88     {
  89         our %XXX = map {($_ => $_)} 123, 234, 345;
  90
  91         our @XXX = ('ok 1','not ok 1', 'ok 2','not ok 2','not ok 3');
  92         while ($_ = shift(@XXX)) {
  93             my $f = index ($_, 'not') >= 0 ? \&nok : \&ok;
  94             my $r = ?(.*)?;
  95             &$f ($r, "?(.*)?");
  96             /not/ && reset;
  97             if (/not ok 2/) {
  98                 if ($^O eq 'VMS') {
  99                     $_ = shift(@XXX);
 100                 }
 101                 else {
 102                     reset 'X';
 103                 }
 104             }
 105         }
 106
 107         SKIP: {
 108             if ($^O eq 'VMS') {
 109                 skip "Reset 'X'", 1;
 110             }
 111             ok !keys %XXX, "%XXX is empty";
 112         }
 113
 114     }
 115
 116     {
 117         local $Message = "Test empty pattern";
 118         my $xyz = 'xyz';
 119         my $cde = 'cde';
 120
 121         $cde =~ /[^ab]*/;
 122         $xyz =~ //;
 123         iseq $&, $xyz;
 124
 125         my $foo = '[^ab]*';
 126         $cde =~ /$foo/;
 127         $xyz =~ //;
 128         iseq $&, $xyz;
 129
 130         $cde =~ /$foo/;
 131         my $null;
 132         no warnings 'uninitialized';
 133         $xyz =~ /$null/;
 134         iseq $&, $xyz;
 135
 136         $null = "";
 137         $xyz =~ /$null/;
 138         iseq $&, $xyz;
 139     }
 140
 141     {
 142         local $Message = q !Check $`, $&, $'!;
 143         $_ = 'abcdefghi';
 144         /def/;        # optimized up to cmd
 145         iseq "$`:$&:$'", 'abc:def:ghi';
 146
 147         no warnings 'void';
 148         /cde/ + 0;    # optimized only to spat
 149         iseq "$`:$&:$'", 'ab:cde:fghi';
 150
 151         /[d][e][f]/;    # not optimized
 152         iseq "$`:$&:$'", 'abc:def:ghi';
 153     }
 154
 155     {
 156         $_ = 'now is the {time for all} good men to come to.';
 157         / {([^}]*)}/;
 158         iseq $1, 'time for all', "Match braces";
 159     }
 160
 161     {
 162         local $Message = "{N,M} quantifier";
 163         $_ = 'xxx {3,4}  yyy   zzz';
 164         ok /( {3,4})/;
 165         iseq $1, '   ';
 166         ok !/( {4,})/;
 167         ok /( {2,3}.)/;
 168         iseq $1, '  y';
 169         ok /(y{2,3}.)/;
 170         iseq $1, 'yyy ';
 171         ok !/x {3,4}/;
 172         ok !/^xxx {3,4}/;
 173     }
 174
 175     {
 176         local $Message = "Test /g";
 177         local $" = ":";
 178         $_ = "now is the time for all good men to come to.";
 179         my @words = /(\w+)/g;
 180         my $exp   = "now:is:the:time:for:all:good:men:to:come:to";
 181
 182         iseq "@words", $exp;
 183
 184         @words = ();
 185         while (/\w+/g) {
 186             push (@words, $&);
 187         }
 188         iseq "@words", $exp;
 189
 190         @words = ();
 191         pos = 0;
 192         while (/to/g) {
 193             push(@words, $&);
 194         }
 195         iseq "@words", "to:to";
 196
 197         pos $_ = 0;
 198         @words = /to/g;
 199         iseq "@words", "to:to";
 200     }
 201
 202     {
 203         $_ = "abcdefghi";
 204
 205         my $pat1 = 'def';
 206         my $pat2 = '^def';
 207         my $pat3 = '.def.';
 208         my $pat4 = 'abc';
 209         my $pat5 = '^abc';
 210         my $pat6 = 'abc$';
 211         my $pat7 = 'ghi';
 212         my $pat8 = '\w*ghi';
 213         my $pat9 = 'ghi$';
 214
 215         my $t1 = my $t2 = my $t3 = my $t4 = my $t5 =
 216         my $t6 = my $t7 = my $t8 = my $t9 = 0;
 217
 218         for my $iter (1 .. 5) {
 219             $t1++ if /$pat1/o;
 220             $t2++ if /$pat2/o;
 221             $t3++ if /$pat3/o;
 222             $t4++ if /$pat4/o;
 223             $t5++ if /$pat5/o;
 224             $t6++ if /$pat6/o;
 225             $t7++ if /$pat7/o;
 226             $t8++ if /$pat8/o;
 227             $t9++ if /$pat9/o;
 228         }
 229         my $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
 230         iseq $x, '505550555', "Test /o";
 231     }
 232
 233
 234     SKIP: {
 235         my $xyz = 'xyz';
 236         ok "abc" =~ /^abc$|$xyz/, "| after \$";
 237
 238         # perl 4.009 says "unmatched ()"
 239         local $Message = '$ inside ()';
 240
 241         my $result;
 242         eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
 243         iseq $@, "" or skip "eval failed", 1;
 244         iseq $result, "abc:bc";
 245     }
 246
 247
 248     {
 249         local $Message = "Scalar /g";
 250         $_ = "abcfooabcbar";
 251
 252         ok  /abc/g && $` eq "";
 253         ok  /abc/g && $` eq "abcfoo";
 254         ok !/abc/g;
 255
 256         local $Message = "Scalar /gi";
 257         pos = 0;
 258         ok  /ABC/gi && $` eq "";
 259         ok  /ABC/gi && $` eq "abcfoo";
 260         ok !/ABC/gi;
 261
 262         local $Message = "Scalar /g";
 263         pos = 0;
 264         ok  /abc/g && $' eq "fooabcbar";
 265         ok  /abc/g && $' eq "bar";
 266
 267         $_ .= '';
 268         my @x = /abc/g;
 269         iseq @x, 2, "/g reset after assignment";
 270     }
 271
 272     {
 273         local $Message = '/g, \G and pos';
 274         $_ = "abdc";
 275         pos $_ = 2;
 276         /\Gc/gc;
 277         iseq pos $_, 2;
 278         /\Gc/g;
 279         ok !defined pos $_;
 280     }
 281
 282     {
 283         local $Message = '(?{ })';
 284         our $out = 1;
 285         'abc' =~ m'a(?{ $out = 2 })b';
 286         iseq $out, 2;
 287
 288         $out = 1;
 289         'abc' =~ m'a(?{ $out = 3 })c';
 290         iseq $out, 1;
 291     }
 292
 293
 294     {
 295         $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
 296         my @out = /(?<!foo)bar./g;
 297         iseq "@out", 'bar2 barf', "Negative lookbehind";
 298     }
 299
 300     {
 301         local $Message = "REG_INFTY tests";
 302         # Tests which depend on REG_INFTY
 303         $::reg_infty   = $Config {reg_infty} // 32767;
 304         $::reg_infty_m = $::reg_infty - 1;
 305         $::reg_infty_p = $::reg_infty + 1;
 306         $::reg_infty_m = $::reg_infty_m;   # Surpress warning.
 307
 308         # As well as failing if the pattern matches do unexpected things, the
 309         # next three tests will fail if you should have picked up a lower-than-
 310         # default value for $reg_infty from Config.pm, but have not.
 311
 312         eval_ok q (('aaa' =~ /(a{1,$::reg_infty_m})/)[0] eq 'aaa');
 313         eval_ok q (('a' x $::reg_infty_m) =~ /a{$::reg_infty_m}/);
 314         eval_ok q (('a' x ($::reg_infty_m - 1)) !~ /a{$::reg_infty_m}/);
 315         eval "'aaa' =~ /a{1,$::reg_infty}/";
 316         ok $@ =~ /^\QQuantifier in {,} bigger than/;
 317         eval "'aaa' =~ /a{1,$::reg_infty_p}/";
 318         ok $@ =~ /^\QQuantifier in {,} bigger than/;
 319     }
 320
 321     {
 322         # Poke a couple more parse failures
 323         my $context = 'x' x 256;
 324         eval qq("${context}y" =~ /(?<=$context)y/);
 325         ok $@ =~ /^\QLookbehind longer than 255 not/, "Lookbehind limit";
 326     }
 327
 328     {
 329         # Long Monsters
 330         local $Message = "Long monster";
 331         for my $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
 332             my $a = 'a' x $l;
 333             local $Error = "length = $l";
 334              ok "ba$a=" =~ /a$a=/;
 335             nok "b$a="  =~ /a$a=/;
 336              ok "b$a="  =~ /ba+=/;
 337
 338              ok "ba$a=" =~ /b(?:a|b)+=/;
 339         }
 340     }
 341
 342
 343     {
 344         # 20000 nodes, each taking 3 words per string, and 1 per branch
 345         my $long_constant_len = join '|', 12120 .. 32645;
 346         my $long_var_len = join '|', 8120 .. 28645;
 347         my %ans = ( 'ax13876y25677lbc' => 1,
 348                     'ax13876y25677mcb' => 0, # not b.
 349                     'ax13876y35677nbc' => 0, # Num too big
 350                     'ax13876y25677y21378obc' => 1,
 351                     'ax13876y25677y21378zbc' => 0,    # Not followed by [k-o]
 352                     'ax13876y25677y21378y21378kbc' => 1,
 353                     'ax13876y25677y21378y21378kcb' => 0, # Not b.
 354                     'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
 355                   );
 356
 357         local $Message = "20000 nodes";
 358         for (keys %ans) {
 359             local $Error = "const-len '$_'";
 360             ok !($ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o);
 361
 362             local $Error = "var-len '$_'";
 363             ok !($ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o);
 364         }
 365     }
 366
 367     {
 368         local $Message = "Complicated backtracking";
 369         $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
 370         my $expect = "(bla()) ((l)u((e))) (l(e)e)";
 371
 372         use vars '$c';
 373         sub matchit {
 374           m/
 375              (
 376                \(
 377                (?{ $c = 1 })    # Initialize
 378                (?:
 379                  (?(?{ $c == 0 })   # PREVIOUS iteration was OK, stop the loop
 380                    (?!
 381                    )        # Fail: will unwind one iteration back
 382                  )
 383                  (?:
 384                    [^()]+        # Match a big chunk
 385                    (?=
 386                      [()]
 387                    )        # Do not try to match subchunks
 388                  |
 389                    \(
 390                    (?{ ++$c })
 391                  |
 392                    \)
 393                    (?{ --$c })
 394                  )
 395                )+        # This may not match with different subblocks
 396              )
 397              (?(?{ $c != 0 })
 398                (?!
 399                )        # Fail
 400              )            # Otherwise the chunk 1 may succeed with $c>0
 401            /xg;
 402         }
 403
 404         my @ans = ();
 405         my $res;
 406         push @ans, $res while $res = matchit;
 407         iseq "@ans", "1 1 1";
 408
 409         @ans = matchit;
 410         iseq "@ans", $expect;
 411
 412         local $Message = "Recursion with (??{ })";
 413         our $matched;
 414         $matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/;
 415
 416         @ans = my @ans1 = ();
 417         push (@ans, $res), push (@ans1, $&) while $res = m/$matched/g;
 418
 419         iseq "@ans", "1 1 1";
 420         iseq "@ans1", $expect;
 421
 422         @ans = m/$matched/g;
 423         iseq "@ans", $expect;
 424
 425     }
 426
 427     {
 428         ok "abc" =~ /^(??{"a"})b/, '"abc" =~ /^(??{"a"})b/';
 429     }
 430
 431     {
 432         my @ans = ('a/b' =~ m%(.*/)?(.*)%);    # Stack may be bad
 433         iseq "@ans", 'a/ b', "Stack may be bad";
 434     }
 435
 436     {
 437         local $Message = "Eval-group not allowed at runtime";
 438         my $code = '{$blah = 45}';
 439         our $blah = 12;
 440         eval { /(?$code)/ };
 441         ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12;
 442
 443         for $code ('{$blah = 45}','=xx') {
 444             $blah = 12;
 445             my $res = eval { "xx" =~ /(?$code)/o };
 446             no warnings 'uninitialized';
 447             local $Error = "'$@', '$res', '$blah'";
 448             if ($code eq '=xx') {
 449                 ok !$@ && $res;
 450             }
 451             else {
 452                 ok $@ && $@ =~ /not allowed at runtime/ && $blah == 12;
 453             }
 454         }
 455
 456         $code = '{$blah = 45}';
 457         $blah = 12;
 458         eval "/(?$code)/";
 459         iseq $blah, 45;
 460
 461         $blah = 12;
 462         /(?{$blah = 45})/;
 463         iseq $blah, 45;
 464     }
 465
 466     {
 467         local $Message = "Pos checks";
 468         my $x = 'banana';
 469         $x =~ /.a/g;
 470         iseq pos ($x), 2;
 471
 472         $x =~ /.z/gc;
 473         iseq pos ($x), 2;
 474
 475         sub f {
 476             my $p = $_[0];
 477             return $p;
 478         }
 479
 480         $x =~ /.a/g;
 481         iseq f (pos ($x)), 4;
 482     }
 483
 484     {
 485         local $Message = 'Checking $^R';
 486         our $x = $^R = 67;
 487         'foot' =~ /foo(?{$x = 12; 75})[t]/;
 488         iseq $^R, 75;
 489
 490         $x = $^R = 67;
 491         'foot' =~ /foo(?{$x = 12; 75})[xy]/;
 492         ok $^R eq '67' && $x eq '12';
 493
 494         $x = $^R = 67;
 495         'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/;
 496         ok $^R eq '79' && $x eq '12';
 497     }
 498
 499     {
 500         iseq qr/\b\v$/i,    '(?i-xsm:\b\v$)', 'qr/\b\v$/i';
 501         iseq qr/\b\v$/s,    '(?s-xim:\b\v$)', 'qr/\b\v$/s';
 502         iseq qr/\b\v$/m,    '(?m-xis:\b\v$)', 'qr/\b\v$/m';
 503         iseq qr/\b\v$/x,    '(?x-ism:\b\v$)', 'qr/\b\v$/x';
 504         iseq qr/\b\v$/xism, '(?msix:\b\v$)',  'qr/\b\v$/xism';
 505         iseq qr/\b\v$/,     '(?-xism:\b\v$)', 'qr/\b\v$/';
 506     }
 507
 508
 509     {
 510         local $Message = "Look around";
 511         $_ = 'xabcx';
 512       SKIP:
 513         foreach my $ans ('', 'c') {
 514             ok /(?<=(?=a)..)((?=c)|.)/g or skip "Match failed", 1;
 515             iseq $1, $ans;
 516         }
 517     }
 518
 519     {
 520         local $Message = "Empty clause";
 521         $_ = 'a';
 522         foreach my $ans ('', 'a', '') {
 523             ok /^|a|$/g or skip "Match failed", 1;
 524             iseq $&, $ans;
 525         }
 526     }
 527
 528     {
 529         local $Message = "Prefixify";
 530         sub prefixify {
 531             SKIP: {
 532                 my ($v, $a, $b, $res) = @_;
 533                 ok $v =~ s/\Q$a\E/$b/ or skip "Match failed", 1;
 534                 iseq $v, $res;
 535             }
 536         }
 537
 538         prefixify ('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch');
 539         prefixify ('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch');
 540     }
 541
 542     {
 543         $_ = 'var="foo"';
 544         /(\")/;
 545         ok $1 && /$1/, "Capture a quote";
 546     }
 547
 548     {
 549         no warnings 'closure';
 550         local $Message = '(?{ $var } refers to package vars';
 551         package aa;
 552         our $c = 2;
 553         $::c = 3;
 554         '' =~ /(?{ $c = 4 })/;
 555         main::iseq $c, 4;
 556         main::iseq $::c, 3;
 557     }
 558
 559     {
 560         must_die 'q(a:[b]:) =~ /[x[:foo:]]/',
 561                  'POSIX class \[:[^:]+:\] unknown in regex',
 562                  'POSIX class [: :] must have valid name';
 563
 564         for my $d (qw [= .]) {
 565             must_die "/[[${d}foo${d}]]/",
 566                      "\QPOSIX syntax [$d $d] is reserved for future extensions",
 567                      "POSIX syntax [[$d $d]] is an error";
 568         }
 569     }
 570
 571
 572     {
 573         # test if failure of patterns returns empty list
 574         local $Message = "Failed pattern returns empty list";
 575         $_ = 'aaa';
 576         @_ = /bbb/;
 577         iseq "@_", "";
 578
 579         @_ = /bbb/g;
 580         iseq "@_", "";
 581
 582         @_ = /(bbb)/;
 583         iseq "@_", "";
 584
 585         @_ = /(bbb)/g;
 586         iseq "@_", "";
 587     }
 588
 589
 590     {
 591         local $Message = '@- and @+ tests';
 592
 593         /a(?=.$)/;
 594         iseq $#+, 0;
 595         iseq $#-, 0;
 596         iseq $+ [0], 2;
 597         iseq $- [0], 1;
 598         ok !defined $+ [1] && !defined $- [1] &&
 599            !defined $+ [2] && !defined $- [2];
 600
 601         /a(a)(a)/;
 602         iseq $#+, 2;
 603         iseq $#-, 2;
 604         iseq $+ [0], 3;
 605         iseq $- [0], 0;
 606         iseq $+ [1], 2;
 607         iseq $- [1], 1;
 608         iseq $+ [2], 3;
 609         iseq $- [2], 2;
 610         ok !defined $+ [3] && !defined $- [3] &&
 611            !defined $+ [4] && !defined $- [4];
 612
 613
 614         /.(a)(b)?(a)/;
 615         iseq $#+, 3;
 616         iseq $#-, 3;
 617         iseq $+ [1], 2;
 618         iseq $- [1], 1;
 619         iseq $+ [3], 3;
 620         iseq $- [3], 2;
 621         ok !defined $+ [2] && !defined $- [2] &&
 622            !defined $+ [4] && !defined $- [4];
 623
 624
 625         /.(a)/;
 626         iseq $#+, 1;
 627         iseq $#-, 1;
 628         iseq $+ [0], 2;
 629         iseq $- [0], 0;
 630         iseq $+ [1], 2;
 631         iseq $- [1], 1;
 632         ok !defined $+ [2] && !defined $- [2] &&
 633            !defined $+ [3] && !defined $- [3];
 634
 635         /.(a)(ba*)?/;
 636         iseq $#+, 2;
 637         iseq $#-, 1;
 638     }
 639
 640
 641     {
 642         local $DiePattern = '^Modification of a read-only value attempted';
 643         local $Message    = 'Elements of @- and @+ are read-only';
 644         must_die '$+[0] = 13';
 645         must_die '$-[0] = 13';
 646         must_die '@+ = (7, 6, 5)';
 647         must_die '@- = qw (foo bar)';
 648     }
 649
 650
 651     {
 652         local $Message = '\G testing';
 653         $_ = 'aaa';
 654         pos = 1;
 655         my @a = /\Ga/g;
 656         iseq "@a", "a a";
 657
 658         my $str = 'abcde';
 659         pos $str = 2;
 660         ok $str !~ /^\G/;
 661         ok $str !~ /^.\G/;
 662         ok $str =~ /^..\G/;
 663         ok $str !~ /^...\G/;
 664         ok $str =~ /\G../ && $& eq 'cd';
 665
 666         local $TODO = $running_as_thread;
 667         ok $str =~ /.\G./ && $& eq 'bc';
 668     }
 669
 670
 671     {
 672         local $Message = 'pos inside (?{ })';
 673         my $str = 'abcde';
 674         our ($foo, $bar);
 675         ok $str =~ /b(?{$foo = $_; $bar = pos})c/;
 676         iseq $foo, $str;
 677         iseq $bar, 2;
 678         ok !defined pos ($str);
 679
 680         undef $foo;
 681         undef $bar;
 682         pos $str = undef;
 683         ok $str =~ /b(?{$foo = $_; $bar = pos})c/g;
 684         iseq $foo, $str;
 685         iseq $bar, 2;
 686         iseq pos ($str), 3;
 687
 688         $_ = $str;
 689         undef $foo;
 690         undef $bar;
 691         ok /b(?{$foo = $_; $bar = pos})c/;
 692         iseq $foo, $str;
 693         iseq $bar, 2;
 694
 695         undef $foo;
 696         undef $bar;
 697         ok /b(?{$foo = $_; $bar = pos})c/g;
 698         iseq $foo, $str;
 699         iseq $bar, 2;
 700         iseq pos, 3;
 701
 702         undef $foo;
 703         undef $bar;
 704         pos = undef;
 705         1 while /b(?{$foo = $_; $bar = pos})c/g;
 706         iseq $foo, $str;
 707         iseq $bar, 2;
 708         ok !defined pos;
 709
 710         undef $foo;
 711         undef $bar;
 712         $_ = 'abcde|abcde';
 713         ok s/b(?{$foo = $_; $bar = pos})c/x/g;
 714         iseq $foo, 'abcde|abcde';
 715         iseq $bar, 8;
 716         iseq $_, 'axde|axde';
 717
 718         # List context:
 719         $_ = 'abcde|abcde';
 720         our @res;
 721         () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
 722         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
 723         iseq "@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'";
 724
 725         @res = ();
 726         () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
 727         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
 728         iseq "@res", "'' 'ab' 'cde|abcde' " .
 729                      "'' 'abc' 'de|abcde' " .
 730                      "'abcd' 'e|' 'abcde' " .
 731                      "'abcde|' 'ab' 'cde' " .
 732                      "'abcde|' 'abc' 'de'" ;
 733     }
 734
 735
 736     {
 737         local $Message = '\G anchor checks';
 738         my $foo = 'aabbccddeeffgg';
 739         pos ($foo) = 1;
 740         {
 741             local $TODO = $running_as_thread;
 742             no warnings 'uninitialized';
 743             ok $foo =~ /.\G(..)/g;
 744             iseq $1, 'ab';
 745
 746             pos ($foo) += 1;
 747             ok $foo =~ /.\G(..)/g;
 748             iseq $1, 'cc';
 749
 750             pos ($foo) += 1;
 751             ok $foo =~ /.\G(..)/g;
 752             iseq $1, 'de';
 753
 754             ok $foo =~ /\Gef/g;
 755         }
 756
 757         undef pos $foo;
 758         ok $foo =~ /\G(..)/g;
 759         iseq $1, 'aa';
 760
 761         ok $foo =~ /\G(..)/g;
 762         iseq $1, 'bb';
 763
 764         pos ($foo) = 5;
 765         ok $foo =~ /\G(..)/g;
 766         iseq $1, 'cd';
 767     }
 768
 769
 770     {
 771         $_ = '123x123';
 772         my @res = /(\d*|x)/g;
 773         local $" = '|';
 774         iseq "@res", "123||x|123|", "0 match in alternation";
 775     }
 776
 777
 778     {
 779         local $Message = "Match against temporaries (created via pp_helem())" .
 780                          " is safe";
 781         ok {foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g;
 782         iseq $1, "bar";
 783     }
 784
 785
 786     {
 787         local $Message = 'package $i inside (?{ }), ' .
 788                          'saved substrings and changing $_';
 789         our @a = qw [foo bar];
 790         our @b = ();
 791         s/(\w)(?{push @b, $1})/,$1,/g for @a;
 792         iseq "@b", "f o o b a r";
 793         iseq "@a", ",f,,o,,o, ,b,,a,,r,";
 794
 795         local $Message = 'lexical $i inside (?{ }), ' .
 796                          'saved substrings and changing $_';
 797         no warnings 'closure';
 798         my @c = qw [foo bar];
 799         my @d = ();
 800         s/(\w)(?{push @d, $1})/,$1,/g for @c;
 801         iseq "@d", "f o o b a r";
 802         iseq "@c", ",f,,o,,o, ,b,,a,,r,";
 803     }
 804
 805
 806     {
 807         local $Message = 'Brackets';
 808         our $brackets;
 809         $brackets = qr {
 810             {  (?> [^{}]+ | (??{ $brackets }) )* }
 811         }x;
 812
 813         ok "{{}" =~ $brackets;
 814         iseq $&, "{}";
 815         ok "something { long { and } hairy" =~ $brackets;
 816         iseq $&, "{ and }";
 817         ok "something { long { and } hairy" =~ m/((??{ $brackets }))/;
 818         iseq $&, "{ and }";
 819     }
 820
 821
 822     {
 823         $_ = "a-a\nxbb";
 824         pos = 1;
 825         nok m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg';
 826     }
 827
 828
 829     {
 830         local $Message = '\G anchor checks';
 831         my $text = "aaXbXcc";
 832         pos ($text) = 0;
 833         ok $text !~ /\GXb*X/g;
 834     }
 835
 836
 837     {
 838         $_ = "xA\n" x 500;
 839         nok /^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"';
 840
 841         my $text = "abc dbf";
 842         my @res = ($text =~ /.*?(b).*?\b/g);
 843         iseq "@res", "b b", '\b is not special';
 844     }
 845
 846
 847     {
 848         local $Message = '\S, [\S], \s, [\s]';
 849         my @a = map chr, 0 .. 255;
 850         my @b = grep m/\S/, @a;
 851         my @c = grep m/[^\s]/, @a;
 852         iseq "@b", "@c";
 853
 854         @b = grep /\S/, @a;
 855         @c = grep /[\S]/, @a;
 856         iseq "@b", "@c";
 857
 858         @b = grep /\s/, @a;
 859         @c = grep /[^\S]/, @a;
 860         iseq "@b", "@c";
 861
 862         @b = grep /\s/, @a;
 863         @c = grep /[\s]/, @a;
 864         iseq "@b", "@c";
 865     }
 866     {
 867         local $Message = '\D, [\D], \d, [\d]';
 868         my @a = map chr, 0 .. 255;
 869         my @b = grep /\D/, @a;
 870         my @c = grep /[^\d]/, @a;
 871         iseq "@b", "@c";
 872
 873         @b = grep /\D/, @a;
 874         @c = grep /[\D]/, @a;
 875         iseq "@b", "@c";
 876
 877         @b = grep /\d/, @a;
 878         @c = grep /[^\D]/, @a;
 879         iseq "@b", "@c";
 880
 881         @b = grep /\d/, @a;
 882         @c = grep /[\d]/, @a;
 883         iseq "@b", "@c";
 884     }
 885     {
 886         local $Message = '\W, [\W], \w, [\w]';
 887         my @a = map chr, 0 .. 255;
 888         my @b = grep /\W/, @a;
 889         my @c = grep /[^\w]/, @a;
 890         iseq "@b", "@c";
 891
 892         @b = grep /\W/, @a;
 893         @c = grep /[\W]/, @a;
 894         iseq "@b", "@c";
 895
 896         @b = grep /\w/, @a;
 897         @c = grep /[^\W]/, @a;
 898         iseq "@b", "@c";
 899
 900         @b = grep /\w/, @a;
 901         @c = grep /[\w]/, @a;
 902         iseq "@b", "@c";
 903     }
 904
 905
 906     {
 907         # see if backtracking optimization works correctly
 908         local $Message = 'Backtrack optimization';
 909         ok "\n\n" =~ /\n   $ \n/x;
 910         ok "\n\n" =~ /\n*  $ \n/x;
 911         ok "\n\n" =~ /\n+  $ \n/x;
 912         ok "\n\n" =~ /\n?  $ \n/x;
 913         ok "\n\n" =~ /\n*? $ \n/x;
 914         ok "\n\n" =~ /\n+? $ \n/x;
 915         ok "\n\n" =~ /\n?? $ \n/x;
 916         ok "\n\n" !~ /\n*+ $ \n/x;
 917         ok "\n\n" !~ /\n++ $ \n/x;
 918         ok "\n\n" =~ /\n?+ $ \n/x;
 919     }
 920
 921
 922     {
 923         package S;
 924         use overload '""' => sub {'Object S'};
 925         sub new {bless []}
 926
 927         local $::Message  = "Ref stringification";
 928       ::ok do { \my $v} =~ /^SCALAR/,   "Scalar ref stringification";
 929       ::ok do {\\my $v} =~ /^REF/,      "Ref ref stringification";
 930       ::ok []           =~ /^ARRAY/,    "Array ref stringification";
 931       ::ok {}           =~ /^HASH/,     "Hash ref stringification";
 932       ::ok 'S' -> new   =~ /^Object S/, "Object stringification";
 933     }
 934
 935
 936     {
 937         local $Message = "Test result of match used as match";
 938         ok 'a1b' =~ ('xyz' =~ /y/);
 939         iseq $`, 'a';
 940         ok 'a1b' =~ ('xyz' =~ /t/);
 941         iseq $`, 'a';
 942     }
 943
 944
 945     {
 946         local $Message = '"1" is not \s';
 947         may_not_warn sub {ok ("1\n" x 102) !~ /^\s*\n/m};
 948     }
 949
 950
 951     {
 952         local $Message = '\s, [[:space:]] and [[:blank:]]';
 953         my %space = (spc   => " ",
 954                      tab   => "\t",
 955                      cr    => "\r",
 956                      lf    => "\n",
 957                      ff    => "\f",
 958         # There's no \v but the vertical tabulator seems miraculously
 959         # be 11 both in ASCII and EBCDIC.
 960                      vt    => chr(11),
 961                      false => "space");
 962
 963         my @space0 = sort grep {$space {$_} =~ /\s/         } keys %space;
 964         my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space;
 965         my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space;
 966
 967         iseq "@space0", "cr ff lf spc tab";
 968         iseq "@space1", "cr ff lf spc tab vt";
 969         iseq "@space2", "spc tab";
 970     }
 971
 972 } # End of sub run_tests
 973
 974 1;