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 => 305;  # 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         local $Message =  "Call code from qr //";
 550         $a = qr/(?{++$b})/;
 551         $b = 7;
 552         ok /$a$a/ && $b eq '9';
 553
 554         $c="$a";
 555         ok /$a$a/ && $b eq '11';
 556
 557         undef $@;
 558         eval {/$c/};
 559         ok $@ && $@ =~ /not allowed at runtime/;
 560
 561         use re "eval";
 562         /$a$c$a/;
 563         iseq $b, '14';
 564
 565         our $lex_a = 43;
 566         our $lex_b = 17;
 567         our $lex_c = 27;
 568         my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/);
 569
 570         iseq $lex_res, 1;
 571         iseq $lex_a, 44;
 572         iseq $lex_c, 43;
 573
 574         no re "eval";
 575         undef $@;
 576         my $match = eval { /$a$c$a/ };
 577         ok $@ && $@ =~ /Eval-group not allowed/ && !$match;
 578         iseq $b, '14';
 579
 580         $lex_a = 2;
 581         $lex_a = 43;
 582         $lex_b = 17;
 583         $lex_c = 27;
 584         $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/);
 585
 586         iseq $lex_res, 1;
 587         iseq $lex_a, 44;
 588         iseq $lex_c, 43;
 589
 590     }
 591
 592
 593     {
 594         no warnings 'closure';
 595         local $Message = '(?{ $var } refers to package vars';
 596         package aa;
 597         our $c = 2;
 598         $::c = 3;
 599         '' =~ /(?{ $c = 4 })/;
 600         main::iseq $c, 4;
 601         main::iseq $::c, 3;
 602     }
 603
 604
 605     {
 606         must_die 'q(a:[b]:) =~ /[x[:foo:]]/',
 607                  'POSIX class \[:[^:]+:\] unknown in regex',
 608                  'POSIX class [: :] must have valid name';
 609
 610         for my $d (qw [= .]) {
 611             must_die "/[[${d}foo${d}]]/",
 612                      "\QPOSIX syntax [$d $d] is reserved for future extensions",
 613                      "POSIX syntax [[$d $d]] is an error";
 614         }
 615     }
 616
 617
 618     {
 619         # test if failure of patterns returns empty list
 620         local $Message = "Failed pattern returns empty list";
 621         $_ = 'aaa';
 622         @_ = /bbb/;
 623         iseq "@_", "";
 624
 625         @_ = /bbb/g;
 626         iseq "@_", "";
 627
 628         @_ = /(bbb)/;
 629         iseq "@_", "";
 630
 631         @_ = /(bbb)/g;
 632         iseq "@_", "";
 633     }
 634
 635
 636     {
 637         local $Message = '@- and @+ tests';
 638
 639         /a(?=.$)/;
 640         iseq $#+, 0;
 641         iseq $#-, 0;
 642         iseq $+ [0], 2;
 643         iseq $- [0], 1;
 644         ok !defined $+ [1] && !defined $- [1] &&
 645            !defined $+ [2] && !defined $- [2];
 646
 647         /a(a)(a)/;
 648         iseq $#+, 2;
 649         iseq $#-, 2;
 650         iseq $+ [0], 3;
 651         iseq $- [0], 0;
 652         iseq $+ [1], 2;
 653         iseq $- [1], 1;
 654         iseq $+ [2], 3;
 655         iseq $- [2], 2;
 656         ok !defined $+ [3] && !defined $- [3] &&
 657            !defined $+ [4] && !defined $- [4];
 658
 659
 660         /.(a)(b)?(a)/;
 661         iseq $#+, 3;
 662         iseq $#-, 3;
 663         iseq $+ [1], 2;
 664         iseq $- [1], 1;
 665         iseq $+ [3], 3;
 666         iseq $- [3], 2;
 667         ok !defined $+ [2] && !defined $- [2] &&
 668            !defined $+ [4] && !defined $- [4];
 669
 670
 671         /.(a)/;
 672         iseq $#+, 1;
 673         iseq $#-, 1;
 674         iseq $+ [0], 2;
 675         iseq $- [0], 0;
 676         iseq $+ [1], 2;
 677         iseq $- [1], 1;
 678         ok !defined $+ [2] && !defined $- [2] &&
 679            !defined $+ [3] && !defined $- [3];
 680
 681         /.(a)(ba*)?/;
 682         iseq $#+, 2;
 683         iseq $#-, 1;
 684     }
 685
 686
 687     {
 688         local $DiePattern = '^Modification of a read-only value attempted';
 689         local $Message    = 'Elements of @- and @+ are read-only';
 690         must_die '$+[0] = 13';
 691         must_die '$-[0] = 13';
 692         must_die '@+ = (7, 6, 5)';
 693         must_die '@- = qw (foo bar)';
 694     }
 695
 696
 697     {
 698         local $Message = '\G testing';
 699         $_ = 'aaa';
 700         pos = 1;
 701         my @a = /\Ga/g;
 702         iseq "@a", "a a";
 703
 704         my $str = 'abcde';
 705         pos $str = 2;
 706         ok $str !~ /^\G/;
 707         ok $str !~ /^.\G/;
 708         ok $str =~ /^..\G/;
 709         ok $str !~ /^...\G/;
 710         ok $str =~ /\G../ && $& eq 'cd';
 711
 712         local $TODO = $running_as_thread;
 713         ok $str =~ /.\G./ && $& eq 'bc';
 714     }
 715
 716
 717     {
 718         local $Message = 'pos inside (?{ })';
 719         my $str = 'abcde';
 720         our ($foo, $bar);
 721         ok $str =~ /b(?{$foo = $_; $bar = pos})c/;
 722         iseq $foo, $str;
 723         iseq $bar, 2;
 724         ok !defined pos ($str);
 725
 726         undef $foo;
 727         undef $bar;
 728         pos $str = undef;
 729         ok $str =~ /b(?{$foo = $_; $bar = pos})c/g;
 730         iseq $foo, $str;
 731         iseq $bar, 2;
 732         iseq pos ($str), 3;
 733
 734         $_ = $str;
 735         undef $foo;
 736         undef $bar;
 737         ok /b(?{$foo = $_; $bar = pos})c/;
 738         iseq $foo, $str;
 739         iseq $bar, 2;
 740
 741         undef $foo;
 742         undef $bar;
 743         ok /b(?{$foo = $_; $bar = pos})c/g;
 744         iseq $foo, $str;
 745         iseq $bar, 2;
 746         iseq pos, 3;
 747
 748         undef $foo;
 749         undef $bar;
 750         pos = undef;
 751         1 while /b(?{$foo = $_; $bar = pos})c/g;
 752         iseq $foo, $str;
 753         iseq $bar, 2;
 754         ok !defined pos;
 755
 756         undef $foo;
 757         undef $bar;
 758         $_ = 'abcde|abcde';
 759         ok s/b(?{$foo = $_; $bar = pos})c/x/g;
 760         iseq $foo, 'abcde|abcde';
 761         iseq $bar, 8;
 762         iseq $_, 'axde|axde';
 763
 764         # List context:
 765         $_ = 'abcde|abcde';
 766         our @res;
 767         () = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g;
 768         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
 769         iseq "@res", "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'";
 770
 771         @res = ();
 772         () = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g;
 773         @res = map {defined $_ ? "'$_'" : 'undef'} @res;
 774         iseq "@res", "'' 'ab' 'cde|abcde' " .
 775                      "'' 'abc' 'de|abcde' " .
 776                      "'abcd' 'e|' 'abcde' " .
 777                      "'abcde|' 'ab' 'cde' " .
 778                      "'abcde|' 'abc' 'de'" ;
 779     }
 780
 781
 782     {
 783         local $Message = '\G anchor checks';
 784         my $foo = 'aabbccddeeffgg';
 785         pos ($foo) = 1;
 786         {
 787             local $TODO = $running_as_thread;
 788             no warnings 'uninitialized';
 789             ok $foo =~ /.\G(..)/g;
 790             iseq $1, 'ab';
 791
 792             pos ($foo) += 1;
 793             ok $foo =~ /.\G(..)/g;
 794             iseq $1, 'cc';
 795
 796             pos ($foo) += 1;
 797             ok $foo =~ /.\G(..)/g;
 798             iseq $1, 'de';
 799
 800             ok $foo =~ /\Gef/g;
 801         }
 802
 803         undef pos $foo;
 804         ok $foo =~ /\G(..)/g;
 805         iseq $1, 'aa';
 806
 807         ok $foo =~ /\G(..)/g;
 808         iseq $1, 'bb';
 809
 810         pos ($foo) = 5;
 811         ok $foo =~ /\G(..)/g;
 812         iseq $1, 'cd';
 813     }
 814
 815
 816     {
 817         $_ = '123x123';
 818         my @res = /(\d*|x)/g;
 819         local $" = '|';
 820         iseq "@res", "123||x|123|", "0 match in alternation";
 821     }
 822
 823
 824     {
 825         local $Message = "Match against temporaries (created via pp_helem())" .
 826                          " is safe";
 827         ok {foo => "bar\n" . $^X} -> {foo} =~ /^(.*)\n/g;
 828         iseq $1, "bar";
 829     }
 830
 831
 832     {
 833         local $Message = 'package $i inside (?{ }), ' .
 834                          'saved substrings and changing $_';
 835         our @a = qw [foo bar];
 836         our @b = ();
 837         s/(\w)(?{push @b, $1})/,$1,/g for @a;
 838         iseq "@b", "f o o b a r";
 839         iseq "@a", ",f,,o,,o, ,b,,a,,r,";
 840
 841         local $Message = 'lexical $i inside (?{ }), ' .
 842                          'saved substrings and changing $_';
 843         no warnings 'closure';
 844         my @c = qw [foo bar];
 845         my @d = ();
 846         s/(\w)(?{push @d, $1})/,$1,/g for @c;
 847         iseq "@d", "f o o b a r";
 848         iseq "@c", ",f,,o,,o, ,b,,a,,r,";
 849     }
 850
 851
 852     {
 853         local $Message = 'Brackets';
 854         our $brackets;
 855         $brackets = qr {
 856             {  (?> [^{}]+ | (??{ $brackets }) )* }
 857         }x;
 858
 859         ok "{{}" =~ $brackets;
 860         iseq $&, "{}";
 861         ok "something { long { and } hairy" =~ $brackets;
 862         iseq $&, "{ and }";
 863         ok "something { long { and } hairy" =~ m/((??{ $brackets }))/;
 864         iseq $&, "{ and }";
 865     }
 866
 867
 868     {
 869         $_ = "a-a\nxbb";
 870         pos = 1;
 871         nok m/^-.*bb/mg, '$_ = "a-a\nxbb"; m/^-.*bb/mg';
 872     }
 873
 874
 875     {
 876         local $Message = '\G anchor checks';
 877         my $text = "aaXbXcc";
 878         pos ($text) = 0;
 879         ok $text !~ /\GXb*X/g;
 880     }
 881
 882
 883     {
 884         $_ = "xA\n" x 500;
 885         nok /^\s*A/m, '$_ = "xA\n" x 500; /^\s*A/m"';
 886
 887         my $text = "abc dbf";
 888         my @res = ($text =~ /.*?(b).*?\b/g);
 889         iseq "@res", "b b", '\b is not special';
 890     }
 891
 892
 893     {
 894         local $Message = '\S, [\S], \s, [\s]';
 895         my @a = map chr, 0 .. 255;
 896         my @b = grep m/\S/, @a;
 897         my @c = grep m/[^\s]/, @a;
 898         iseq "@b", "@c";
 899
 900         @b = grep /\S/, @a;
 901         @c = grep /[\S]/, @a;
 902         iseq "@b", "@c";
 903
 904         @b = grep /\s/, @a;
 905         @c = grep /[^\S]/, @a;
 906         iseq "@b", "@c";
 907
 908         @b = grep /\s/, @a;
 909         @c = grep /[\s]/, @a;
 910         iseq "@b", "@c";
 911     }
 912     {
 913         local $Message = '\D, [\D], \d, [\d]';
 914         my @a = map chr, 0 .. 255;
 915         my @b = grep /\D/, @a;
 916         my @c = grep /[^\d]/, @a;
 917         iseq "@b", "@c";
 918
 919         @b = grep /\D/, @a;
 920         @c = grep /[\D]/, @a;
 921         iseq "@b", "@c";
 922
 923         @b = grep /\d/, @a;
 924         @c = grep /[^\D]/, @a;
 925         iseq "@b", "@c";
 926
 927         @b = grep /\d/, @a;
 928         @c = grep /[\d]/, @a;
 929         iseq "@b", "@c";
 930     }
 931     {
 932         local $Message = '\W, [\W], \w, [\w]';
 933         my @a = map chr, 0 .. 255;
 934         my @b = grep /\W/, @a;
 935         my @c = grep /[^\w]/, @a;
 936         iseq "@b", "@c";
 937
 938         @b = grep /\W/, @a;
 939         @c = grep /[\W]/, @a;
 940         iseq "@b", "@c";
 941
 942         @b = grep /\w/, @a;
 943         @c = grep /[^\W]/, @a;
 944         iseq "@b", "@c";
 945
 946         @b = grep /\w/, @a;
 947         @c = grep /[\w]/, @a;
 948         iseq "@b", "@c";
 949     }
 950
 951
 952     {
 953         # see if backtracking optimization works correctly
 954         local $Message = 'Backtrack optimization';
 955         ok "\n\n" =~ /\n   $ \n/x;
 956         ok "\n\n" =~ /\n*  $ \n/x;
 957         ok "\n\n" =~ /\n+  $ \n/x;
 958         ok "\n\n" =~ /\n?  $ \n/x;
 959         ok "\n\n" =~ /\n*? $ \n/x;
 960         ok "\n\n" =~ /\n+? $ \n/x;
 961         ok "\n\n" =~ /\n?? $ \n/x;
 962         ok "\n\n" !~ /\n*+ $ \n/x;
 963         ok "\n\n" !~ /\n++ $ \n/x;
 964         ok "\n\n" =~ /\n?+ $ \n/x;
 965     }
 966
 967
 968     {
 969         package S;
 970         use overload '""' => sub {'Object S'};
 971         sub new {bless []}
 972
 973         local $::Message  = "Ref stringification";
 974       ::ok do { \my $v} =~ /^SCALAR/,   "Scalar ref stringification";
 975       ::ok do {\\my $v} =~ /^REF/,      "Ref ref stringification";
 976       ::ok []           =~ /^ARRAY/,    "Array ref stringification";
 977       ::ok {}           =~ /^HASH/,     "Hash ref stringification";
 978       ::ok 'S' -> new   =~ /^Object S/, "Object stringification";
 979     }
 980
 981
 982     {
 983         local $Message = "Test result of match used as match";
 984         ok 'a1b' =~ ('xyz' =~ /y/);
 985         iseq $`, 'a';
 986         ok 'a1b' =~ ('xyz' =~ /t/);
 987         iseq $`, 'a';
 988     }
 989
 990
 991     {
 992         local $Message = '"1" is not \s';
 993         may_not_warn sub {ok ("1\n" x 102) !~ /^\s*\n/m};
 994     }
 995
 996
 997     {
 998         local $Message = '\s, [[:space:]] and [[:blank:]]';
 999         my %space = (spc   => " ",
1000                      tab   => "\t",
1001                      cr    => "\r",
1002                      lf    => "\n",
1003                      ff    => "\f",
1004         # There's no \v but the vertical tabulator seems miraculously
1005         # be 11 both in ASCII and EBCDIC.
1006                      vt    => chr(11),
1007                      false => "space");
1008
1009         my @space0 = sort grep {$space {$_} =~ /\s/         } keys %space;
1010         my @space1 = sort grep {$space {$_} =~ /[[:space:]]/} keys %space;
1011         my @space2 = sort grep {$space {$_} =~ /[[:blank:]]/} keys %space;
1012
1013         iseq "@space0", "cr ff lf spc tab";
1014         iseq "@space1", "cr ff lf spc tab vt";
1015         iseq "@space2", "spc tab";
1016     }
1017
1018 } # End of sub run_tests
1019
1020 1;