Regex Utility Functions and Substituion Fix (XML::Twig core dump)
[p5sagit/p5-mst-13.2.git] / t / op / pat.t
index 4ff133b..0de3b14 100755 (executable)
@@ -6,8 +6,7 @@
 
 $| = 1;
 
-# please update note at bottom of file when you change this
-print "1..1232\n"; 
+# Test counter output is generated by a BEGIN block at bottom of file
 
 BEGIN {
     chdir 't' if -d 't';
@@ -477,27 +476,27 @@ print "not " unless $^R eq '79' and $x eq '12';
 print "ok $test\n";
 $test++;
 
-print "not " unless qr/\b\v$/i eq '(?i-xsm:\bv$)';
+print "not " unless qr/\b\v$/i eq '(?i-xsm:\b\v$)';
 print "ok $test\n";
 $test++;
 
-print "not " unless qr/\b\v$/s eq '(?s-xim:\bv$)';
+print "not " unless qr/\b\v$/s eq '(?s-xim:\b\v$)';
 print "ok $test\n";
 $test++;
 
-print "not " unless qr/\b\v$/m eq '(?m-xis:\bv$)';
+print "not " unless qr/\b\v$/m eq '(?m-xis:\b\v$)';
 print "ok $test\n";
 $test++;
 
-print "not " unless qr/\b\v$/x eq '(?x-ism:\bv$)';
+print "not " unless qr/\b\v$/x eq '(?x-ism:\b\v$)';
 print "ok $test\n";
 $test++;
 
-print "not " unless qr/\b\v$/xism eq '(?msix:\bv$)';
+print "not " unless qr/\b\v$/xism eq '(?msix:\b\v$)';
 print "ok $test\n";
 $test++;
 
-print "not " unless qr/\b\v$/ eq '(?-xism:\bv$)';
+print "not " unless qr/\b\v$/ eq '(?-xism:\b\v$)';
 print "ok $test\n";
 $test++;
 
@@ -1286,7 +1285,7 @@ print "ok 247\n";
 {
     # bug id 20001008.001
 
-    my $test = 248;
+    $test = 248;
     my @x = ("stra\337e 138","stra\337e 138");
     for (@x) {
        s/(\d+)\s*([\w\-]+)/$1 . uc $2/e;
@@ -1376,7 +1375,7 @@ print "ok 247\n";
 }
 
 SKIP: {
-    my $test = 264; # till 575
+    $test = 264; # till 575
 
     use charnames ":full";
 
@@ -2032,13 +2031,13 @@ print "ok 683\n" if @a == 9 && "@a" eq "f o o \n $a $b b a r";
 }
 
 
-my $test = 687;
+$test = 687;
 
 # Force scalar context on the patern match
-sub ok ($$) {
+sub ok ($;$) {
     my($ok, $name) = @_;
 
-    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name;
+    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed';
 
     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
 
@@ -2604,35 +2603,21 @@ print "# some Unicode properties\n";
 
     use charnames ':full';
 
-    print "\N{LATIN SMALL LETTER SHARP S}" =~
-       /\N{LATIN SMALL LETTER SHARP S}/    ? "ok 835\n" : "not ok 835\n";
+    $test= 835;
 
-    print "\N{LATIN SMALL LETTER SHARP S}" =~
-       /\N{LATIN SMALL LETTER SHARP S}/i   ? "ok 836\n" : "not ok 836\n";
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/);
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /\N{LATIN SMALL LETTER SHARP S}/i);
 
-    print "\N{LATIN SMALL LETTER SHARP S}" =~
-       /[\N{LATIN SMALL LETTER SHARP S}]/  ? "ok 837\n" : "not ok 837\n";
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/);
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i);
 
