make die reliably hand error to post-eval code

Put the exception into $@ last thing before longjmping to the op following
the eval block, where previously it went into $@ before unwinding the
stack.  This change means that the exception is not liable to be lost
by $@ being clobbered by destructors, cleanup code, or restoration after
"local $@".  The code running immediately after eval can now rely on $@
accurately indicating the exception status of the eval.

1 files changed, 34 insertions, 38 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index d62d58ada3..921688d656 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1575,45 +1575,13 @@ void
 Perl_die_where(pTHX_ SV *msv)
 {
     dVAR;
+    SV *exceptsv = sv_mortalcopy(msv ? msv : ERRSV);
+    U8 in_eval = PL_in_eval;
 
-    if (PL_in_eval) {
+    if (in_eval) {
 	I32 cxix;
 	I32 gimme;
 
-	if (msv) {
-	    if (PL_in_eval & EVAL_KEEPERR) {
-                static const char prefix[] = "\t(in cleanup) ";
-		SV * const err = ERRSV;
-		const char *e = NULL;
-		if (!SvPOK(err))
-		    sv_setpvs(err,"");
-		else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
-		    STRLEN len;
-		    STRLEN msglen;
-		    const char* message = SvPV_const(msv, msglen);
-		    e = SvPV_const(err, len);
-		    e += len - msglen;
-		    if (*e != *message || strNE(e,message))
-			e = NULL;
-		}
-		if (!e) {
-		    STRLEN start;
-		    SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
-		    sv_catpvn(err, prefix, sizeof(prefix)-1);
-		    sv_catsv(err, msv);
-		    start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
-		    Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
-				   SvPVX_const(err)+start);
-		}
-	    }
-	    else {
-		STRLEN msglen;
-		const char* message = SvPV_const(msv, msglen);
-		sv_setpvn(ERRSV, message, msglen);
-		SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
-	    }
-	}
-
 	while ((cxix = dopoptoeval(cxstack_ix)) < 0
 	       && PL_curstackinfo->si_prev)
 	{
@@ -1632,7 +1600,7 @@ Perl_die_where(pTHX_ SV *msv)
 	    POPBLOCK(cx,PL_curpm);
 	    if (CxTYPE(cx) != CXt_EVAL) {
 		STRLEN msglen;
-		const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
+		const char* message = SvPVx_const(exceptsv, msglen);
 		PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
 		PerlIO_write(Perl_error_log, message, msglen);
 		my_exit(1);
@@ -1652,7 +1620,7 @@ Perl_die_where(pTHX_ SV *msv)
 	    PL_curcop = cx->blk_oldcop;
 
 	    if (optype == OP_REQUIRE) {
-                const char* const msg = SvPVx_nolen_const(ERRSV);
+                const char* const msg = SvPVx_nolen_const(exceptsv);
 		SV * const nsv = cx->blk_eval.old_namesv;
                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
                                &PL_sv_undef, 0);
@@ -1663,6 +1631,34 @@ Perl_die_where(pTHX_ SV *msv)
 		DIE(aTHX_ "%sCompilation failed in require",
 		    *msg ? msg : "Unknown error\n");
 	    }
+	    if ((in_eval & EVAL_KEEPERR) && msv) {
+                static const char prefix[] = "\t(in cleanup) ";
+		SV * const err = ERRSV;
+		const char *e = NULL;
+		if (!SvPOK(err))
+		    sv_setpvs(err,"");
+		else if (SvCUR(err) >= sizeof(prefix)+SvCUR(exceptsv)-1) {
+		    STRLEN len;
+		    STRLEN msglen;
+		    const char* message = SvPV_const(exceptsv, msglen);
+		    e = SvPV_const(err, len);
+		    e += len - msglen;
+		    if (*e != *message || strNE(e,message))
+			e = NULL;
+		}
+		if (!e) {
+		    STRLEN start;
+		    SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(exceptsv));
+		    sv_catpvn(err, prefix, sizeof(prefix)-1);
+		    sv_catsv(err, exceptsv);
+		    start = SvCUR(err)-SvCUR(exceptsv)-sizeof(prefix)+1;
+		    Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
+				   SvPVX_const(err)+start);
+		}
+	    }
+	    else {
+		sv_setsv(ERRSV, exceptsv);
+	    }
 	    assert(CxTYPE(cx) == CXt_EVAL);
 	    PL_restartop = cx->blk_eval.retop;
 	    JMPENV_JUMP(3);
@@ -1670,7 +1666,7 @@ Perl_die_where(pTHX_ SV *msv)
 	}
     }
 
-    write_to_stderr( msv ? msv : ERRSV );
+    write_to_stderr(exceptsv);
     my_failure_exit();
     /* NOTREACHED */
 }