From: David Mitchell Date: Thu, 8 Apr 2010 12:16:56 +0000 (+0100) Subject: fix RT 23810: eval and tied methods X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=27e904532594b7fb224bdf9a05bf3b5336b8a39e;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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, + * 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 --- 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 +