don't rely on ghost contexts being unmolested

Dying and returning from a format both relied on the state of a
just-popped context frame being preserved across a LEAVE.  Don't rely
on it.  Test using an operator ripped off from Scope::Cleanup, which makes
it easy to run arbitrary Perl code during cleanup, without isolating it
on a separate context stack as the DESTROY mechanism does.

5 files changed, 167 insertions, 5 deletions

diff --git a/MANIFEST b/MANIFEST
index 1b96d3e3ad..85fc71260a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3390,6 +3390,7 @@ ext/XS-APItest/t/Block.pm	Helper for ./blockhooks.t
 ext/XS-APItest/t/call_checker.t	test call checker plugin API
 ext/XS-APItest/t/caller.t	XS::APItest: tests for caller_cx
 ext/XS-APItest/t/call.t		XS::APItest extension
+ext/XS-APItest/t/cleanup.t	test stack behaviour on unwinding
 ext/XS-APItest/t/cophh.t	test COPHH API
 ext/XS-APItest/t/copyhints.t	test hv_copy_hints_hv() API
 ext/XS-APItest/t/exception.t	XS::APItest extension
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index efd9b3e1e7..e40785c613 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -509,6 +509,52 @@ test_op_linklist_describe(OP *start)
     return SvPVX(rv);
 }
 
+/** establish_cleanup operator, ripped off from Scope::Cleanup **/
+
+STATIC void
+THX_run_cleanup(pTHX_ void *cleanup_code_ref)
+{
+    dSP;
+    ENTER;
+    SAVETMPS;
+    PUSHMARK(SP);
+    call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
+    FREETMPS;
+    LEAVE;
+}
+
+STATIC OP *
+THX_pp_establish_cleanup(pTHX)
+{
+    dSP;
+    SV *cleanup_code_ref;
+    cleanup_code_ref = newSVsv(POPs);
+    SAVEFREESV(cleanup_code_ref);
+    SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref);
+    if(GIMME_V != G_VOID) PUSHs(&PL_sv_undef);
+    RETURN;
+}
+
+STATIC OP *
+THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+    OP *pushop, *argop, *estop;
+    ck_entersub_args_proto(entersubop, namegv, ckobj);
+    pushop = cUNOPx(entersubop)->op_first;
+    if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
+    argop = pushop->op_sibling;
+    pushop->op_sibling = argop->op_sibling;
+    argop->op_sibling = NULL;
+    op_free(entersubop);
+    NewOpSz(0, estop, sizeof(UNOP));
+    estop->op_type = OP_RAND;
+    estop->op_ppaddr = THX_pp_establish_cleanup;
+    cUNOPx(estop)->op_flags = OPf_KIDS;
+    cUNOPx(estop)->op_first = argop;
+    PL_hints |= HINT_BLOCK_SCOPE;
+    return estop;
+}
+
 /** RPN keyword parser **/
 
 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
@@ -2350,3 +2396,15 @@ BOOT:
     next_keyword_plugin = PL_keyword_plugin;
     PL_keyword_plugin = my_keyword_plugin;
 }
+
+void
+establish_cleanup(...)
+PROTOTYPE: $
+CODE:
+    croak("establish_cleanup called as a function");
+
+BOOT:
+{
+    CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
+    cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
+}
diff --git a/ext/XS-APItest/t/cleanup.t b/ext/XS-APItest/t/cleanup.t
new file mode 100644
index 0000000000..07ce7ead05
--- /dev/null
+++ b/ext/XS-APItest/t/cleanup.t
@@ -0,0 +1,96 @@
+use warnings;
+use strict;
+
+use Test::More tests => 3;
+
+use XS::APItest qw(establish_cleanup);
+
+my @events;
+
+# unwinding on local return from sub
+
+sub aa {
+    push @events, "aa0";
+    establish_cleanup sub { push @events, "bb0" };
+    push @events, "aa1";
+    "aa2";
+}
+
+sub cc {
+    push @events, "cc0";
+    push @events, [ "cc1", aa() ];
+    push @events, "cc2";
+    "cc3";
+}
+
+@events = ();
+push @events, "dd0";
+push @events, [ "dd1", cc() ];
+is_deeply \@events, [
+    "dd0",
+    "cc0",
+    "aa0",
+    "aa1",
+    "bb0",
+    [ "cc1", "aa2" ],
+    "cc2",
+    [ "dd1", "cc3" ],
+];
+
+# unwinding on local return from format
+
+sub ff { push @events, "ff0" }
+
+format EE =
+@<<
+((push @events, "ee0"), (establish_cleanup \&ff), (push @events, "ee1"), "ee2")
+.
+
+sub gg {
+    push @events, "gg0";
+    write(EE);
+    push @events, "gg1";
+    "gg2";
+}
+
+@events = ();
+open EE, ">", \(my $ee);
+push @events, "hh0";
+push @events, [ "hh1", gg() ];
+close EE;
+is_deeply \@events, [
+    "hh0",
+    "gg0",
+    "ee0",
+    "ee1",
+    "ff0",
+    "gg1",
+    [ "hh1", "gg2" ],
+];
+
+# unwinding on die
+
+sub pp {
+    my $value = eval {
+	push @events, "pp0";
+	establish_cleanup sub { push @events, "qq0" };
+	push @events, "pp1";
+	die "pp2\n";
+	push @events, "pp3";
+	"pp4";
+    };
+    [ "pp5", $value, $@ ];
+}
+
+@events = ();
+push @events, "rr0";
+push @events, [  "rr1", pp() ];
+is_deeply \@events, [
+	"rr0",
+	"pp0",
+	"pp1",
+	"qq0",
+	[ "rr1", [ "pp5", undef, "pp2\n" ] ],
+];
+
+1;
diff --git a/pp_ctl.c b/pp_ctl.c
index 46c6a0b0b2..9eebf43c65 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1653,6 +1653,9 @@ Perl_die_unwind(pTHX_ SV *msv)
 	    SV *namesv;
 	    register PERL_CONTEXT *cx;
 	    SV **newsp;
+	    COP *oldcop;
+	    JMPENV *restartjmpenv;
+	    OP *restartop;
 
 	    if (cxix < cxstack_ix)
 		dounwind(cxix);
@@ -1667,6 +1670,9 @@ Perl_die_unwind(pTHX_ SV *msv)
 	    }
 	    POPEVAL(cx);
 	    namesv = cx->blk_eval.old_namesv;
+	    oldcop = cx->blk_oldcop;
+	    restartjmpenv = cx->blk_eval.cur_top_env;
+	    restartop = cx->blk_eval.retop;
 
 	    if (gimme == G_SCALAR)
 		*++newsp = &PL_sv_undef;
@@ -1678,7 +1684,7 @@ Perl_die_unwind(pTHX_ SV *msv)
 	     * XXX it might be better to find a way to avoid messing with
 	     * PL_curcop in save_re_context() instead, but this is a more
 	     * minimal fix --GSAR */
-	    PL_curcop = cx->blk_oldcop;
+	    PL_curcop = oldcop;
 
 	    if (optype == OP_REQUIRE) {
                 const char* const msg = SvPVx_nolen_const(exceptsv);
@@ -1699,9 +1705,8 @@ Perl_die_unwind(pTHX_ SV *msv)
 	    else {
 		sv_setsv(ERRSV, exceptsv);
 	    }
-	    assert(CxTYPE(cx) == CXt_EVAL);
-	    PL_restartjmpenv = cx->blk_eval.cur_top_env;
-	    PL_restartop = cx->blk_eval.retop;
+	    PL_restartjmpenv = restartjmpenv;
+	    PL_restartop = restartop;
 	    JMPENV_JUMP(3);
 	    /* NOTREACHED */
 	}
diff --git a/pp_sys.c b/pp_sys.c
index 39daad6880..78b635f05d 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1348,6 +1348,7 @@ PP(pp_leavewrite)
     SV **newsp;
     I32 gimme;
     register PERL_CONTEXT *cx;
+    OP *retop;
 
     if (!io || !(ofp = IoOFP(io)))
         goto forget_top;
@@ -1428,6 +1429,7 @@ PP(pp_leavewrite)
   forget_top:
     POPBLOCK(cx,PL_curpm);
     POPFORMAT(cx);
+    retop = cx->blk_sub.retop;
     LEAVE;
 
     fp = IoOFP(io);
@@ -1460,7 +1462,7 @@ PP(pp_leavewrite)
     PUTBACK;
     PERL_UNUSED_VAR(newsp);
     PERL_UNUSED_VAR(gimme);
-    return cx->blk_sub.retop;
+    return retop;
 }
 
 PP(pp_prtf)