X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/00cc874382d18406b0909f99025f70ca0df1996d..1e4f088863436a8019c7d864691903ffdafeefda:/pad.c?ds=sidebyside diff --git a/pad.c b/pad.c index 941f663..70519e4 100644 --- a/pad.c +++ b/pad.c @@ -196,7 +196,7 @@ sv_eq_pvn_flags(pTHX_ const SV *sv, const char* pv, const STRLEN pvlen, const U3 sv_recode_to_utf8(svrecode, PL_encoding); pv1 = SvPV_const(svrecode, cur1); } - SvREFCNT_dec(svrecode); + SvREFCNT_dec_NN(svrecode); } if (flags & SVf_UTF8) return (bytes_cmp_utf8( @@ -280,7 +280,6 @@ Perl_pad_new(pTHX_ int flags) padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name); } else { - padlist->xpadl_id = PL_padlist_generation++; av_store(pad, 0, NULL); padname = newAV(); } @@ -371,6 +370,8 @@ Perl_cv_undef(pTHX_ CV *cv) PAD_SAVE_SETNULLPAD(); /* discard any leaked ops */ + if (PL_parser) + parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(cv)); opslab_force_free((OPSLAB *)CvSTART(cv)); CvSTART(cv) = NULL; @@ -426,7 +427,7 @@ Perl_cv_undef(pTHX_ CV *cv) if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ curpad[ix] = NULL; - SvREFCNT_dec(innercv); + SvREFCNT_dec_NN(innercv); inner_rc--; } @@ -456,7 +457,7 @@ Perl_cv_undef(pTHX_ CV *cv) PL_comppad = NULL; PL_curpad = NULL; } - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); } } { @@ -626,8 +627,12 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, flags &= ~padadd_UTF8_NAME; if ((flags & padadd_NO_DUP_CHECK) == 0) { + ENTER; + SAVEFREESV(namesv); /* in case of fatal warnings */ /* check for duplicate declaration */ pad_check_dup(namesv, flags & padadd_OUR, ourstash); + SvREFCNT_inc_simple_void_NN(namesv); + LEAVE; } offset = pad_alloc_name(namesv, flags & ~padadd_UTF8_NAME, typestash, ourstash); @@ -825,7 +830,7 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype) if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) { assert(!CvWEAKOUTSIDE(func)); CvWEAKOUTSIDE_on(func); - SvREFCNT_dec(CvOUTSIDE(func)); + SvREFCNT_dec_NN(CvOUTSIDE(func)); } return ix; } @@ -1116,6 +1121,17 @@ the parent pad. /* the CV does late binding of its lexicals */ #define CvLATE(cv) (CvANON(cv) || CvCLONE(cv) || SvTYPE(cv) == SVt_PVFM) +static void +S_unavailable(pTHX_ SV *namesv) +{ + /* diag_listed_as: Variable "%s" is not available */ + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "%se \"%"SVf"\" is not available", + *SvPVX_const(namesv) == '&' + ? "Subroutin" + : "Variabl", + namesv); +} STATIC PADOFFSET S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, @@ -1238,8 +1254,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, : *out_flags & PAD_FAKELEX_ANON) { if (warn) - Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%"SVf"\" is not available", + S_unavailable(aTHX_ newSVpvn_flags(namepv, namelen, SVs_TEMP | (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); @@ -1287,8 +1302,7 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, && (!CvDEPTH(cv) || !staleok) && !SvPAD_STATE(name_svp[offset])) { - Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%"SVf"\" is not available", + S_unavailable(aTHX_ newSVpvn_flags(namepv, namelen, SVs_TEMP | (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))); @@ -1374,6 +1388,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, else { /* immediate creation - capture outer value right now */ av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); + /* But also note the offset, as newMYSUB needs it */ + PARENT_PAD_INDEX_set(new_namesv, offset); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n", PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); @@ -1659,7 +1675,7 @@ S_pad_reset(pTHX) ) ); - if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */ + if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */ I32 po; for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) @@ -1698,13 +1714,21 @@ Perl_pad_tidy(pTHX_ padtidy_type type) ASSERT_CURPAD_ACTIVE("pad_tidy"); - /* If this CV has had any 'eval-capable' ops planted in it - * (ie it contains eval '...', //ee, /$var/ or /(?{..})/), Then any - * anon prototypes in the chain of CVs should be marked as cloneable, - * so that for example the eval's CV in C<< sub { eval '$x' } >> gets - * the right CvOUTSIDE. - * If running with -d, *any* sub may potentially have an eval - * executed within it. + /* If this CV has had any 'eval-capable' ops planted in it: + * i.e. it contains any of: + * + * * eval '...', + * * //ee, + * * use re 'eval'; /$var/ + * * /(?{..})/), + * + * Then any anon prototypes in the chain of CVs should be marked as + * cloneable, so that for example the eval's CV in + * + * sub { eval '$x' } + * + * gets the right CvOUTSIDE. If running with -d, *any* sub may + * potentially have an eval executed within it. */ if (PL_cv_has_eval || PL_perldb) { @@ -1800,6 +1824,7 @@ void Perl_pad_free(pTHX_ PADOFFSET po) { dVAR; + SV *sv; ASSERT_CURPAD_LEGAL("pad_free"); if (!PL_curpad) return; @@ -1814,9 +1839,11 @@ Perl_pad_free(pTHX_ PADOFFSET po) PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po) ); - if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { - SvFLAGS(PL_curpad[po]) &= ~SVs_PADTMP; /* also clears SVs_PADSTALE */ - } + + sv = PL_curpad[po]; + if (sv && sv != &PL_sv_undef && !SvPADMY(sv)) + SvFLAGS(sv) &= ~SVs_PADTMP; + if ((I32)po < PL_padix) PL_padix = po - 1; } @@ -1949,7 +1976,7 @@ the immediately surrounding code. static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside); static void -S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) +S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) { dVAR; I32 ix; @@ -1963,46 +1990,43 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) SV** outpad; long depth; bool subclones = FALSE; -#ifdef DEBUGGING - CV * const outside_arg = outside; -#endif assert(!CvUNIQUE(proto)); /* Anonymous subs have a weak CvOUTSIDE pointer, so its value is not * reliable. The currently-running sub is always the one we need to * close over. + * For my subs, the currently-running sub may not be the one we want. + * We have to check whether it is a clone of CvOUTSIDE. * Note that in general for formats, CvOUTSIDE != find_runcv. * Since formats may be nested inside closures, CvOUTSIDE may point * to a prototype; we instead want the cloned parent who called us. */ if (!outside) { - if (SvTYPE(proto) == SVt_PVCV) + if (CvWEAKOUTSIDE(proto)) outside = find_runcv(NULL); else { outside = CvOUTSIDE(proto); if ((CvCLONE(outside) && ! CvCLONED(outside)) || !CvPADLIST(outside) - || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) { + || PadlistNAMES(CvPADLIST(outside)) + != protopadlist->xpadl_outid) { outside = find_runcv_where( - FIND_RUNCV_padid_eq, (IV)protopadlist->xpadl_outid, NULL + FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL ); /* outside could be null */ } } } depth = outside ? CvDEPTH(outside) : 0; -#ifdef DEBUGGING - assert(depth || outside_arg || SvTYPE(proto) == SVt_PVFM); -#endif if (!depth) depth = 1; - assert(SvTYPE(proto) == SVt_PVFM || CvPADLIST(outside)); ENTER; SAVESPTR(PL_compcv); PL_compcv = cv; + if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */ if (CvHASEVAL(cv)) CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); @@ -2010,7 +2034,6 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) SAVESPTR(PL_comppad_name); PL_comppad_name = protopad_name; CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); - CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id; av_fill(PL_comppad, fpad); @@ -2019,8 +2042,8 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) outpad = outside && CvPADLIST(outside) ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth]) : NULL; - assert(outpad || SvTYPE(cv) == SVt_PVFM); - if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id; + if (outpad) + CvPADLIST(cv)->xpadl_outid = PadlistNAMES(CvPADLIST(outside)); for (ix = fpad; ix > 0; ix--) { SV* const namesv = (ix <= fname) ? pname[ix] : NULL; @@ -2032,9 +2055,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) && (!outside || !CvDEPTH(outside))) ) { - assert(SvTYPE(cv) == SVt_PVFM); - Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%"SVf"\" is not available", namesv); + S_unavailable(aTHX_ namesv); sv = NULL; } else @@ -2058,21 +2079,16 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) { /* my sub */ - /* This is actually a stub with a proto CV attached - to it by magic. Since the stub itself is used - when the proto is cloned, we need a new stub - that nonetheless shares the same proto. - */ - MAGIC * const mg = - mg_find(ppad[ix], PERL_MAGIC_proto); - assert(mg); - assert(mg->mg_obj); - assert(SvTYPE(ppad[ix]) == SVt_PVCV); - assert(CvNAME_HEK((CV *)ppad[ix])); + /* Just provide a stub, but name it. It will be + upgrade to the real thing on scope entry. */ sv = newSV_type(SVt_PVCV); - CvNAME_HEK_set(sv, - share_hek_hek(CvNAME_HEK((CV *)ppad[ix]))); - sv_magic(sv,mg->mg_obj,PERL_MAGIC_proto,NULL,0); + CvNAME_HEK_set( + sv, + share_hek(SvPVX_const(namesv)+1, + SvCUR(namesv) - 1 + * (SvUTF8(namesv) ? -1 : 1), + 0) + ); } else sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') @@ -2105,12 +2121,16 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside) S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv); } + if (newcv) SvREFCNT_inc_simple_void_NN(cv); LEAVE; } static CV * S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) { + dVAR; + const bool newcv = !cv; + assert(!CvUNIQUE(proto)); if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto))); @@ -2135,7 +2155,7 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) if (SvMAGIC(proto)) mg_copy((SV *)proto, (SV *)cv, 0, 0); - if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside); + if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv); DEBUG_Xv( PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); @@ -2152,7 +2172,7 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside) */ SV* const const_sv = op_const_sv(CvSTART(cv), cv); if (const_sv) { - SvREFCNT_dec(cv); + SvREFCNT_dec_NN(cv); /* For this calling case, op_const_sv returns a *copy*, which we donate to newCONSTSUB. Yes, this is ugly, and should be killed. Need to fix how lib/constant.pm works to eliminate this. */ @@ -2219,7 +2239,10 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) : NULL; CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]); if (CvOUTSIDE(innercv) == old_cv) { - assert(CvWEAKOUTSIDE(innercv)); + if (!CvWEAKOUTSIDE(innercv)) { + SvREFCNT_dec(old_cv); + SvREFCNT_inc_simple_void_NN(new_cv); + } CvOUTSIDE(innercv) = new_cv; } } @@ -2454,7 +2477,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) #endif /* USE_ITHREADS */ PAD ** -Perl_padlist_store(pTHX_ register PADLIST *padlist, I32 key, PAD *val) +Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val) { dVAR; PAD **ary;