-    print "\N{LATIN SMALL LETTER SHARP S}" =~
-       /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 838\n" : "not ok 838\n";
+    ok("ss" =~ /\N{LATIN SMALL LETTER SHARP S}/i);
+    ok("SS" =~ /\N{LATIN SMALL LETTER SHARP S}/i);
+    ok("ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i);
+    ok("SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i);
 
-    print "ss" =~
-       /\N{LATIN SMALL LETTER SHARP S}/i   ? "ok 839\n" : "not ok 839\n";
-
-    print "SS" =~
-       /\N{LATIN SMALL LETTER SHARP S}/i   ? "ok 840\n" : "not ok 840\n";
-
-    print "ss" =~
-       /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 841\n" : "not ok 841\n";
-
-    print "SS" =~
-       /[\N{LATIN SMALL LETTER SHARP S}]/i ? "ok 842\n" : "not ok 842\n";
-
-    print "\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i ?
-       "ok 843\n" : "not ok 843\n";
-
-    print "\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i ?
-       "ok 844\n" : "not ok 844\n";
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /ss/i);
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /SS/i);
 }
 
 {
@@ -2751,7 +2736,7 @@ print "# some Unicode properties\n";
     # check utf8/non-utf8 mixtures
     # try to force all float/anchored check combinations
     my $c = "\x{100}";
-    my $test = 865;
+    $test = 865;
     my $subst;
     for my $re (
        "xx.*$c", "x.*$c$c", "$c.*xx", "$c$c.*x", "xx.*(?=$c)", "(?=$c).*xx",
@@ -2790,7 +2775,7 @@ print "# some Unicode properties\n";
 
 {
     print "# qr/.../x\n";
-    my $test = 893;
+    $test = 893;
 
     my $R = qr/ A B C # D E/x;
 
@@ -2806,7 +2791,7 @@ print "# some Unicode properties\n";
 
 {
     print "# illegal Unicode properties\n";
-    my $test = 896;
+    $test = 896;
 
     print eval { "a" =~ /\pq / }      ? "not ok $test\n" : "ok $test\n";
     $test++;
@@ -2818,7 +2803,7 @@ print "# some Unicode properties\n";
 {
     print "# [ID 20020412.005] wrong pmop flags checked when empty pattern\n";
     # requires reuse of last successful pattern
-    my $test = 898;
+    $test = 898;
     $test =~ /\d/;
     for (0 .. 1) {
        my $match = ?? + 0;
@@ -3039,7 +3024,7 @@ ok("A" =~ /\p{AsciiHexAndDash}/, "'A' is AsciiHexAndDash");
     my $ok = $s =~ /(\x{100}{4})/;
     my($ord, $len) = (ord $1, length $1);
     print +($ok && $ord == 0x100 && $len == 4)
-           ? "ok $test\n" : "not ok $test\t# $ok/$ord/$len\n";
+           ? "ok $test\n" : "not ok $test\t# [#18179] $ok/$ord/$len\n";
     ++$test;
 }
 
@@ -3404,10 +3389,12 @@ ok(("foba  ba${s}pxySS$s$s" =~ qr/(b(?:a${s}t|a${s}f|a${s}p)[xy]+$s*)/i)
 
 
 
-{
+if (!$ENV{PERL_SKIP_PSYCHO_TEST}){
     my @normal=qw(these are some normal words);
     my $psycho=join "|",@normal,map chr $_,255..20000;
     ok(('these'=~/($psycho)/) && $1 eq 'these','Pyscho');
+} else {
+    ok(1,'Skipped Psycho');
 }
 
 # [perl #36207] mixed utf8 / latin-1 and case folding
@@ -3533,22 +3520,22 @@ if ($ordA == 193) {
     my @chars = ("A".."Z");
     my $delim = ",";
     my $size = 32771 - 4;
-    my $test = '';
+    my $str = '';
 
     # create some random junk. Inefficient, but it works.
     for ($i = 0 ; $i < $size ; $i++) {
-        $test .= $chars[int(rand(@chars))];
+        $str .= $chars[int(rand(@chars))];
     }
 
-    $test .= ($delim x 4);
+    $str .= ($delim x 4);
     my $res;
     my $matched;
-    if ($test =~ s/^(.*?)${delim}{4}//s) {
+    if ($str =~ s/^(.*?)${delim}{4}//s) {
         $res = $1;
         $matched=1;
     } 
     ok($matched,'pattern matches');
-    ok(length($test)==0,"Empty string");
+    ok(length($str)==0,"Empty string");
     ok(defined($res) && length($res)==$size,"\$1 is correct size");
 }
 
@@ -3578,9 +3565,448 @@ if ($ordA == 193) {
     ok("A@-B"  =~ /A@{-}B/x, 'interpolation of @- in /@{-}/x');
 }
 
-# Keep the following test last -- it may crash perl
+{
+    use lib 'lib';
+    use Cname;
+    
+    ok('fooB'=~/\N{foo}[\N{B}\N{b}]/,"Passthrough charname");
+    $test=1233; my $handle=make_must_warn('Ignoring excess chars from');
+    $handle->('q(xxWxx) =~ /[\N{WARN}]/');
+    {
+        my $code;
+        my $w="";
+        local $SIG{__WARN__} = sub { $w.=shift };
+        eval($code=<<'EOFTEST') or die "$@\n$code\n";
+        {
+            use warnings;
+            
+            #1234
+            ok("\0" !~ /[\N{EMPTY-STR}XY]/,
+                "Zerolength charname in charclass doesnt match \0");
+            1;
+        }
+EOFTEST
+        ok($w=~/Ignoring zero length/,
+            "Got expected zero length warning");
+        warn $code;                    
+        
+    }
+    $handle= make_must_warn('Ignoring zero length');
+    $handle->('qq(\\0) =~ /[\N{EMPTY-STR}XY]/');
+    ok('AB'=~/(\N{EVIL})/ && $1 eq 'A',"Charname caching $1");
+    ok('ABC'=~/(\N{EVIL})/,"Charname caching $1");    
+    ok('xy'=~/x\N{EMPTY-STR}y/, 'Empty string charname produces NOTHING node');
+    ok(''=~/\N{EMPTY-STR}/, 'Empty string charname produces NOTHING node 2');
+        
+}
+{
+    print "# MORE LATIN SMALL LETTER SHARP S\n";
+
+    use charnames ':full';
+
+    #see also test #835
+    ok("ss" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i,
+        "unoptimized named sequence in class 1");
+    ok("SS" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i,
+        "unoptimized named sequence in class 2");        
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/,
+        "unoptimized named sequence in class 3");
+    ok("\N{LATIN SMALL LETTER SHARP S}" =~ /[\N{LATIN SMALL LETTER SHARP S}x]/i,
+        "unoptimized named sequence in class 4");        
+    
+    ok('aabc' !~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against aabc');
+    ok('a+bc' =~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against a+bc');
+    ok('a+bc' =~ /a\N{PLUS SIGN}b/,'/a\N{PLUS SIGN}b/ against a+bc');
+
+    ok(' A B'=~/\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/,
+        'Intermixed named and unicode escapes 1');
+    ok("\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}"=~
+       /\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042}/,
+        'Intermixed named and unicode escapes 2');
+    ok("\N{SPACE}\N{U+0041}\N{SPACE}\N{U+0042} 3"=~
+       /[\N{SPACE}\N{U+0041}][\N{SPACE}\N{U+0042}]/,
+        'Intermixed named and unicode escapes');     
+}
+$brackets = qr{
+                {  (?> [^{}]+ | (??{ $brackets }) )* }
+             }x;
+ok("{b{c}d" !~ m/^((??{ $brackets }))/, "bracket mismatch");
+
+SKIP:{
+    our @stack=();
+    my @expect=qw(
+        stuff1
+        stuff2
+        <stuff1>and<stuff2>
+        right
+        <right>
+        <<right>>
+        <<<right>>>
+        <<stuff1>and<stuff2>><<<<right>>>>
+    );
+
+    local $_='<<<stuff1>and<stuff2>><<<<right>>>>>';
+    ok(/^(<((?:(?>[^<>]+)|(?1))*)>(?{push @stack, $2 }))$/,
+        "Recursion should match");
+    ok(@stack==@expect)
+        or skip("Won't test individual results as count isn't equal",
+                0+@expect);
+    foreach my $idx (@expect) {
+        ok($expect[$idx] eq $stack[$idx], 
+            "Expecting '$expect' at stack pos #$idx");
+    }
+        
+}
+{
+    my $s='123453456';
+    $s=~s/(?<digits>\d+)\k<digits>/$+{digits}/;
+    ok($s eq '123456','Named capture (angle brackets) s///');
+    $s='123453456';
+    $s=~s/(?'digits'\d+)\k'digits'/$+{digits}/;
+    ok($s eq '123456','Named capture (single quotes) s///');    
+}
+sub iseq($$;$) { 
+    my ( $got, $expect, $name)=@_;
+    
+    $_=defined($_) ? "'$_'" : "undef"
+        for $got, $expect;
+        
+    my $ok=  $got eq $expect;
+        
+    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed';
+
+    printf "# Failed test at line %d\n".
+           "# expected: %s\n". 
+           "#   result: %s\n", 
+           (caller)[2], $expect, $got
+        unless $ok;
+
+    $test++;
+    return $ok;
+}   
+{
+    my $s='foo bar baz';
+    my (@k,@v,@fetch,$res);
+    my $count= 0;
+    my @names=qw($+{A} $+{B} $+{C});
+    if ($s=~/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/) {
+        while (my ($k,$v)=each(%+)) {
+            $count++;
+        }
+        @k=sort keys(%+);
+        @v=sort values(%+);
+        $res=1;
+        push @fetch,
+            [ "$+{A}", "$1" ],
+            [ "$+{B}", "$2" ],
+            [ "$+{C}", "$3" ],
+        ;
+    } 
+    foreach (0..2) {
+        if ($fetch[$_]) {
+            iseq($fetch[$_][0],$fetch[$_][1],$names[$_]);
+        } else {
+            ok(0, $names[$_]);
+        }
+    }
+    iseq($res,1,"$s~=/(?<A>foo)\s+(?<B>bar)?\s+(?<C>baz)/");
+    iseq($count,3,"Got 3 keys in %+ via each");
+    iseq(0+@k, 3, 'Got 3 keys in %+ via keys');
+    iseq("@k","A B C", "Got expected keys");
+    iseq("@v","bar baz foo", "Got expected values");
+    eval'
+        print for $+{this_key_doesnt_exist};
+    ';
+    ok(!$@,'lvalue $+{...} should not throw an exception');
+}
+
+# stress test CURLYX/WHILEM.
+#
+# This test includes varying levels of nesting, and according to
+# profiling done against build 28905, exercises every code line in the
+# CURLYX and WHILEM blocks, except those related to LONGJMP, the
+# super-linear cache and warnings. It executes about 0.5M regexes
+
+if ($ENV{PERL_SKIP_PSYCHO_TEST}){
+  printf "ok %d Skip: No psycho tests\n", $test++;
+} else {    
+  my $r = qr/^
+           (?:
+               ( (?:a|z+)+ )
+               (?:
+                   ( (?:b|z+){3,}? )
+                   (
+                       (?:
+                           (?:
+                               (?:c|z+){1,1}?z
+                           )?
+                           (?:c|z+){1,1}
+                       )*
+                   )
+                   (?:z*){2,}
+                   ( (?:z+|d)+ )
+                   (?:
+                       ( (?:e|z+)+ )
+                   )*
+                   ( (?:f|z+)+ )
+               )*
+               ( (?:z+|g)+ )
+               (?:
+                   ( (?:h|z+)+ )
+               )*
+               ( (?:i|z+)+ )
+           )+
+           ( (?:j|z+)+ )
+           (?:
+               ( (?:k|z+)+ )
+           )*
+           ( (?:l|z+)+ )
+       $/x;
+  
+  
+  my $ok = 1;
+  my $msg = "CURLYX stress test";
+  OUTER:
+  for my $a ("x","a","aa") {
+    for my $b ("x","bbb","bbbb") {
+      my $bs = $a.$b;
+      for my $c ("x","c","cc") {
+        my $cs = $bs.$c;
+        for my $d ("x","d","dd") {
+          my $ds = $cs.$d;
+          for my $e ("x","e","ee") {
+            my $es = $ds.$e;
+            for my $f ("x","f","ff") {
+              my $fs = $es.$f;
+              for my $g ("x","g","gg") {
+                my $gs = $fs.$g;
+                for my $h ("x","h","hh") {
+                  my $hs = $gs.$h;
+                  for my $i ("x","i","ii") {
+                    my $is = $hs.$i;
+                    for my $j ("x","j","jj") {
+                      my $js = $is.$j;
+                      for my $k ("x","k","kk") {
+                        my $ks = $js.$k;
+                        for my $l ("x","l","ll") {
+                          my $ls = $ks.$l;
+                          if ($ls =~ $r) {
+                            if ($ls =~ /x/) {
+                              $msg .= ": unexpected match for [$ls]";
+                             $ok = 0;
+                              last OUTER;
+                            }
+                            my $cap = "$1$2$3$4$5$6$7$8$9$10$11$12";
+                            unless ($ls eq $cap) {
+                              $msg .= ": capture: [$ls], got [$cap]";
+                             $ok = 0;
+                              last OUTER;
+                            }
+                          }
+                          else {
+                            unless ($ls =~ /x/) {
+                              $msg = ": failed for [$ls]";
+                             $ok = 0;
+                              last OUTER;
+                            }
+                          }
+                        }
+                      }
+                    }
+                  }
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+  ok($ok, $msg);
+}
+
+# \, breaks {3,4}
+ok("xaaay"    !~ /xa{3\,4}y/, "\, in a pattern");
+ok("xa{3,4}y" =~ /xa{3\,4}y/, "\, in a pattern");
+
+# \c\ followed by _
+ok("x\c_y"    !~ /x\c\_y/,    "\_ in a pattern");
+ok("x\c\_y"   =~ /x\c\_y/,    "\_ in a pattern");
+
+# \c\ followed by other characters
+for my $c ("z", "\0", "!", chr(254), chr(256)) {
+    my $targ = "a\034$c";
+    my $reg  = "a\\c\\$c";
+    ok(eval("qq/$targ/ =~ /$reg/"), "\\c\\ in pattern");
+}
+
+{
+    my $str='abc'; 
+    my $count=0;
+    my $mval=0;
+    my $pval=0;
+    while ($str=~/b/g) { $mval=$#-; $pval=$#+; $count++ }
+    iseq($mval,0,"\@- should be empty [RT#36046]");
+    iseq($pval,0,"\@+ should be empty [RT#36046]");
+    iseq($count,1,"should have matched once only [RT#36046]");
+}
+
+{   # Test the (*NOMATCH) pattern
+    our $count = 0;
+    'aaab'=~/a+b?(?{$count++})(*FAIL)/;
+    iseq($count,9,"expect 9 for no (*NOMATCH)");
+    $count = 0;
+    'aaab'=~/a+b?(*NOMATCH)(?{$count++})(*FAIL)/;
+    iseq($count,3,"expect 3 with (*NOMATCH)");
+    local $_='aaab';
+    $count=0;
+    1 while /.(*NOMATCH)(?{$count++})(*FAIL)/g;
+    iseq($count,4,"/.(*NOMATCH)/");
+    $count = 0;
+    'aaab'=~/a+b?(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/;
+    iseq($count,3,"expect 3 with (*NOMATCH)");
+    local $_='aaab';
+    $count=0;
+    1 while /.(??{'(*NOMATCH)'})(?{$count++})(*FAIL)/g;
+    iseq($count,4,"/.(*NOMATCH)/");
+}
+{   # Test the (*CUT) pattern
+    our $count = 0;
+    'aaab'=~/a+b?(*CUT)(?{$count++})(*FAIL)/;
+    iseq($count,1,"expect 1 with (*CUT)");
+    local $_='aaab';
+    $count=0;
+    1 while /.(*CUT)(?{$count++})(*FAIL)/g;
+    iseq($count,4,"/.(*CUT)/");
+    $_='aaabaaab';
+    $count=0;
+    our @res=();
+    1 while /(a+b?)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g;
+    iseq($count,2,"Expect 2 with (*CUT)" );
+    iseq("@res","aaab aaab","adjacent (*CUT) works as expected" );
+}
+{   # Test the (*CUT) pattern
+    our $count = 0;
+    'aaab'=~/a+b?(*MARK)(*CUT)(?{$count++})(*FAIL)/;
+    iseq($count,1,"expect 1 with (*CUT)");
+    local $_='aaab';
+    $count=0;
+    1 while /.(*MARK)(*CUT)(?{$count++})(*FAIL)/g;
+    iseq($count,4,"/.(*CUT)/");
+    $_='aaabaaab';
+    $count=0;
+    our @res=();
+    1 while /(a+b?)(*MARK)(*CUT)(?{$count++; push @res,$1})(*FAIL)/g;
+    iseq($count,2,"Expect 2 with (*CUT)" );
+    iseq("@res","aaab aaab","adjacent (*CUT) works as expected" );
+}
+{   # Test the (*CUT) pattern
+    our $count = 0;
+    'aaab'=~/a*(*MARK:a)b?(*MARK:b)(*CUT:a)(?{$count++})(*FAIL)/;
+    iseq($count,3,"expect 3 with *MARK:a)b?(*MARK:b)(*CUT:a)");
+    local $_='aaabaaab';
+    $count=0;
+    our @res=();
+    1 while /(a*(*MARK:a)b?)(*MARK)(*CUT:a)(?{$count++; push @res,$1})(*FAIL)/g;
+    iseq($count,5,"Expect 5 with (*MARK:a)b?)(*MARK)(*CUT:a)" );
+    iseq("@res","aaab b aaab b ","adjacent (*MARK:a)b?)(*MARK)(*CUT:a) works as expected" );
+}
+{   # Test the (*COMMIT) pattern
+    our $count = 0;
+    'aaabaaab'=~/a+b?(*COMMIT)(?{$count++})(*FAIL)/;
+    iseq($count,1,"expect 1 with (*COMMIT)");
+    local $_='aaab';
+    $count=0;
+    1 while /.(*COMMIT)(?{$count++})(*FAIL)/g;
+    iseq($count,1,"/.(*COMMIT)/");
+    $_='aaabaaab';
+    $count=0;
+    our @res=();
+    1 while /(a+b?)(*COMMIT)(?{$count++; push @res,$1})(*FAIL)/g;
+    iseq($count,1,"Expect 1 with (*COMMIT)" );
+    iseq("@res","aaab","adjacent (*COMMIT) works as expected" );
+}
+{
+    # Test named commits and the $REGERROR var
+    our $REGERROR;
+    for my $name ('',':foo') 
+    {
+        for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)",
+                         "(*CUT$name)","(*COMMIT$name)")
+        {                         
+            for my $suffix ('(*FAIL)','') 
+            {
+                'aaaab'=~/a+b$pat$suffix/;
+                iseq(
+                    $REGERROR,
+                    ($suffix ? ($name ? 'foo' : "1") : ""),
+                    "Test $pat and \$REGERROR $suffix"
+                );
+            }
+        }
+    }      
+}    
+{
+    # Test named commits and the $REGERROR var
+    package Fnorble;
+    our $REGERROR;
+    for my $name ('',':foo') 
+    {
+        for my $pat ("(*NOMATCH$name)","(*MARK$name)(*CUT)",
+                         "(*CUT$name)","(*COMMIT$name)")
+        {                         
+            for my $suffix ('(*FAIL)','') 
+            {
+                'aaaab'=~/a+b$pat$suffix/;
+                ::iseq(
+                    $REGERROR,
+                    ($suffix ? ($name ? 'foo' : "1") : ""),
+                    "Test $pat and \$REGERROR $suffix"
+                );
+            }
+        }
+    }      
+}    
+{
+    # Test named commits and the $REGERROR var
+    our $REGERROR;
+    for $word (qw(bar baz bop)) {
+        $REGERROR="";
+        "aaaaa$word"=~/a+(?:bar(*COMMIT:bar)|baz(*COMMIT:baz)|bop(*COMMIT:bop))(*FAIL)/;
+        iseq($REGERROR,$word);
+    }    
+}
+{   #Regression test for perlbug 40684
+    my $s = "abc\ndef";
+    my $rex = qr'^abc$'m;
+    ok($s =~ m/$rex/);
+    ok($s =~ m/^abc$/m);
+}
+#-------------------------------------------------------------------
+
+# Keep the following tests last -- they may crash perl
 
 ok(("a" x (2**15 - 10)) =~ /^()(a|bb)*$/, "Recursive stack cracker: #24274")
     or print "# Unexpected outcome: should pass or crash perl\n";
 
-# last test 1231
+ok((q(a)x 100) =~ /^(??{'(.)'x 100})/, 
+        "Regexp /^(??{'(.)'x 100})/ crashes older perls")
+    or print "# Unexpected outcome: should pass or crash perl\n";
+
+{
+    $_="ns1ns1ns1";
+    s/ns(?=\d)/ns_/g;
+    iseq($_,"ns_1ns_1ns_1");
+    $_="ns1";
+    s/ns(?=\d)/ns_/;
+    iseq($_,"ns_1");
+    $_="123";
+    s/(?=\d+)|(?<=\d)/!Bang!/g;
+    iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
+}
+
+# Put new tests above the line, not here.
+
+# Don't forget to update this!
+BEGIN{print "1..1347\n"};
+