{
dVAR;
const PADLIST *padlist = CvPADLIST(cv);
+ bool const slabbed = !!CvSLABBED(cv);
PERL_ARGS_ASSERT_CV_UNDEF;
}
CvFILE(cv) = NULL;
+ CvSLABBED_off(cv);
if (!CvISXSUB(cv) && CvROOT(cv)) {
if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
Perl_croak(aTHX_ "Can't undef active subroutine");
PAD_SAVE_SETNULLPAD();
+#ifndef PL_OP_SLAB_ALLOC
+ if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
+#endif
op_free(CvROOT(cv));
CvROOT(cv) = NULL;
CvSTART(cv) = NULL;
LEAVE;
}
+#ifndef PL_OP_SLAB_ALLOC
+ else if (slabbed && CvSTART(cv)) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+
+ /* discard any leaked ops */
+ opslab_force_free((OPSLAB *)CvSTART(cv));
+ CvSTART(cv) = NULL;
+
+ LEAVE;
+ }
+# ifdef DEBUGGING
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+# endif
+#endif
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
CvGV_set(cv, NULL);
CV * const innercv = MUTABLE_CV(curpad[ix]);
U32 inner_rc = SvREFCNT(innercv);
assert(inner_rc);
+ assert(SvTYPE(innercv) != SVt_PVFM);
namepad[ix] = NULL;
SvREFCNT_dec(namesv);
CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
}
+#ifndef PL_OP_SLAB_ALLOC
+void
+Perl_cv_forget_slab(pTHX_ CV *cv)
+{
+ const bool slabbed = !!CvSLABBED(cv);
+
+ PERL_ARGS_ASSERT_CV_FORGET_SLAB;
+
+ if (!slabbed) return;
+
+ CvSLABBED_off(cv);
+
+ if (CvROOT(cv)) OpslabREFCNT_dec(OpSLAB(CvROOT(cv)));
+ else if (CvSTART(cv)) OpslabREFCNT_dec((OPSLAB *)CvSTART(cv));
+# ifdef DEBUGGING
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+# endif
+}
+#endif
+
/*
=for apidoc m|PADOFFSET|pad_alloc_name|SV *namesv|U32 flags|HV *typestash|HV *ourstash
/* XXX DAPM integrate alloc(), add_name() and add_anon(),
* or at least rationalise ??? */
-/* And flag whether the incoming name is UTF8 or 8 bit?
- Could do this either with the +ve/-ve hack of the HV code, or expanding
- the flag bits. Either way, this makes proper Unicode safe pad support.
- NWC
-*/
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
ix = pad_alloc(optype, SVs_PADMY);
av_store(PL_comppad_name, ix, name);
/* XXX DAPM use PL_curpad[] ? */
- av_store(PL_comppad, ix, (SV*)func);
+ if (SvTYPE(func) == SVt_PVCV || !CvOUTSIDE(func))
+ av_store(PL_comppad, ix, (SV*)func);
+ else {
+ SV *rv = newRV_inc((SV *)func);
+ sv_rvweaken(rv);
+ assert (SvTYPE(func) == SVt_PVFM);
+ av_store(PL_comppad, ix, rv);
+ }
SvPADMY_on((SV*)func);
/* to avoid ref loops, we never have parent + child referencing each
* other simultaneously */
- if (CvOUTSIDE(func)) {
+ if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
assert(!CvWEAKOUTSIDE(func));
CvWEAKOUTSIDE_on(func);
SvREFCNT_dec(CvOUTSIDE(func));
/*
=for apidoc m|U32|intro_my
-"Introduce" my variables to visible status.
+"Introduce" my variables to visible status. This is called during parsing
+at the end of each statement to make lexical variables visible to
+subsequent statements.
=cut
*/
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
CvCLONE_on(cv);
+ CvHASEVAL_on(cv);
}
}
}
assert(!CvUNIQUE(proto));
- /* Since cloneable anon subs can be nested, CvOUTSIDE may point
+ /* 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.
+ * 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.
- * Note that in general for formats, CvOUTSIDE != find_runcv */
+ */
- outside = CvOUTSIDE(proto);
- if (outside && CvCLONE(outside) && ! CvCLONED(outside))
+ if (SvTYPE(proto) == SVt_PVCV)
outside = find_runcv(NULL);
+ else {
+ outside = CvOUTSIDE(proto);
+ if (CvCLONE(outside) && ! CvCLONED(outside)) {
+ CV * const runcv = find_runcv_where(
+ FIND_RUNCV_root_eq, (void *)CvROOT(outside), NULL
+ );
+ if (runcv) outside = runcv;
+ }
+ }
depth = CvDEPTH(outside);
assert(depth || SvTYPE(proto) == SVt_PVFM);
if (!depth)
depth = 1;
- assert(CvPADLIST(outside));
+ assert(CvPADLIST(outside) || SvTYPE(proto) == SVt_PVFM);
ENTER;
SAVESPTR(PL_compcv);
cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
- CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC);
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
+ |CVf_SLABBED);
CvCLONED_on(cv);
CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
OP_REFCNT_UNLOCK;
CvSTART(cv) = CvSTART(proto);
- CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
+ if (CvHASEVAL(cv))
+ CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
if (SvPOK(proto))
sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
+ if (SvMAGIC(proto))
+ mg_copy((SV *)proto, (SV *)cv, 0, 0);
CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
PL_curpad = AvARRAY(PL_comppad);
- outpad = AvARRAY(AvARRAY(CvPADLIST(outside))[depth]);
+ outpad = CvPADLIST(outside)
+ ? AvARRAY(AvARRAY(CvPADLIST(outside))[depth])
+ : NULL;
for (ix = fpad; ix > 0; ix--) {
SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
SV *sv = NULL;
if (namesv && namesv != &PL_sv_undef) { /* lexical */
if (SvFAKE(namesv)) { /* lexical from outside? */
- sv = outpad[PARENT_PAD_INDEX(namesv)];
- assert(sv);
- /* formats may have an inactive parent,
+ /* formats may have an inactive, or even undefined, parent,
while my $x if $false can leave an active var marked as
stale. And state vars are always available */
- if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) {
+ if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)])
+ || (SvPADSTALE(sv) && !SvPAD_STATE(namesv))) {
Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%"SVf"\" is not available", namesv);
sv = NULL;
if (namesv && namesv != &PL_sv_undef
&& *SvPVX_const(namesv) == '&')
{
+ if (SvTYPE(curpad[ix]) == SVt_PVCV) {
CV * const innercv = MUTABLE_CV(curpad[ix]);
assert(CvWEAKOUTSIDE(innercv));
assert(CvOUTSIDE(innercv) == old_cv);
CvOUTSIDE(innercv) = new_cv;
+ }
+ else { /* format reference */
+ SV * const rv = curpad[ix];
+ CV *innercv;
+ if (!SvOK(rv)) continue;
+ assert(SvROK(rv));
+ assert(SvWEAKREF(rv));
+ innercv = (CV *)SvRV(rv);
+ assert(!CvWEAKOUTSIDE(innercv));
+ SvREFCNT_dec(CvOUTSIDE(innercv));
+ CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv);
+ }
}
}
}
AV *args;
/* Look for it in the table first, as the padlist may have ended up
as an element of @DB::args (or theoretically even @_), so it may
- may have been cloned already. It may also be there because of
- how Perl_sv_compile_2op() "works". :-( */
+ may have been cloned already. */
dstpad = (AV*)ptr_table_fetch(PL_ptr_table, srcpad);
if (dstpad)
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff