Properly restore PL_curcop after /(?{})/

C</$code/ or die> was reporting the place of dying as being in
an eval rather than in the main body of the code. This was because
when calling the code, we were setting PL_curcop to the inner code block
*before* doing the PUSH_MULTICALL, which happens to save PL_curcop;
the wrong value was then  being restored at the end of the function with
the POP_MULTICALL.

The fix is easy: just swap the two blocks of code that set PL_curcop and
do the PUSH_MULTICALL.

diff --git a/regexec.c b/regexec.c
index 702a5c7..ca6e645 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -4328,6 +4328,26 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                    nop = (OP*)rexi->data->data[n];
                }
 
+               /* normally if we're about to execute code from the same
+                * CV that we used previously, we just use the existing
+                * CX stack entry. However, its possible that in the
+                * meantime we may have backtracked, popped from the save
+                * stack, and undone the SAVECOMPPAD(s) associated with
+                * PUSH_MULTICALL; in which case PL_comppad no longer
+                * points to newcv's pad. */
+               if (newcv != last_pushed_cv || PL_comppad != last_pad)
+               {
+                   I32 depth = (newcv == caller_cv) ? 0 : 1;
+                   if (last_pushed_cv) {
+                       CHANGE_MULTICALL_WITHDEPTH(newcv, depth);
+                   }
+                   else {
+                       PUSH_MULTICALL_WITHDEPTH(newcv, depth);
+                   }
+                   last_pushed_cv = newcv;
+               }
+               last_pad = PL_comppad;
+
                /* the initial nextstate you would normally execute
                 * at the start of an eval (which would cause error
                 * messages to come from the eval), may be optimised
@@ -4363,26 +4383,6 @@ S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
                DEBUG_STATE_r( PerlIO_printf(Perl_debug_log, 
                    "  re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
 
-               /* normally if we're about to execute code from the same
-                * CV that we used previously, we just use the existing
-                * CX stack entry. However, its possible that in the
-                * meantime we may have backtracked, popped from the save
-                * stack, and undone the SAVECOMPPAD(s) associated with
-                * PUSH_MULTICALL; in which case PL_comppad no longer
-                * points to newcv's pad. */
-               if (newcv != last_pushed_cv || PL_comppad != last_pad)
-               {
-                   I32 depth = (newcv == caller_cv) ? 0 : 1;
-                   if (last_pushed_cv) {
-                       CHANGE_MULTICALL_WITHDEPTH(newcv, depth);
-                   }
-                   else {
-                       PUSH_MULTICALL_WITHDEPTH(newcv, depth);
-                   }
-                   last_pushed_cv = newcv;
-               }
-               last_pad = PL_comppad;
-
                rex->offs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
 
                 if (sv_yes_mark) {

diff --git a/t/re/reg_eval_scope.t b/t/re/reg_eval_scope.t
index 04411fe..46b9bb2 100644 (file)
--- a/t/re/reg_eval_scope.t
+++ b/t/re/reg_eval_scope.t
@@ -9,7 +9,7 @@ BEGIN {
     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
 }
 
-plan 30;
+plan 34;
 
 fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
  my $x = 7; my $a = 4; my $b = 5;
@@ -255,3 +255,30 @@ pass "undef *_ in a re-eval does not cause a double free";
     ("a" x 40_000) =~ /^$qr(ab*)+/; my $line = __LINE__;
     like($w, qr/recursion limit.* line $line\b/, "warning on right line");
 }
+
+# on immediate exit from pattern with code blocks, make sure PL_curcop is
+# restored
+
+{
+    use re 'eval';
+
+    my $c = '(?{"1"})';
+    my $w = '';
+    my $l;
+
+    local $SIG{__WARN__} = sub { $w .= "@_" };
+    $l = __LINE__; "1" =~ /^1$c/x and warn "foo";
+    like($w, qr/foo.+line $l/, 'curcop 1');
+
+    $w = '';
+    $l = __LINE__; "4" =~ /^1$c/x or warn "foo";
+    like($w, qr/foo.+line $l/, 'curcop 2');
+
+    $c = '(??{"1"})';
+    $l = __LINE__; "1" =~ /^$c/x and warn "foo";
+    like($w, qr/foo.+line $l/, 'curcop 3');
+
+    $w = '';
+    $l = __LINE__; "4" =~ /^$c/x or warn "foo";
+    like($w, qr/foo.+line $l/, 'curcop 4');
+}