save paren positions when running (?{}) code

Currently, all paren positions are saved before and after executing the
regops returned by (??{}); but not while the perl ops are being executed
beforehand. If the code happens to do a pattern match against the same
regex that's being currently run, then all iuts oparen positions will be
overwritten. So save them before entering the RUNOPS loop too.

2 files changed, 111 insertions, 6 deletions

diff --git a/regexec.c b/regexec.c
index a20b60a21a..2d86b0e41e 100644
--- a/regexec.c
+++ b/regexec.c
@@ -477,6 +477,18 @@ S_regcppop(pTHX_ regexp *rex)
 #endif
 }
 
+/* restore the parens and associated vars at savestack position ix,
+ * but without popping the stack */
+
+STATIC void
+S_regcp_restore(pTHX_ regexp *rex, I32 ix)
+{
+    I32 tmpix = PL_savestack_ix;
+    PL_savestack_ix = ix;
+    regcppop(rex);
+    PL_savestack_ix = tmpix;
+}
+
 #define regcpblow(cp) LEAVE_SCOPE(cp)	/* Ignores regcppush()ed data. */
 
 /*
@@ -3138,6 +3150,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
     I32 gimme = G_SCALAR;
     CV *caller_cv = NULL;	/* who called us */
     CV *last_pushed_cv = NULL;	/* most recently called (?{}) CV */
+    CHECKPOINT runops_cp;	/* savestack position before executing EVAL */
 
 #ifdef DEBUGGING
     GET_RE_DEBUG_FLAGS_DECL;
@@ -4269,6 +4282,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
 		struct re_save_state saved_state;
 		CV *newcv;
 
+		/* save *all* paren positions */
+		regcppush(rex, 0);
+		REGCP_SET(runops_cp);
+
 		/* To not corrupt the existing regex state while executing the
 		 * eval we would normally put it on the save stack, like with
 		 * save_re_context. However, re-evals have a weird scoping so we
@@ -4398,6 +4415,11 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
 		PL_regeol = saved_regeol;
 		if (!logical) {
 		    /* /(?{...})/ */
+		    /* restore all paren positions. Note that where the
+		     * return value is used, we must delay this as the
+		     * returned string to be compiled may be $1 for
+		     * example */
+		    S_regcp_restore(aTHX_ rex, runops_cp);
 		    sv_setsv(save_scalar(PL_replgv), ret);
 		    break;
 		}
@@ -4471,6 +4493,10 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
 			    sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
 			}
 			PL_regsize = osize;
+			/* safe to do now that any $1 etc has been
+			 * interpolated into the new pattern string and
+			 * compiled */
+			S_regcp_restore(aTHX_ rex, runops_cp);
 		    }
 		    re_sv = rx;
 		    re = (struct regexp *)SvANY(rx);
@@ -4523,6 +4549,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
 	    }
 	    /* logical is 1,   /(?(?{...})X|Y)/ */
 	    sw = cBOOL(SvTRUE(ret));
+	    S_regcp_restore(aTHX_ rex, runops_cp);
 	    logical = 0;
 	    break;
 	}
@@ -5568,7 +5595,6 @@ NULL
 	    fake_end:
 	    if (cur_eval) {
 		/* we've just finished A in /(??{A})B/; now continue with B */
-		I32 tmpix;
 		st->u.eval.toggle_reg_flags
 			    = cur_eval->u.eval.toggle_reg_flags;
 		PL_reg_flags ^= st->u.eval.toggle_reg_flags; 
@@ -5586,10 +5612,7 @@ NULL
 
 		/* Restore parens of the outer rex without popping the
 		 * savestack */
-		tmpix = PL_savestack_ix;
-		PL_savestack_ix = cur_eval->u.eval.lastcp;
-		regcppop(rex);
-		PL_savestack_ix = tmpix;
+		S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp);
 
 		st->u.eval.prev_eval = cur_eval;
 		cur_eval = cur_eval->u.eval.prev_eval;
diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t
index 20dbf06984..338f5c2be0 100644
--- a/t/re/pat_re_eval.t
+++ b/t/re/pat_re_eval.t
@@ -23,7 +23,7 @@ BEGIN {
 }
 
 
-plan tests => 434;  # Update this when adding/deleting tests.
+plan tests => 444;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -835,6 +835,88 @@ sub run_tests {
 	recurse2(5);
     }
 
+    # nested (??{}) called from various levels of a recursive function
+
+    {
+	sub recurse3 {
+	    my ($n) = @_;
+	    return if $n > 3;
+	    ok("A$n" =~ m{^A(??{ "0123" =~ /((??{$n}))/; $1 })$},
+		"recurse3($n)");
+	    ok("A$n" !~ m{^A(??{ "0123" =~ /((??{$n}))/; "X" })$},
+		"recurse3($n) nomatch");
+	    recurse3($n+1);
+	}
+	recurse3(0);
+    }
+
+    # nested (??{}) being invoked recursively via a function
+
+    {
+	my $s = '';
+	our $recurse4;
+	my @alpha = qw(A B C D E);
+	$recurse4 = sub {
+	    my ($n) = @_;
+	    $s .= "(n=$n:";
+	    if ($n < 4) {
+		my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
+		    m{^([A-Z])
+		      (??{
+			    $s .= "1=$1:";
+			    "$n-0123" =~ m{^(\d)-(((??{$recurse4->($n+1)})))};
+			    $s .= "i1=$1:<=[$2]";
+			    $3; # NB - not stringified
+		       })
+		       $
+		     }x;
+		$s .= "1a=$1:";
+		$s .= $m ? 'M' : '!M';
+	    }
+	    my $ret =  '.*?' . ($n-1);
+	    $s .= "<=[$ret])";
+	    return $ret;
+	};
+	$recurse4->(0);
+	my $exp =   '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
+		  . 'i1=3:<=[0123]1a=D:M<=[.*?2])i1=2:<=[012]1a=C:M<=[.*?1])'
+		  . 'i1=1:<=[01]1a=B:M<=[.*?0])i1=0:<=[0]1a=A:M<=[.*?-1])';
+	is($s, $exp, 'recurse4');
+    }
+
+    # single (??{}) being invoked recursively via a function
+
+    {
+	my $s = '';
+	our $recurse5;
+	my @alpha = qw(A B C D E);
+	$recurse5 = sub {
+	    my ($n) = @_;
+	    $s .= "(n=$n:";
+	    if ($n < 4) {
+		my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
+		    m{^([A-Z])
+		      ((??{
+			    $s .= "1=$1:";
+			    $recurse5->($n+1);
+		       }))
+		       $
+		     }x;
+		$s .= "1a=$1:2=$2:";
+		$s .= $m ? 'M' : '!M';
+	    }
+	    my $ret =  '.*?' . ($n-1);
+	    $s .= "<=[$ret])";
+	    return $ret;
+	};
+	$recurse5->(0);
+	my $exp =   '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
+		  . '1a=D:2=0123:M<=[.*?2])1a=C:2=012:M<=[.*?1])'
+		  . '1a=B:2=01:M<=[.*?0])1a=A:2=0:M<=[.*?-1])';
+	is($s, $exp, 'recurse5');
+    }
+
+
     # make sure that errors during compiling run-time code get trapped
 
     {