From 2aabfe8a6165874dd6373e006f0e80d74d5f602c Mon Sep 17 00:00:00 2001 From: David Mitchell 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