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.

diff --git a/MANIFEST b/MANIFEST
index 5ca4f13..6ae1626 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4386,6 +4386,7 @@ t/op/crypt.t                      See if crypt works
 t/op/dbm.t                     See if dbmopen/dbmclose work
 t/op/defins.t                  See if auto-insert of defined() works
 t/op/delete.t                  See if delete works
+t/op/die_except.t              See if die/eval avoids $@ clobberage
 t/op/die_exit.t                        See if die and exit status interaction works
 t/op/die.t                     See if die works
 t/op/dor.t                     See if defined-or (//) works

diff --git a/pp_ctl.c b/pp_ctl.c
index d62d58a..921688d 100644 (file)
--- 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 */
 }

diff --git a/t/op/die_except.t b/t/op/die_except.t
new file mode 100644 (file)
index 0000000..b0fcadb
--- /dev/null
+++ b/t/op/die_except.t
@@ -0,0 +1,81 @@
+#!./perl
+
+print "1..12\n";
+my $test_num = 0;
+sub ok {
+    print $_[0] ? "" : "not ", "ok ", ++$test_num, "\n";
+}
+
+{
+    package End;
+    sub DESTROY { $_[0]->() }
+    sub main::end(&) {
+       my($cleanup) = @_;
+       return bless(sub { $cleanup->() }, "End");
+    }
+}
+
+my($val, $err);
+
+$@ = "t0\n";
+$val = eval {
+       $@ = "t1\n";
+       1;
+}; $err = $@;
+ok $val == 1;
+ok $err eq "";
+
+$@ = "t0\n";
+$val = eval {
+       $@ = "t1\n";
+       do {
+               die "t3\n";
+       };
+       1;
+}; $err = $@;
+ok !defined($val);
+ok $err eq "t3\n";
+
+$@ = "t0\n";
+$val = eval {
+       $@ = "t1\n";
+       local $@ = "t2\n";
+       1;
+}; $err = $@;
+ok $val == 1;
+ok $err eq "";
+
+$@ = "t0\n";
+$val = eval {
+       $@ = "t1\n";
+       local $@ = "t2\n";
+       do {
+               die "t3\n";
+       };
+       1;
+}; $err = $@;
+ok !defined($val);
+ok $err eq "t3\n";
+
+$@ = "t0\n";
+$val = eval {
+       $@ = "t1\n";
+       my $c = end { $@ = "t2\n"; };
+       1;
+}; $err = $@;
+ok $val == 1;
+ok $err eq "";
+
+$@ = "t0\n";
+$val = eval {
+       $@ = "t1\n";
+       my $c = end { $@ = "t2\n"; };
+       do {
+               die "t3\n";
+       };
+       1;
+}; $err = $@;
+ok !defined($val);
+ok $err eq "t3\n";
+
+1;

diff --git a/t/op/eval.t b/t/op/eval.t
index 98fbc1e..ff5004e 100644 (file)
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -526,6 +526,8 @@ if (eval "use Devel::Peek; 1;") {
         my $in = <IN>;
         my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2);
         $first =~ s/,pNOK//;
+        s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
+        s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
         $ok = 1 if ($first eq $second);
       }
     }