FREETMPS when leaving eval, even when void/dying

[ This commit was originally added as v5.25.2-77-g214949f then reverted
by v5.25.2-89-gcc040a9, since it broke Variable::Magic. That distribution
has since been fixed, so this fix can be re-applied to blead ]

When a scope is exited normally (e.g. pp_leavetry, pp_leavesub),
we do a FREETMPS only in scalar or list context; in void context
we don't bother for efficiency reasons. Similarly, when there's an
exception and we unwind to (and then pop) an EVAL context, we haven't
been bothering to FREETMPS.

The problem with this in try/eval (exiting normally or via an exception)
is that it can delay some SVs getting freed until *after* $@ has been
set. If that freeing calls a destructor which happens to set $@,
then that overwrites the "real" value of $@.

For example

    sub DESTROY { eval { die "died in DESTROY"; } }
    eval { bless []; };
    is ($@, "");

Before this commit, that test would fail because $@ is "died in DESTROY".

This commit ensures that leaving an eval/try by whatever means always
clears the tmps stack before setting $@.

See http://nntp.perl.org/group/perl.perl5.porters/237380.

For now, I haven't added a FREETMPS to the other pp_leavefoo()
void context cases, since I can't think of a case where it would
matter.

diff --git a/pp_ctl.c b/pp_ctl.c
index e24d7b6..d465a9e 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1685,7 +1685,13 @@ Perl_die_unwind(pTHX_ SV *msv)
     if (in_eval) {
        I32 cxix;
 
-        exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
+        /* We need to keep this SV alive through all the stack unwinding
+         * and FREETMPSing below, while ensuing that it doesn't leak
+         * if we call out to something which then dies (e.g. sub STORE{die}
+         * when unlocalising a tied var). So we do a dance with
+         * mortalising and SAVEFREEing.
+         */
+        sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
 
        /*
         * Historically, perl used to set ERRSV ($@) early in the die
@@ -1754,6 +1760,24 @@ Perl_die_unwind(pTHX_ SV *msv)
 
            restartjmpenv = cx->blk_eval.cur_top_env;
            restartop     = cx->blk_eval.retop;
+
+            /* We need a FREETMPS here to avoid late-called destructors
+             * clobbering $@ *after* we set it below, e.g.
+             *    sub DESTROY { eval { die "X" } }
+             *    eval { my $x = bless []; die $x = 0, "Y" };
+             *    is($@, "Y")
+             * Here the clearing of the $x ref mortalises the anon array,
+             * which needs to be freed *before* $& is set to "Y",
+             * otherwise it gets overwritten with "X".
+             *
+             * However, the FREETMPS will clobber exceptsv, so preserve it
+             * on the savestack for now.
+             */
+            SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
+            FREETMPS;
+            /* now we're about to pop the savestack, so re-mortalise it */
+            sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
+
             /* Note that unlike pp_entereval, pp_require isn't supposed to
              * trap errors. So if we're a require, after we pop the
              * CXt_EVAL that pp_require pushed, rethrow the error with
@@ -4439,8 +4463,11 @@ PP(pp_leaveeval)
                     ? SvTRUE(*PL_stack_sp)
                     : PL_stack_sp > oldsp);
 
-    if (gimme == G_VOID)
+    if (gimme == G_VOID) {
         PL_stack_sp = oldsp;
+        /* free now to avoid late-called destructors clobbering $@ */
+        FREETMPS;
+    }
     else
         leave_adjust_stacks(oldsp, oldsp, gimme, 0);
 
@@ -4532,8 +4559,11 @@ PP(pp_leavetry)
     oldsp = PL_stack_base + cx->blk_oldsp;
     gimme = cx->blk_gimme;
 
-    if (gimme == G_VOID)
+    if (gimme == G_VOID) {
         PL_stack_sp = oldsp;
+        /* free now to avoid late-called destructors clobbering $@ */
+        FREETMPS;
+    }
     else
         leave_adjust_stacks(oldsp, oldsp, gimme, 1);
     CX_LEAVE_SCOPE(cx);

diff --git a/t/op/eval.t b/t/op/eval.t
index 722cd35..a9b8c9e 100644 (file)
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 134);
+plan(tests => 140);
 
 eval 'pass();';
 
@@ -665,3 +665,35 @@ pass("eval in freed package does not crash");
     sub { $s; DB::f127786}->();
     pass("RT #127786");
 }
+
+# Late calling of destructors overwriting $@.
+# When leaving an eval scope (either by falling off the end or dying),
+# we must ensure that any temps are freed before the end of the eval
+# leave: in particular before $@ is set (to either "" or the error),
+# because otherwise the tmps freeing may call a destructor which
+# will change $@ (e.g. due to a successful eval) *after* its been set.
+# Some extra nested scopes are included in the tests to ensure they don't
+# affect the tmps freeing.
+
+{
+    package TMPS;
+    sub DESTROY { eval { die "died in DESTROY"; } } # alters $@
+
+    eval { { 1; { 1; bless []; } } };
+    ::is ($@, "", "FREETMPS: normal try exit");
+
+    eval q{ { 1; { 1; bless []; } } };
+    ::is ($@, "", "FREETMPS: normal string eval exit");
+
+    eval { { 1; { 1; return bless []; } } };
+    ::is ($@, "", "FREETMPS: return try exit");
+
+    eval q{ { 1; { 1; return bless []; } } };
+    ::is ($@, "", "FREETMPS: return string eval exit");
+
+    eval { { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } };
+    ::like ($@, qr/die in eval/, "FREETMPS: die try exit");
+
+    eval q{ { 1; { 1; my $x = bless []; die $x = 0, "die in eval"; } } };
+    ::like ($@, qr/die in eval/, "FREETMPS: die eval string exit");
+}