X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b68108d9b5245170bc0844ad4bded511ab7cca6a..ac1dd572b7ca3bf48b942fd88551d451d38a884d:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 1aaa261..199df1f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -116,7 +116,7 @@ PP(pp_regcomp) pm->op_pmflags | (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); if (pm->op_pmflags & PMf_HAS_CV) - ((struct regexp *)SvANY(new_re))->qr_anoncv + ReANY(new_re)->qr_anoncv = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); if (is_bare_re) { @@ -129,7 +129,7 @@ PP(pp_regcomp) some day. */ if (pm->op_type == OP_MATCH) { SV *lhs; - const bool was_tainted = PL_tainted; + const bool was_tainted = TAINT_get; if (pm->op_flags & OPf_STACKED) lhs = args[-1]; else if (pm->op_private & OPpTARGET_MY) @@ -138,8 +138,8 @@ PP(pp_regcomp) SvGETMAGIC(lhs); /* Restore the previous value of PL_tainted (which may have been modified by get-magic), to avoid incorrectly setting the - RXf_TAINTED flag further down. */ - PL_tainted = was_tainted; + RXf_TAINTED flag with RX_TAINT_on further down. */ + TAINT_set(was_tainted); } tmp = reg_temp_copy(NULL, new_re); ReREFCNT_dec(new_re); @@ -151,9 +151,9 @@ PP(pp_regcomp) } #ifndef INCOMPLETE_TAINTS - if (PL_tainting && PL_tainted) { + if (TAINTING_get && TAINT_get) { SvTAINTED_on((SV*)new_re); - RX_EXTFLAGS(new_re) |= RXf_TAINTED; + RX_TAINT_on(new_re); } #endif @@ -259,7 +259,7 @@ PP(pp_substcont) /* update the taint state of various various variables in * preparation for final exit. * See "how taint works" above pp_subst() */ - if (PL_tainting) { + if (TAINTING_get) { if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) @@ -271,8 +271,10 @@ PP(pp_substcont) ) SvTAINTED_on(TOPs); /* taint return value */ /* needed for mg_set below */ - PL_tainted = cBOOL(cx->sb_rxtainted & - (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + TAINT_set( + cBOOL(cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + ); SvTAINT(TARG); } /* PL_tainted must be correctly set for this mg_set */ @@ -321,7 +323,7 @@ PP(pp_substcont) /* update the taint state of various various variables in preparation * for calling the code block. * See "how taint works" above pp_subst() */ - if (PL_tainting) { + if (TAINTING_get) { if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ cx->sb_rxtainted |= SUBST_TAINT_PAT; @@ -352,7 +354,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) PERL_UNUSED_CONTEXT; if (!p || p[1] < RX_NPARENS(rx)) { -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW i = 7 + (RX_NPARENS(rx)+1) * 2; #else i = 6 + (RX_NPARENS(rx)+1) * 2; @@ -369,7 +371,7 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) RX_MATCH_COPIED_off(rx); *p++ = RX_NPARENS(rx); -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW *p++ = PTR2UV(RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = NULL; #endif @@ -398,7 +400,7 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) *p++ = 0; RX_NPARENS(rx) = *p++; -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW if (RX_SAVED_COPY(rx)) SvREFCNT_dec (RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); @@ -426,14 +428,14 @@ S_rxres_free(pTHX_ void **rsp) if (p) { void *tmp = INT2PTR(char*,*p); #ifdef PERL_POISON -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW U32 i = 9 + p[1] * 2; #else U32 i = 8 + p[1] * 2; #endif #endif -#ifdef PERL_OLD_COPY_ON_WRITE +#ifdef PERL_ANY_COW SvREFCNT_dec (INT2PTR(SV*,p[2])); #endif #ifdef PERL_POISON @@ -1998,8 +2000,12 @@ PP(pp_dbstate) PUSHSUB_DB(cx); cx->blk_sub.retop = PL_op->op_next; CvDEPTH(cv)++; + if (CvDEPTH(cv) >= 2) { + PERL_STACK_OVERFLOW_CHECK(); + pad_push(CvPADLIST(cv), CvDEPTH(cv)); + } SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); RETURNOP(CvSTART(cv)); } } @@ -2686,7 +2692,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac { dVAR; OP **ops = opstack; - static const char too_deep[] = "Target of goto is too deeply nested"; + static const char* const too_deep = "Target of goto is too deeply nested"; PERL_ARGS_ASSERT_DOFINDLABEL; @@ -2758,20 +2764,19 @@ PP(pp_goto) STRLEN label_len = 0; U32 label_flags = 0; const bool do_dump = (PL_op->op_type == OP_DUMP); - static const char must_have_label[] = "goto must have label"; + static const char* const must_have_label = "goto must have label"; if (PL_op->op_flags & OPf_STACKED) { SV * const sv = POPs; + SvGETMAGIC(sv); /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; PERL_CONTEXT *cx; CV *cv = MUTABLE_CV(SvRV(sv)); - SV** mark; - I32 items = 0; + AV *arg = GvAV(PL_defgv); I32 oldsave; - bool reified = 0; retry: if (!CvROOT(cv) && !CvXSUB(cv)) { @@ -2799,13 +2804,17 @@ PP(pp_goto) FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) + { + SvREFCNT_dec(cv); DIE(aTHX_ "Can't goto subroutine outside a subroutine"); + } if (cxix < cxstack_ix) dounwind(cxix); TOPBLOCK(cx); SPAGAIN; /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ if (CxTYPE(cx) == CXt_EVAL) { + SvREFCNT_dec(cv); if (CxREALEVAL(cx)) /* diag_listed_as: Can't goto subroutine from an eval-%s */ DIE(aTHX_ "Can't goto subroutine from an eval-string"); @@ -2814,35 +2823,25 @@ PP(pp_goto) DIE(aTHX_ "Can't goto subroutine from an eval-block"); } else if (CxMULTICALL(cx)) + { + SvREFCNT_dec(cv); DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); + } if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { - /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; - items = AvFILLp(av) + 1; - EXTEND(SP, items+1); /* @_ could have been extended. */ - Copy(AvARRAY(av), SP + 1, items, SV*); - SvREFCNT_dec(GvAV(PL_defgv)); - GvAV(PL_defgv) = cx->blk_sub.savearray; - CLEAR_ARGARRAY(av); - /* abandon @_ if it got reified */ - if (AvREAL(av)) { - reified = 1; + /* abandon the original @_ if it got reified or if it is + the same as the current @_ */ + if (AvREAL(av) || av == arg) { SvREFCNT_dec(av); av = newAV(); - av_extend(av, items-1); AvREIFY_only(av); PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); } + else CLEAR_ARGARRAY(av); } - else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */ - AV* const av = GvAV(PL_defgv); - items = AvFILLp(av) + 1; - EXTEND(SP, items+1); /* @_ could have been extended. */ - Copy(AvARRAY(av), SP + 1, items, SV*); - } - mark = SP; - SP += items; + /* We donate this refcount later to the callee’s pad. */ + SvREFCNT_inc_simple_void(arg); if (CxTYPE(cx) == CXt_SUB && !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) SvREFCNT_dec(cx->blk_sub.cv); @@ -2853,6 +2852,7 @@ PP(pp_goto) * our precious cv. See bug #99850. */ if (!CvROOT(cv) && !CvXSUB(cv)) { const GV * const gv = CvGV(cv); + SvREFCNT_dec(arg); if (gv) { SV * const tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); @@ -2867,12 +2867,30 @@ PP(pp_goto) SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { OP* const retop = cx->blk_sub.retop; - SV **newsp PERL_UNUSED_DECL; - I32 gimme PERL_UNUSED_DECL; - if (reified) { + SV **newsp; + I32 gimme; + const SSize_t items = AvFILLp(arg) + 1; + SV** mark; + + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + + /* put GvAV(defgv) back onto stack */ + EXTEND(SP, items+1); /* @_ could have been extended. */ + Copy(AvARRAY(arg), SP + 1, items, SV*); + mark = SP; + SP += items; + if (AvREAL(arg)) { I32 index; for (index=0; indexblk_sub.savearray; + SvREFCNT_dec(arg); } /* XS subs don't have a CxSUB, so pop it */ @@ -2886,11 +2904,6 @@ PP(pp_goto) } else { PADLIST * const padlist = CvPADLIST(cv); - if (CxTYPE(cx) == CXt_EVAL) { - PL_in_eval = CxOLD_IN_EVAL(cx); - PL_eval_root = cx->blk_eval.old_eval_root; - cx->cx_type = CXt_SUB; - } cx->blk_sub.cv = cv; cx->blk_sub.olddepth = CvDEPTH(cv); @@ -2907,41 +2920,26 @@ PP(pp_goto) PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); if (CxHASARGS(cx)) { - AV *const av = MUTABLE_AV(PAD_SVl(0)); - - cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); CX_CURPAD_SAVE(cx->blk_sub); - cx->blk_sub.argarray = av; - if (items >= AvMAX(av) + 1) { - SV **ary = AvALLOC(av); - if (AvARRAY(av) != ary) { - AvMAX(av) += AvARRAY(av) - AvALLOC(av); - AvARRAY(av) = ary; - } - if (items >= AvMAX(av) + 1) { - AvMAX(av) = items - 1; - Renew(ary,items+1,SV*); - AvALLOC(av) = ary; - AvARRAY(av) = ary; - } - } - ++mark; - Copy(mark,AvARRAY(av),items,SV*); - AvFILLp(av) = items - 1; - assert(!AvREAL(av)); - if (reified) { - /* transfer 'ownership' of refcnts to new @_ */ - AvREAL_on(av); - AvREIFY_off(av); - } - while (items--) { - if (*mark) - SvTEMP_off(*mark); - mark++; + /* cx->blk_sub.argarray has no reference count, so we + need something to hang on to our argument array so + that cx->blk_sub.argarray does not end up pointing + to freed memory as the result of undef *_. So put + it in the callee’s pad, donating our refer- + ence count. */ + SvREFCNT_dec(PAD_SVl(0)); + PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg); + + /* GvAV(PL_defgv) might have been modified on scope + exit, so restore it. */ + if (arg != GvAV(PL_defgv)) { + AV * const av = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg); + SvREFCNT_dec(av); } } + else SvREFCNT_dec(arg); if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ Perl_get_db_sub(aTHX_ NULL, cv); if (PERLDB_GOTO) { @@ -2957,7 +2955,7 @@ PP(pp_goto) } } else { - label = SvPV_const(sv, label_len); + label = SvPV_nomg_const(sv, label_len); label_flags = SvUTF8(sv); } } @@ -3273,7 +3271,8 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) switch (cond) { case FIND_RUNCV_padid_eq: if (!CvPADLIST(cv) - || CvPADLIST(cv)->xpadl_id != (U32)arg) continue; + || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg)) + continue; return cv; case FIND_RUNCV_level_eq: if (level++ != arg) continue; @@ -3450,6 +3449,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) PERL_CONTEXT *cx; I32 optype; /* Used by POPEVAL. */ SV *namesv; + SV *errsv = NULL; cx = NULL; namesv = NULL; @@ -3461,7 +3461,6 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) PL_op = saveop; if (yystatus != 3) { if (PL_eval_root) { - cv_forget_slab(evalcv); op_free(PL_eval_root); PL_eval_root = NULL; } @@ -3473,6 +3472,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */ } + errsv = ERRSV; if (in_require) { if (!cx) { /* If cx is still NULL, it means that we didn't go in the @@ -3486,13 +3486,13 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh) SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), &PL_sv_undef, 0); Perl_croak(aTHX_ "%"SVf"Compilation failed in require", - SVfARG(ERRSV - ? ERRSV + SVfARG(errsv + ? errsv : newSVpvs_flags("Unknown error\n", SVs_TEMP))); } else { - if (!*(SvPVx_nolen_const(ERRSV))) { - sv_setpvs(ERRSV, "Compilation error"); + if (!*(SvPV_nolen_const(errsv))) { + sv_setpvs(errsv, "Compilation error"); } } if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); @@ -3613,7 +3613,7 @@ PP(pp_require) sv = POPs; if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { sv = sv_2mortal(new_version(sv)); - if (!sv_derived_from(PL_patchlevel, "version")) + if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) upg_version(PL_patchlevel, TRUE); if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { if ( vcmp(sv,PL_patchlevel) <= 0 ) @@ -3933,7 +3933,7 @@ PP(pp_require) if (namesv) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); I32 i; - SV *const msg = newSVpv("", 0); + SV *const msg = newSVpvs_flags("", SVs_TEMP); SV *const inc = newSVpvs_flags("", SVs_TEMP); for (i = 0; i <= AvFILL(ar); i++) { sv_catpvs(inc, " "); @@ -5373,8 +5373,10 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (SvOK(out)) { status = SvIV(out); } - else if (SvTRUE(ERRSV)) { - err = newSVsv(ERRSV); + else { + SV * const errsv = ERRSV; + if (SvTRUE_NN(errsv)) + err = newSVsv(errsv); } }