From 2aabfe8a6165874dd6373e006f0e80d74d5f602c Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Fri, 16 Oct 2015 13:31:57 +0100
Subject: [PATCH] pp_leaveeval: reset stack in VOID context

    $ perl -Dst -e'eval"1"'

Gives:
    ....
    ((eval 1):1)	leaveeval
        =>  (FREED)

Change it so that like all the other pp_leavefoo() functions, it does

    if (gimme == G_VOID)
        PL_stack_sp = newsp;

I can't think of any (non-debugging) perl-level badness the old behaviour
can be shown to demonstrate, but best not to have freed values left
dangling.

This also allows pp_leaveeval() to (like the other pp_leavefoo functions)
avoid doing a dSP with the associated unnecessary PUTBACKs and SPAGAINs.

Finally, the code to detect a false require is moved to earlier in the
function where it's in the same place as the rest of the stack arg
processing code.
---
 ext/XS-APItest/t/call.t |  8 ++++++--
 pp_ctl.c                | 29 +++++++++++++++++------------
 2 files changed, 23 insertions(+), 14 deletions(-)

diff --git a/ext/XS-APItest/t/call.t b/ext/XS-APItest/t/call.t
index df98b1a..c474639 100644
--- a/ext/XS-APItest/t/call.t
+++ b/ext/XS-APItest/t/call.t
@@ -81,7 +81,9 @@ for my $test (
 	"$description call_pv('f')");
 
     ok(eq_array( [ eval_sv('f(' . join(',',map"'$_'",@$args) . ')', $flags) ],
-	$expected), "$description eval_sv('f(args)')");
+                 $flags == G_VOID ? [ 0 ] : $expected
+               ),
+        "$description eval_sv('f(args)')");
 
     ok(eq_array( [ call_method('meth', $flags, $obj, @$args) ], $expected),
 	"$description call_method('meth')");
@@ -135,7 +137,9 @@ for my $test (
 	$expected), "$description G_NOARGS call_pv('f')");
 
     ok(eq_array( [ sub { eval_sv('f(@_)', $flags|G_NOARGS) }->(@$args) ],
-	$expected), "$description G_NOARGS eval_sv('f(@_)')");
+                  $flags == G_VOID ? [ 0 ] :  $expected
+               ),
+        "$description G_NOARGS eval_sv('f(@_)')");
 
     # XXX call_method(G_NOARGS) isn't tested: I'm assuming
     # it's not a sensible combination. DAPM.
diff --git a/pp_ctl.c b/pp_ctl.c
index 615e84c..23b5140 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4258,12 +4258,11 @@ PP(pp_entereval)
 
 PP(pp_leaveeval)
 {
-    dSP;
     SV **newsp;
     I32 gimme;
     PERL_CONTEXT *cx;
     OP *retop;
-    I32 optype;
+    bool require_failed = FALSE;
     CV *evalcv;
     /* grab this value before POPEVAL restores old PL_in_eval */
     bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
@@ -4272,14 +4271,23 @@ PP(pp_leaveeval)
 
     cx = &cxstack[cxstack_ix];
     assert(CxTYPE(cx) == CXt_EVAL);
+
     newsp = PL_stack_base + cx->blk_oldsp;
     gimme = cx->blk_gimme;
 
-    if (gimme != G_VOID) {
-        PUTBACK;
+    /* did require return a false value? */
+    if (       CxOLD_OP_TYPE(cx) == OP_REQUIRE
+            && !(gimme == G_SCALAR
+                    ? SvTRUE(*PL_stack_sp)
+                : PL_stack_sp > newsp)
+    )
+        require_failed = TRUE;
+
+    if (gimme == G_VOID)
+        PL_stack_sp = newsp;
+    else
         leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE);
-        SPAGAIN;
-    }
+
     /* the POPEVAL does a leavescope, which frees the optree associated
      * with eval, which if it frees the nextstate associated with
      * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
@@ -4287,22 +4295,19 @@ PP(pp_leaveeval)
      * to get the current hints. So restore it early.
      */
     PL_curcop = cx->blk_oldcop;
+
     CX_LEAVE_SCOPE(cx);
     POPEVAL(cx);
     POPBLOCK(cx);
     retop = cx->blk_eval.retop;
     evalcv = cx->blk_eval.cv;
-    optype = CxOLD_OP_TYPE(cx);
-
 
 #ifdef DEBUGGING
     assert(CvDEPTH(evalcv) == 1);
 #endif
     CvDEPTH(evalcv) = 0;
 
-    if (optype == OP_REQUIRE &&
-	!(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
-    {
+    if (require_failed) {
 	/* Unassume the success we assumed earlier. */
         S_undo_inc_then_croak(aTHX_ cx, NULL, TRUE);
         NOT_REACHED; /* NOTREACHED */
@@ -4313,7 +4318,7 @@ PP(pp_leaveeval)
     if (!keep)
         CLEAR_ERRSV();
 
-    RETURNOP(retop);
+    return retop;
 }
 
 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
-- 
1.8.3.1