From: yves orton <bugs-perl5@bugs6.perl.org>
Date: Fri, 17 Nov 2006 16:07:00 +0000 (+0000)
Subject: [perl #36909] $^R undefined on matches involving backreferences
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f0852a51af159e1bea17f91d673cfba18804cbb5;p=p5sagit%2Fp5-mst-13.2.git

[perl #36909] $^R undefined on matches involving backreferences
From: yves orton via RT <bugs-perl5@bugs6.perl.org>
Date: Nov 17, 2006 4:07 PM

p4raw-id: //depot/perl@29308
---

diff --git a/regexec.c b/regexec.c
index d547ff7..8abe220 100644
--- a/regexec.c
+++ b/regexec.c
@@ -3867,7 +3867,15 @@ NULL
 	}
 
 	case CURLYX_end: /* just finished matching all of A*B */
-	    regcpblow(ST.cp);
+	    if (PL_reg_eval_set){
+		SV *pres= GvSV(PL_replgv);
+		SvREFCNT_inc(pres);
+		regcpblow(ST.cp);
+		sv_setsv(GvSV(PL_replgv), pres);
+		SvREFCNT_dec(pres);
+	    } else {
+		regcpblow(ST.cp);
+	    }
 	    cur_curlyx = ST.prev_curlyx;
 	    sayYES;
 	    /* NOTREACHED */
diff --git a/t/op/pat.t b/t/op/pat.t
index 5ab10d0..68328f8 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -12,6 +12,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
 }
+our $Message = "Line";
 
 eval 'use Config';          #  Defaults assumed if this fails
 
@@ -2037,7 +2038,8 @@ $test = 687;
 sub ok ($;$) {
     my($ok, $name) = @_;
 
-    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed';
+    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
+        $name||"$Message:".((caller)[2]);
 
     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
 
@@ -3673,7 +3675,8 @@ sub iseq($$;$) {
         
     my $ok=  $got eq $expect;
         
-    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test, $name||'unnamed';
+    printf "%sok %d - %s\n", ($ok ? "" : "not "), $test,
+        $name||"$Message:".((caller)[2]);
 
     printf "# Failed test at line %d\n".
            "# expected: %s\n". 
@@ -3973,6 +3976,7 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
 }    
 {
     # Test named commits and the $REGERROR var
+    local $Message = "\$REGERROR";
     our $REGERROR;
     for $word (qw(bar baz bop)) {
         $REGERROR="";
@@ -3981,6 +3985,7 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
     }    
 }
 {   #Regression test for perlbug 40684
+    local $Message = "RT#40684 tests:";
     my $s = "abc\ndef";
     my $rex = qr'^abc$'m;
     ok($s =~ m/$rex/);
@@ -3994,6 +3999,7 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
 }
 
 {
+    local $Message = "Relative Recursion";
     my $parens=qr/(\((?:[^()]++|(?-1))*+\))/;
     local $_='foo((2*3)+4-3) + bar(2*(3+4)-1*(2-3))';
     my ($all,$one,$two)=('','','');
@@ -4015,6 +4021,39 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
     iseq($_,$spaces,"SUSPEND final string");
     iseq($count,1,"Optimiser should have prevented more than one match");
 }
+{
+    local $Message = "RT#36909 test";
+    $^R = 'Nothing';
+    {
+        local $^R = "Bad";
+        ok('x foofoo y' =~ m{
+         (foo) # $^R correctly set
+        (?{ "last regexp code result" })
+        }x);
+        iseq($^R,'last regexp code result');
+    }
+    iseq($^R,'Nothing');
+    {
+        local $^R = "Bad";
+
+        ok('x foofoo y' =~ m{
+         (?:foo|bar)+ # $^R correctly set
+        (?{"last regexp code result"})
+        }x);
+        iseq($^R,'last regexp code result');
+    }
+    iseq($^R,'Nothing');
+
+    {
+        local $^R = "Bad";
+        ok('x foofoo y' =~ m{
+         (foo|bar)\1+ # $^R undefined
+        (?{"last regexp code result"})
+        }x);
+        iseq($^R,'last regexp code result');
+    }
+    iseq($^R,'Nothing');
+}
 
 # Test counter is at bottom of file. Put new tests above here.
 #-------------------------------------------------------------------
@@ -4046,6 +4085,7 @@ ok((q(a)x 100) =~ /^(??{'(.)'x 100})/,
     or print "# Unexpected outcome: should pass or crash perl\n";
 
 {
+    local $Message = "substituation with lookahead (possible segv)";
     $_="ns1ns1ns1";
     s/ns(?=\d)/ns_/g;
     iseq($_,"ns_1ns_1ns_1");
@@ -4060,4 +4100,4 @@ ok((q(a)x 100) =~ /^(??{'(.)'x 100})/,
 # Put new tests above the dotted line about a page above this comment
 
 # Don't forget to update this!
-BEGIN { print "1..1349\n" };
+BEGIN { print "1..1358\n" };
diff --git a/t/op/subst.t b/t/op/subst.t
index 0b02ff9..d6e5f51 100755
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 133 );
+plan( tests => 134 );
 
 $x = 'foo';
 $_ = "x";
@@ -562,4 +562,13 @@ is($name, "cis", q[#22351 bug with 'e' substitution modifier]);
     ($c = "\x20\x00\x30\x01\x40\x1A\x50\x1F\x60") =~ s/[\x00-\x1f]//g;
     is($c, "\x20\x30\x40\x50\x60", "s/[\\x00-\\x1f]//g");
 }
+TODO:{
+    local $TODO = "RT#6006 needs resolution";
+    $TODO=$TODO;
+    $_ = "xy";
+    no warnings 'uninitialized';
+    /(((((((((x)))))))))(z)/;	# clear $10
+    s/(((((((((x)))))))))(y)/${10}/;
+    is($_,"y","RT#6006: \$_ eq '$_'");
+}
 
diff --git a/win32/Makefile b/win32/Makefile
index 99ca522..87b111c 100644
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -1363,7 +1363,7 @@ test-reonly : reonly utils
 	$(XCOPY) $(PERLDLL) ..\t\$(NULL)
 	$(XCOPY) $(GLOBEXE) ..\t\$(NULL)
 	cd ..\t
-	$(PERLEXE) -I..\lib harness $(OPT) -re \bpat\b \breg \bre\b $(EXTRA)
+	$(PERLEXE) -I..\lib harness $(OPT) -re \bpat\b \breg \bre\b \bsubst $(EXTRA)
 	cd ..\win32
 
 regen :