fix RT 23810: eval and tied methods

Something like the following ended up corrupted:
    sub FETCH { eval 'BEGIN{syntax err}' }
The croak on error popped back the context stack etc to the EVAL pushed by
entereval, but the corresponding JUMPENV_PUSH(3) unwound all the way to the
outer perl_run, losing all the mg_get() related parts of the C stack.

It turns out that the run-time parts of pp_entereval were protected with
a new JUMPENV level, but the compile-time parts weren't. Add this.

diff --git a/pp_ctl.c b/pp_ctl.c
index 80c7b22..bbb2d15 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1653,6 +1653,10 @@ Perl_die_where(pTHX_ SV *msv)
                SV * const nsv = cx->blk_eval.old_namesv;
                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
                                &PL_sv_undef, 0);
+               /* note that unlike pp_entereval, pp_require isn't
+                * supposed to trap errors. So now that we've popped the
+                * EVAL that pp_require pushed, and processed the error
+                * message, rethrow the error */
                DIE(aTHX_ "%sCompilation failed in require",
                    *msg ? msg : "Unknown error\n");
            }
@@ -3041,6 +3045,35 @@ Perl_find_runcv(pTHX_ U32 *db_seqp)
 }
 
 
+/* Run yyparse() in a setjmp wrapper. Returns:
+ *   0: yyparse() successful
+ *   1: yyparse() failed
+ *   3: yyparse() died
+ */
+STATIC int
+S_try_yyparse(pTHX)
+{
+    int ret;
+    dJMPENV;
+
+    assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+    JMPENV_PUSH(ret);
+    switch (ret) {
+    case 0:
+       ret = yyparse() ? 1 : 0;
+       break;
+    case 3:
+       break;
+    default:
+       JMPENV_POP;
+       JMPENV_JUMP(ret);
+       /* NOTREACHED */
+    }
+    JMPENV_POP;
+    return ret;
+}
+
+
 /* Compile a require/do, an eval '', or a /(?{...})/.
  * In the last case, startop is non-null, and contains the address of
  * a pointer that should be set to the just-compiled code.
@@ -3055,8 +3088,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 {
     dVAR; dSP;
     OP * const saveop = PL_op;
+    bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
+    int yystatus;
 
-    PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+    PL_in_eval = (in_require
                  ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
                  : EVAL_INEVAL);
 
@@ -3108,27 +3143,39 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
        PL_in_eval |= EVAL_KEEPERR;
     else
        CLEAR_ERRSV();
-    if (yyparse() || PL_parser->error_count || !PL_eval_root) {
+
+    /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
+     * so honour CATCH_GET and trap it here if necessary */
+
+    yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
+
+    if (yystatus || PL_parser->error_count || !PL_eval_root) {
        SV **newsp;                     /* Used by POPBLOCK. */
        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
-       I32 optype = 0;                 /* Might be reset by POPEVAL. */
+       I32 optype;                     /* Used by POPEVAL. */
        const char *msg;
 
+       PERL_UNUSED_VAR(newsp);
+       PERL_UNUSED_VAR(optype);
+
        PL_op = saveop;
        if (PL_eval_root) {
            op_free(PL_eval_root);
            PL_eval_root = NULL;
        }
-       SP = PL_stack_base + POPMARK;           /* pop original mark */
-       if (!startop) {
-           POPBLOCK(cx,PL_curpm);
-           POPEVAL(cx);
+       if (yystatus != 3) {
+           SP = PL_stack_base + POPMARK;       /* pop original mark */
+           if (!startop) {
+               POPBLOCK(cx,PL_curpm);
+               POPEVAL(cx);
+           }
        }
        lex_end();
-       LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
+       if (yystatus != 3)
+           LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
 
        msg = SvPVx_nolen_const(ERRSV);
-       if (optype == OP_REQUIRE) {
+       if (in_require) {
            const SV * const nsv = cx->blk_eval.old_namesv;
            (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
                           &PL_sv_undef, 0);
@@ -3136,8 +3183,10 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
                       *msg ? msg : "Unknown error\n");
        }
        else if (startop) {
-           POPBLOCK(cx,PL_curpm);
-           POPEVAL(cx);
+           if (yystatus != 3) {
+               POPBLOCK(cx,PL_curpm);
+               POPEVAL(cx);
+           }
            Perl_croak(aTHX_ "%sCompilation failed in regexp",
                       (*msg ? msg : "Unknown error\n"));
        }
@@ -3146,7 +3195,6 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
                sv_setpvs(ERRSV, "Compilation error");
            }
        }
-       PERL_UNUSED_VAR(newsp);
        PUSHs(&PL_sv_undef);
        PUTBACK;
        return FALSE;

diff --git a/t/op/tie.t b/t/op/tie.t
index a2e1d4a..0ec8050 100644 (file)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -658,3 +658,93 @@ sub STORE {
 tie $SELECT, 'main';
 $SELECT = *STDERR;
 EXPECT
+########
+# RT 23810: eval in die in FETCH can corrupt context stack
+
+my $file = 'rt23810.pm';
+
+my $e;
+my $s;
+
+sub do_require {
+    my ($str, $eval) = @_;
+    open my $fh, '>', $file or die "Can't create $file: $!\n";
+    print $fh $str;
+    close $fh;
+    if ($eval) {
+       $s .= '-ERQ';
+       eval { require $pm; $s .= '-ENDE' }
+    }
+    else {
+       $s .= '-RQ';
+       require $pm;
+    }
+    $s .= '-ENDRQ';
+    unlink $file;
+}
+
+sub TIEHASH { bless {} }
+
+sub FETCH {
+    # 10 or more syntax errors makes yyparse croak()
+    my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
+
+    if ($_[1] eq 'eval') {
+       $s .= 'EVAL';
+       eval q[BEGIN { die; $s .= '-X1' }];
+       $s .= '-BD';
+       eval q[BEGIN { $x+ }];
+       $s .= '-BS';
+       eval '$x+';
+       $s .= '-E1';
+       $s .= '-S1' while $@ =~ /syntax error at/g;
+       eval $bad;
+       $s .= '-E2';
+       $s .= '-S2' while $@ =~ /syntax error at/g;
+    }
+    elsif ($_[1] eq 'require') {
+       $s .= 'REQUIRE';
+       my @text = (
+           q[BEGIN { die; $s .= '-X1' }],
+           q[BEGIN { $x+ }],
+           '$x+',
+           $bad
+       );
+       for my $i (0..$#text) {
+           $s .= "-$i";
+           do_require($txt[$i], 0) if $e;;
+           do_require($txt[$i], 1);
+       }
+    }
+    elsif ($_[1] eq 'exit') {
+       eval q[exit(0); print "overshot eval\n"];
+    }
+    else {
+       print "unknown key: '$_[1]'\n";
+    }
+    return "-R";
+}
+my %foo;
+tie %foo, "main";
+
+for my $action(qw(eval require)) {
+    $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
+    $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
+    $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
+    $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
+}
+1 while unlink $file;
+
+$foo{'exit'};
+print "overshot main\n"; # shouldn't reach here
+
+EXPECT
+eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
+require: s1=REQUIRE-0-RQ
+require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
+require: s3=REQUIRE-0-RQ
+