In perl.git, the branch davem/post-5.12 has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/27e904532594b7fb224bdf9a05bf3b5336b8a39e?hp=1c98cc53150c48606faf09909b3bb3a4ebdd329f>
- Log -----------------------------------------------------------------
commit 27e904532594b7fb224bdf9a05bf3b5336b8a39e
Author: David Mitchell <da...@iabyn.com>
Date: Thu Apr 8 13:16:56 2010 +0100
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.
M pp_ctl.c
M t/op/tie.t
commit 91e35ba127b7082418836f7f9f428e4d2f9b5745
Author: David Mitchell <da...@iabyn.com>
Date: Tue Apr 6 20:53:45 2010 +0100
more mods to -Dl debugging output
M cop.h
-----------------------------------------------------------------------
Summary of changes:
cop.h | 15 ++++------
pp_ctl.c | 72 ++++++++++++++++++++++++++++++++++++++++--------
t/op/tie.t | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 156 insertions(+), 21 deletions(-)
diff --git a/cop.h b/cop.h
index 2d0a459..6c51d73 100644
--- a/cop.h
+++ b/cop.h
@@ -103,9 +103,8 @@ typedef struct jmpenv JMPENV;
DEBUG_l({ \
int i = 0; JMPENV *p = PL_top_env; \
while (p) { i++; p = p->je_prev; } \
- Perl_deb(aTHX_ "push JUMPLEVEL %d (now %p, was %p) at %s:%d\n",\
- i, (void*)&cur_env, (void*)PL_top_env, \
- __FILE__, __LINE__);}) \
+ Perl_deb(aTHX_ "JUMPENV_PUSH level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
cur_env.je_prev = PL_top_env; \
OP_REG_TO_MEM; \
cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf,
SCOPE_SAVES_SIGNAL_MASK); \
@@ -120,9 +119,8 @@ typedef struct jmpenv JMPENV;
DEBUG_l({ \
int i = -1; JMPENV *p = PL_top_env; \
while (p) { i++; p = p->je_prev; } \
- Perl_deb(aTHX_ "pop JUMPLEVEL %d (now %p, was %p) at %s:%d\n",\
- i, (void*)cur_env.je_prev, (void*)PL_top_env, \
- __FILE__, __LINE__);}) \
+ Perl_deb(aTHX_ "JUMPENV_POP level=%d at %s:%d\n", \
+ i, __FILE__, __LINE__);}) \
assert(PL_top_env == &cur_env); \
PL_top_env = cur_env.je_prev; \
} STMT_END
@@ -132,9 +130,8 @@ typedef struct jmpenv JMPENV;
DEBUG_l({ \
int i = -1; JMPENV *p = PL_top_env; \
while (p) { i++; p = p->je_prev; } \
- Perl_deb(aTHX_ "JUMP JUMPLEVEL %d (%p) at %s:%d\n", \
- i, (void*)PL_top_env, \
- __FILE__, __LINE__);}) \
+ Perl_deb(aTHX_ "JUMPENV_JUMP(%d) level=%d at %s:%d\n", \
+ (int)v, i, __FILE__, __LINE__);}) \
OP_REG_TO_MEM; \
if (PL_top_env->je_prev) \
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
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<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
--- 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
+
--
Perl5 Master Repository
