From 410be5dba347e0340059d489e15d034982d73278 Mon Sep 17 00:00:00 2001 From: Dave Mitchell Date: Tue, 10 Jul 2007 23:51:58 +0000 Subject: [PATCH] Fix assertion failure on failed magic eval - eg FETCH {eval'('} S_doeval()'s behaviour varies depending on whether the code compiles or not; on failure it pops the EVAL context block. This is bad because later on, S_docatch() assumes that the block is still there. Make docatch() return a boolean instead, indicating success. The value it formerly returned (the next op) can be deduced as PL_eval_start or PL_op->op_next on success/failure. p4raw-id: //depot/perl@31582 --- embed.fnc | 2 +- pp_ctl.c | 32 ++++++++++++++++++++------------ proto.h | 4 +--- t/op/eval.t | 23 ++++++++++++++++++++++- 4 files changed, 44 insertions(+), 17 deletions(-) diff --git a/embed.fnc b/embed.fnc index 93c0a2e..022b683 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1320,7 +1320,7 @@ sR |I32 |dopoptosub |I32 startingblock sR |I32 |dopoptosub_at |NN const PERL_CONTEXT* cxstk|I32 startingblock sR |I32 |dopoptowhen |I32 startingblock s |void |save_lines |NULLOK AV *array|NN SV *sv -sR |OP* |doeval |int gimme|NULLOK OP** startop|NULLOK CV* outside|U32 seq +s |bool |doeval |int gimme|NULLOK OP** startop|NULLOK CV* outside|U32 seq sR |PerlIO *|check_type_and_open|NN const char *name|NN const char *mode sR |PerlIO *|doopen_pm |NN const char *name|NN const char *mode sRn |bool |path_is_absolute|NN const char *name diff --git a/pp_ctl.c b/pp_ctl.c index c6ee3f7..b16d97e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2737,7 +2737,6 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) I32 gimme = G_VOID; I32 optype; OP dummy; - OP *rop; char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; @@ -2795,9 +2794,9 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PUSHEVAL(cx, 0, NULL); if (runtime) - rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); else - rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); + (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2815,7 +2814,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(optype); - return rop; + return PL_eval_start; } @@ -2864,9 +2863,12 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) * In the last case, startop is non-null, and contains the address of * a pointer that should be set to the just-compiled code. * outside is the lexically enclosing CV (if any) that invoked us. + * Returns a bool indicating whether the compile was successful; if so, + * PL_eval_start contains the first op of the compiled ocde; otherwise, + * pushes undef (also croaks if startop != NULL). */ -STATIC OP * +STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dVAR; dSP; @@ -2963,7 +2965,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } } PERL_UNUSED_VAR(newsp); - RETPUSHUNDEF; + PUSHs(&PL_sv_undef); + PUTBACK; + return FALSE; } CopLINE_set(&PL_compiling, 0); if (startop) { @@ -3010,7 +3014,8 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_op = saveop; /* The caller may need it. */ PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ - RETURNOP(PL_eval_start); + PUTBACK; + return TRUE; } STATIC PerlIO * @@ -3410,7 +3415,10 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = NULL; - op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq)); + if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) + op = DOCATCH(PL_eval_start); + else + op = PL_op->op_next; /* Restore encoding. */ PL_encoding = encoding; @@ -3429,7 +3437,7 @@ PP(pp_entereval) char *tmpbuf = tbuf; char *safestr; STRLEN len; - OP *ret; + bool ok; CV* runcv; U32 seq; HV *saved_hh = NULL; @@ -3502,13 +3510,13 @@ PP(pp_entereval) if (PERLDB_LINE && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); PUTBACK; - ret = doeval(gimme, NULL, runcv, seq); + ok = doeval(gimme, NULL, runcv, seq); if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ - && ret != PL_op->op_next) { /* Successive compilation. */ + && ok) { /* Copy in anything fake and short. */ my_strlcpy(safestr, fakestr, fakelen); } - return DOCATCH(ret); + return ok ? DOCATCH(PL_eval_start) : PL_op->op_next; } PP(pp_leaveeval) diff --git a/proto.h b/proto.h index e67f028..a519ef2 100644 --- a/proto.h +++ b/proto.h @@ -3546,9 +3546,7 @@ STATIC I32 S_dopoptowhen(pTHX_ I32 startingblock) STATIC void S_save_lines(pTHX_ AV *array, SV *sv) __attribute__nonnull__(pTHX_2); -STATIC OP* S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) - __attribute__warn_unused_result__; - +STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq); STATIC PerlIO * S_check_type_and_open(pTHX_ const char *name, const char *mode) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1) diff --git a/t/op/eval.t b/t/op/eval.t index 7ab73ed..57e39dd 100755 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..93\n"; +print "1..94\n"; eval 'print "ok 1\n";'; @@ -458,3 +458,24 @@ print "ok $test - eval and last\n"; $test++; print "ok $test # eval unef \n"; $test++; } + +# a syntax error in an eval called magically 9eg vie tie or overload) +# resulted in an assertion failure in S_docatch, since doeval had already +# poppedthe EVAL context due to the failure, but S_docatch expected the +# context to still be there. + +{ + my $ok = 0; + package Eval1; + sub STORE { eval '('; $ok = 1 } + sub TIESCALAR { bless [] } + + my $x; + tie $x, bless []; + $x = 1; + print "not " unless $ok; + print "ok $test # eval docatch \n"; $test++; +} + + + -- 2.7.4