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

4 files changed, 44 insertions, 17 deletions

diff --git a/embed.fnc b/embed.fnc
index 93c0a2ec67..022b683085 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 c6ee3f77c8..b16d97e388 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 e67f028dde..a519ef2f03 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 7ab73ed5d6..57e39dd928 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++;
+}
+
+
+