From 06a7bc17ca999c04cd2c36ca6162417b9bc32959 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Tue, 28 Jun 2016 21:22:39 +0100 Subject: [PATCH] expand and rename S_undo_inc_then_croak() This function is called from 3 places in pp_ctl.c to do things on require failure like: delete $INC{$name}; croak "$errsv: Compilation failed in require" After some previous commits, all 3 callers are now very similar around the time they call this function: for example they all do CX_LEAVE_SCOPE(cx); cx_popeval(cx); cx_popblock(cx); So incorporate all that into the function too, and rename it to S_pop_eval_context_maybe_croak() to reflect its expanded role. --- pp_ctl.c | 121 +++++++++++++++++++++++++++++---------------------------------- 1 file changed, 55 insertions(+), 66 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index 7b33d4e..0e31e73 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1588,32 +1588,50 @@ Perl_qerror(pTHX_ SV *err) -/* undef or delete the $INC{namesv} entry, then croak. - * require0 indicates that the require didn't return a true value */ +/* pop a CXt_EVAL context and in addition, if it was a require then + * based on action: + * 0: do nothing extra; + * 1: undef $INC{$name}; croak "$name did not return a true value"; + * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require" + */ static void -S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0) +S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action) { - const char *fmt; - HV *inc_hv = GvHVn(PL_incgv); - I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); - const char *key = SvPVX_const(namesv); + SV *namesv; + bool do_croak; - if (require0) { - (void)hv_delete(inc_hv, key, klen, G_DISCARD); - fmt = "%"SVf" did not return a true value"; - err = namesv; - } - else { - (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); - fmt = "%"SVf"Compilation failed in require"; - err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP); - } + CX_LEAVE_SCOPE(cx); + do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE); + namesv = cx->blk_eval.old_namesv; + cx_popeval(cx); + cx_popblock(cx); + CX_POP(cx); - Perl_croak(aTHX_ fmt, SVfARG(err)); + if (do_croak) { + const char *fmt; + HV *inc_hv = GvHVn(PL_incgv); + I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv); + const char *key = SvPVX_const(namesv); + + if (action == 1) { + (void)hv_delete(inc_hv, key, klen, G_DISCARD); + fmt = "%"SVf" did not return a true value"; + errsv = namesv; + } + else { + (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); + fmt = "%"SVf"Compilation failed in require"; + if (!errsv) + errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP); + } + + Perl_croak(aTHX_ fmt, SVfARG(errsv)); + } } + void Perl_die_unwind(pTHX_ SV *msv) { @@ -1671,7 +1689,6 @@ Perl_die_unwind(pTHX_ SV *msv) } if (cxix >= 0) { - SV *namesv = NULL; PERL_CONTEXT *cx; SV **oldsp; U8 gimme; @@ -1693,22 +1710,13 @@ Perl_die_unwind(pTHX_ SV *msv) restartjmpenv = cx->blk_eval.cur_top_env; restartop = cx->blk_eval.retop; - - CX_LEAVE_SCOPE(cx); - cx_popeval(cx); - cx_popblock(cx); - if (CxOLD_OP_TYPE(cx) == OP_REQUIRE) - namesv = cx->blk_eval.old_namesv; - CX_POP(cx); - - if (namesv) { - /* note that unlike pp_entereval, pp_require isn't - * supposed to trap errors. So now that we've popped the - * EVAL that pp_require pushed, process the error message - * and rethrow the error */ - S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE); - NOT_REACHED; /* NOTREACHED */ - } + /* 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 + * croak(exceptsv). This is all handled by the call below when + * action == 2. + */ + S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2); if (!(in_eval & EVAL_KEEPERR)) sv_setsv(ERRSV, exceptsv); @@ -3392,25 +3400,15 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) * compilation, so the EVAL CX block has already been popped, and * various vars restored */ if (yystatus != 3) { - SV *namesv; if (PL_eval_root) { op_free(PL_eval_root); PL_eval_root = NULL; } SP = PL_stack_base + POPMARK; /* pop original mark */ cx = CX_CUR(); - CX_LEAVE_SCOPE(cx); - cx_popeval(cx); - cx_popblock(cx); - assert((CxOLD_OP_TYPE(cx) == OP_REQUIRE) == cBOOL(in_require)); - if (CxOLD_OP_TYPE(cx) == OP_REQUIRE) - namesv = cx->blk_eval.old_namesv; - CX_POP(cx); - - if (in_require) { - S_undo_inc_then_croak(aTHX_ namesv, ERRSV, FALSE); - NOT_REACHED; /* NOTREACHED */ - } + assert(CxTYPE(cx) == CXt_EVAL); + /* pop the CXt_EVAL, and if was a require, croak */ + S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2); } /* die_unwind() re-croaks when in require, having popped the @@ -4276,10 +4274,9 @@ PP(pp_leaveeval) U8 gimme; PERL_CONTEXT *cx; OP *retop; - SV *namesv = NULL; + int failed; CV *evalcv; - /* grab this value before cx_popeval restores old PL_in_eval */ - bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR); + bool keep; PERL_ASYNC_CHECK(); @@ -4290,12 +4287,10 @@ PP(pp_leaveeval) gimme = cx->blk_gimme; /* did require return a false value? */ - if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE - && !(gimme == G_SCALAR + failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE + && !(gimme == G_SCALAR ? SvTRUE(*PL_stack_sp) - : PL_stack_sp > oldsp) - ) - namesv = cx->blk_eval.old_namesv; + : PL_stack_sp > oldsp); if (gimme == G_VOID) PL_stack_sp = oldsp; @@ -4310,6 +4305,8 @@ PP(pp_leaveeval) */ PL_curcop = cx->blk_oldcop; + /* grab this value before cx_popeval restores the old PL_in_eval */ + keep = cBOOL(PL_in_eval & EVAL_KEEPERR); retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; #ifdef DEBUGGING @@ -4317,16 +4314,8 @@ PP(pp_leaveeval) #endif CvDEPTH(evalcv) = 0; - CX_LEAVE_SCOPE(cx); - cx_popeval(cx); - cx_popblock(cx); - CX_POP(cx); - - if (namesv) { /* require returned false */ - /* Unassume the success we assumed earlier. */ - S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE); - NOT_REACHED; /* NOTREACHED */ - } + /* pop the CXt_EVAL, and if a require failed, croak */ + S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed); if (!keep) CLEAR_ERRSV(); -- 1.8.3.1