From: Dave Mitchell <davem@fdisolutions.com>
Date: Sun, 1 Apr 2007 00:27:02 +0000 (+0000)
Subject: fix $^R scoping bug.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=19b95bf092bc6fdb9455fe107fc46111b0a1ec31;p=p5sagit%2Fp5-mst-13.2.git

fix $^R scoping bug.
By setting the outer saved $^R to the current $^R just at the
end of a successful match, and ensuring that that the savestack
doesn't get popped beforehand, the code is simplified and fixes a
bug.

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

diff --git a/regexec.c b/regexec.c
index b9ce5f9..470f251 100644
--- a/regexec.c
+++ b/regexec.c
@@ -1690,7 +1690,6 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
     I32 end_shift = 0;			/* Same for the end. */		/* CC */
     I32 scream_pos = -1;		/* Internal iterator of scream. */
     char *scream_olds = NULL;
-    SV* const oreplsv = GvSV(PL_replgv);
     const bool do_utf8 = (bool)DO_UTF8(sv);
     I32 multiline;
     RXi_GET_DECL(prog,progi);
@@ -2076,14 +2075,8 @@ Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *
 got_it:
     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
 
-    if (PL_reg_eval_set) {
-	/* Preserve the current value of $^R */
-	if (oreplsv != GvSV(PL_replgv))
-	    sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
-						  restored, the value remains
-						  the same. */
+    if (PL_reg_eval_set)
 	restore_pos(aTHX_ prog);
-    }
     if (prog->paren_names) 
         (void)hv_iterinit(prog->paren_names);
 
@@ -2655,6 +2648,8 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                                during a successfull match */
     U32 lastopen = 0;       /* last open we saw */
     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;   
+
+    SV* const oreplsv = GvSV(PL_replgv);
                
     
     /* these three flags are set by various ops to signal information to
@@ -3955,15 +3950,6 @@ NULL
 	}
 
 	case CURLYX_end: /* just finished matching all of A*B */
-	    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 */
@@ -5081,6 +5067,15 @@ yes:
     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
 			  PL_colors[4], PL_colors[5]));
 
+    if (PL_reg_eval_set) {
+	/* each successfully executed (?{...}) block does the equivalent of
+	 *   local $^R = do {...}
+	 * When popping the save stack, all these locals would be undone;
+	 * bypass this by setting the outermost saved $^R to the latest
+	 * value */
+	if (oreplsv != GvSV(PL_replgv))
+	    sv_setsv(oreplsv, GvSV(PL_replgv));
+    }
     result = 1;
     goto final_exit;
 
@@ -5137,6 +5132,7 @@ no_silent:
         sv_setsv(sv_err, sv_commit);
         sv_setsv(sv_mrk, sv_yes_mark);
     }
+
     /* restore original high-water mark */
     PL_regmatch_slab  = orig_slab;
     PL_regmatch_state = orig_state;
diff --git a/t/op/pat.t b/t/op/pat.t
index 71ddbe9..6d3cafd 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -4127,6 +4127,16 @@ for my $c ("z", "\0", "!", chr(254), chr(256)) {
         iseq($^R,'last regexp code result');
     }
     iseq($^R,'Nothing');
+
+    {
+        local $^R = "Bad";
+        ok('x foofoo y' =~ m{
+         (foo|bar)\1 # this time without the +
+        (?{"last regexp code result"})
+        }x);
+        iseq($^R,'last regexp code result');
+    }
+    iseq($^R,'Nothing');
 }
 {
     local $Message="RT#22395";
@@ -4405,7 +4415,7 @@ ok($@=~/\QSequence \k... not terminated in regex;\E/);
 iseq(0+$::test,$::TestCount,"Got the right number of tests!");
 # Don't forget to update this!
 BEGIN {
-    $::TestCount = 1655;
+    $::TestCount = 1658;
     print "1..$::TestCount\n";
 }