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(
padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
}
else {
- padlist->xpadl_id = PL_padlist_generation++;
av_store(pad, 0, NULL);
padname = newAV();
}
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;
if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */
curpad[ix] = NULL;
- SvREFCNT_dec(innercv);
+ SvREFCNT_dec_NN(innercv);
inner_rc--;
}
PL_comppad = NULL;
PL_curpad = NULL;
}
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
}
}
{
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);
if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
assert(!CvWEAKOUTSIDE(func));
CvWEAKOUTSIDE_on(func);
- SvREFCNT_dec(CvOUTSIDE(func));
+ SvREFCNT_dec_NN(CvOUTSIDE(func));
}
return ix;
}
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));
)
);
- 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]))
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) {
Perl_pad_free(pTHX_ PADOFFSET po)
{
dVAR;
+ SV *sv;
ASSERT_CURPAD_LEGAL("pad_free");
if (!PL_curpad)
return;
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;
}
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;
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 */
}
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));
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);
outpad = outside && CvPADLIST(outside)
? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth])
: NULL;
- 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;
else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
{
/* my sub */
- sv = newSV_type(SVt_PVCV);
- if (SvTYPE(ppad[ix]) == SVt_PVCV) {
- /* 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]));
- CvNAME_HEK_set(sv,
- share_hek_hek(CvNAME_HEK((CV *)ppad[ix])));
- sv_magic(sv,mg->mg_obj,PERL_MAGIC_proto,NULL,0);
- }
- else {
- assert(SvTYPE(ppad[ix]) == SVt_NULL);
- /* Unavailable; just provide a stub, but name it */
+ /* 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(SvPVX_const(namesv)+1,
* (SvUTF8(namesv) ? -1 : 1),
0)
);
- }
}
else sv = SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
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)));
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");
*/
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. */
#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;