AV which is @_. Other entries are storage for variables and op targets.
Iterating over the PADNAMELIST iterates over all possible pad
-items. Pad slots that are SVs_PADTMP (targets/GVs/constants) end up having
-&PL_sv_undef "names" (see pad_alloc()).
+items. Pad slots for targets (SVs_PADTMP)
+and GVs end up having &PL_sv_undef
+"names", while slots for constants have &PL_sv_no "names" (see
+pad_alloc()). That &PL_sv_no is used is an implementation detail subject
+to change. To test for it, use C<PadnamePV(name) && !PadnameLEN(name)>.
Only my/our variable (SvPADMY/PADNAME_isOUR) slots get valid names.
The rest are op targets/GVs/constants which are statically allocated
If PADNAME_OUTER (SvFAKE) is set on the
name SV, then that slot in the frame AV is
-a REFCNT'ed reference to a lexical from "outside". In this case,
+a REFCNT'ed reference to a lexical from "outside". In this case,
the name SV does not use xlow and xhigh to store a cop_seq range, since it is
-in scope throughout. Instead xhigh stores some flags containing info about
+in scope throughout. Instead xhigh stores some flags containing info about
the real lexical (is it declared in an anon, and is it capable of being
instantiated multiple times?), and for fake ANONs, xlow contains the index
within the parent's pad where the lexical's value is stored, to make
STMT_START { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = (val); } STMT_END
/*
-=for apidoc mx|void|pad_peg|const char *s
-
-When PERL_MAD is enabled, this is a small no-op function that gets called
-at the start of each pad-related function. It can be breakpointed to
-track all pad operations. The parameter is a string indicating the type
-of pad operation being performed.
-
-=cut
-*/
-
-#ifdef PERL_MAD
-void pad_peg(const char* s) {
- static int pegcnt; /* XXX not threadsafe */
- PERL_UNUSED_ARG(s);
-
- PERL_ARGS_ASSERT_PAD_PEG;
-
- pegcnt++;
-}
-#endif
-
-/*
This is basically sv_eq_flags() in sv.c, but we avoid the magic
and bytes checking.
*/
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(
PADLIST *
Perl_pad_new(pTHX_ int flags)
{
- dVAR;
PADLIST *padlist;
PAD *padname, *pad;
PAD **ary;
if (flags & padnew_SAVE) {
SAVECOMPPAD();
- SAVESPTR(PL_comppad_name);
if (! (flags & padnew_CLONE)) {
+ SAVESPTR(PL_comppad_name);
SAVEI32(PL_padix);
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_min_intro_pending);
/* ... create new pad ... */
Newxz(padlist, 1, PADLIST);
- padname = newAV();
pad = newAV();
if (flags & padnew_CLONE) {
AV * const a0 = newAV(); /* will be @_ */
av_store(pad, 0, MUTABLE_SV(a0));
AvREIFY_only(a0);
+
+ padname = (PAD *)SvREFCNT_inc_simple_NN(PL_comppad_name);
}
else {
- padlist->xpadl_id = PL_padlist_generation++;
av_store(pad, 0, NULL);
+ padname = newAV();
+ AvPAD_NAMELIST_on(padname);
+ av_store(padname, 0, &PL_sv_undef);
}
/* Most subroutines never recurse, hence only need 2 entries in the padlist
/* ... then update state variables */
- PL_comppad_name = padname;
PL_comppad = pad;
PL_curpad = AvARRAY(pad);
if (! (flags & padnew_CLONE)) {
+ PL_comppad_name = padname;
PL_comppad_name_fill = 0;
PL_min_intro_pending = 0;
PL_padix = 0;
=for apidoc cv_undef
-Clear out all the active components of a CV. This can happen either
+Clear out all the active components of a CV. This can happen either
by an explicit C<undef &foo>, or by the reference count going to zero.
In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
children can still follow the full lexical scope chain.
void
Perl_cv_undef(pTHX_ CV *cv)
{
- dVAR;
const PADLIST *padlist = CvPADLIST(cv);
bool const slabbed = !!CvSLABBED(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;
LEAVE;
}
#ifdef DEBUGGING
- else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
#endif
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
- CvGV_set(cv, NULL);
+ if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
+ else CvGV_set(cv, NULL);
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
U32 inner_rc = SvREFCNT(innercv);
assert(inner_rc);
assert(SvTYPE(innercv) != SVt_PVFM);
- namepad[ix] = NULL;
- SvREFCNT_dec(namesv);
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);
}
}
{
PAD * const sv = PadlistARRAY(padlist)[0];
- if (sv == PL_comppad_name)
+ if (sv == PL_comppad_name && SvREFCNT(sv) == 1)
PL_comppad_name = NULL;
SvREFCNT_dec(sv);
}
if (CvROOT(cv)) slab = OpSLAB(CvROOT(cv));
else if (CvSTART(cv)) slab = (OPSLAB *)CvSTART(cv);
#ifdef DEBUGGING
- else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", cv);
+ else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
#endif
if (slab) {
static PADOFFSET
S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash)
{
- dVAR;
const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY);
PERL_ARGS_ASSERT_PAD_ALLOC_NAME;
}
av_store(PL_comppad_name, offset, namesv);
+ PadnamelistMAXNAMED(PL_comppad_name) = offset;
return offset;
}
Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
U32 flags, HV *typestash, HV *ourstash)
{
- dVAR;
PADOFFSET offset;
SV *namesv;
bool is_utf8;
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);
sv_upgrade(PL_curpad[offset], SVt_PVAV);
else if (namelen != 0 && *namepv == '%')
sv_upgrade(PL_curpad[offset], SVt_PVHV);
+ else if (namelen != 0 && *namepv == '&')
+ sv_upgrade(PL_curpad[offset], SVt_PVCV);
assert(SvPADMY(PL_curpad[offset]));
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
SVs_PADMY named lexical variable ("my", "our", "state")
SVs_PADTMP unnamed temporary store
+ SVf_READONLY constant shared between recursion levels
+
+C<SVf_READONLY> has been supported here only since perl 5.20. To work with
+earlier versions as well, use C<SVf_READONLY|SVs_PADTMP>. C<SVf_READONLY>
+does not cause the SV in the pad slot to be marked read-only, but simply
+tells C<pad_alloc> that it I<will> be made read-only (by the caller), or at
+least should be treated as such.
I<optype> should be an opcode indicating the type of operation that the
pad entry is to support. This doesn't affect operational semantics,
PADOFFSET
Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
{
- dVAR;
SV *sv;
I32 retval;
const SSize_t names_fill = AvFILLp(PL_comppad_name);
for (;;) {
/*
- * "foreach" index vars temporarily become aliases to non-"my"
- * values. Thus we must skip, not just pad values that are
+ * Entries that close over unavailable variables
+ * in outer subs contain values not marked PADMY.
+ * Thus we must skip, not just pad values that are
* marked as current pad values, but also those with names.
*/
- /* HVDS why copy to sv here? we don't seem to use it */
if (++PL_padix <= names_fill &&
(sv = names[PL_padix]) && sv != &PL_sv_undef)
continue;
sv = *av_fetch(PL_comppad, PL_padix, TRUE);
if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) &&
- !IS_PADGV(sv) && !IS_PADCONST(sv))
+ !IS_PADGV(sv))
break;
}
+ if (tmptype & SVf_READONLY) {
+ av_store(PL_comppad_name, PL_padix, &PL_sv_no);
+ tmptype &= ~SVf_READONLY;
+ tmptype |= SVs_PADTMP;
+ }
retval = PL_padix;
}
SvFLAGS(sv) |= tmptype;
PADOFFSET
Perl_pad_add_anon(pTHX_ CV* func, I32 optype)
{
- dVAR;
PADOFFSET ix;
SV* const name = newSV_type(SVt_PVNV);
if (CvOUTSIDE(func) && SvTYPE(func) == SVt_PVCV) {
assert(!CvWEAKOUTSIDE(func));
CvWEAKOUTSIDE_on(func);
- SvREFCNT_dec(CvOUTSIDE(func));
+ SvREFCNT_dec_NN(CvOUTSIDE(func));
}
return ix;
}
STATIC void
S_pad_check_dup(pTHX_ SV *name, U32 flags, const HV *ourstash)
{
- dVAR;
SV **svp;
PADOFFSET top, off;
const U32 is_our = flags & padadd_OUR;
for (off = top; (I32)off > PL_comppad_name_floor; off--) {
SV * const sv = svp[off];
if (sv
- && sv != &PL_sv_undef
+ && PadnameLEN(sv)
&& !SvFAKE(sv)
&& ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
|| COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
{
if (is_our && (SvPAD_OUR(sv)))
break; /* "our" masking "our" */
+ /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"%s\" variable %"SVf" masks earlier declaration in same %s",
+ "\"%s\" %s %"SVf" masks earlier declaration in same %s",
(is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : "state"),
- sv,
+ *SvPVX(sv) == '&' ? "subroutine" : "variable",
+ SVfARG(sv),
(COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO
? "scope" : "statement"));
--off;
while (off > 0) {
SV * const sv = svp[off];
if (sv
- && sv != &PL_sv_undef
+ && PadnameLEN(sv)
&& !SvFAKE(sv)
&& ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO
|| COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
&& sv_eq(name, sv))
{
Perl_warner(aTHX_ packWARN(WARN_MISC),
- "\"our\" variable %"SVf" redeclared", sv);
+ "\"our\" variable %"SVf" redeclared", SVfARG(sv));
if ((I32)off <= PL_comppad_name_floor)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"\t(Did you mean \"local\" instead of \"our\"?)\n");
PADOFFSET
Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags)
{
- dVAR;
SV *out_sv;
int out_flags;
I32 offset;
name_svp = AvARRAY(nameav);
for (offset = AvFILLp(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
- if (namesv && namesv != &PL_sv_undef
+ if (namesv && PadnameLEN(namesv) == namelen
&& !SvFAKE(namesv)
&& (SvPAD_OUR(namesv))
- && SvCUR(namesv) == namelen
&& sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
flags & padadd_UTF8_NAME ? SVf_UTF8 : 0 )
&& COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
PADOFFSET
Perl_find_rundefsvoffset(pTHX)
{
- dVAR;
SV *out_sv;
int out_flags;
return pad_findlex("$_", 2, 0, find_runcv(NULL), PL_curcop->cop_seq, 1,
/*
=for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
-Find a named lexical anywhere in a chain of nested pads. Add fake entries
+Find a named lexical anywhere in a chain of nested pads. Add fake entries
in the inner pads if it's found in an outer one.
Returns the offset in the bottom pad of the lex or the fake lex.
cv is the CV in which to start the search, and seq is the current cop_seq
-to match against. If warn is true, print appropriate warnings. The out_*
+to match against. If warn is true, print appropriate warnings. The out_*
vars return values, and so are pointers to where the returned values
-should be stored. out_capture, if non-null, requests that the innermost
+should be stored. out_capture, if non-null, requests that the innermost
instance of the lexical is captured; out_name_sv is set to the innermost
matched namesv or fake namesv; out_flags returns the flags normally
associated with the IVX field of a fake namesv.
Note that pad_findlex() is recursive; it recurses up the chain of CVs,
-then comes back down, adding fake entries as it goes. It has to be this way
+then comes back down, adding fake entries
+as it goes. It has to be this way
because fake namesvs in anon protoypes have to store in xlow the index into
the parent pad.
#define CvCOMPILED(cv) CvROOT(cv)
/* the CV does late binding of its lexicals */
-#define CvLATE(cv) (CvANON(cv) || SvTYPE(cv) == SVt_PVFM)
+#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",
+ SVfARG(namesv));
+}
STATIC PADOFFSET
S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq,
int warn, SV** out_capture, SV** out_name_sv, int *out_flags)
{
- dVAR;
I32 offset, new_offset;
SV *new_capture;
SV **new_capturep;
const AV * const nameav = PadlistARRAY(padlist)[0];
SV * const * const name_svp = AvARRAY(nameav);
- for (offset = AvFILLp(nameav); offset > 0; offset--) {
+ for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) {
const SV * const namesv = name_svp[offset];
- if (namesv && namesv != &PL_sv_undef
- && SvCUR(namesv) == namelen
+ if (namesv && PadnameLEN(namesv) == namelen
&& sv_eq_pvn_flags(aTHX_ namesv, namepv, namelen,
flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))
{
: *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)));
newwarn = 0;
Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%"SVf"\" will not stay shared",
- newSVpvn_flags(namepv, namelen,
+ SVfARG(newSVpvn_flags(namepv, namelen,
SVs_TEMP |
- (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0)));
+ (flags & padadd_UTF8_NAME ? SVf_UTF8 : 0))));
}
if (fake_offset && CvANON(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)));
*out_capture = sv_2mortal(MUTABLE_SV(newAV()));
else if (namelen != 0 && *namepv == '%')
*out_capture = sv_2mortal(MUTABLE_SV(newHV()));
+ else if (namelen != 0 && *namepv == '&')
+ *out_capture = sv_2mortal(newSV_type(SVt_PVCV));
else
*out_capture = sv_newmortal();
}
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));
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
- dVAR;
ASSERT_CURPAD_ACTIVE("pad_sv");
if (!po)
void
Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_PAD_SETSV;
ASSERT_CURPAD_ACTIVE("pad_setsv");
void
Perl_pad_block_start(pTHX_ int full)
{
- dVAR;
ASSERT_CURPAD_ACTIVE("pad_block_start");
SAVEI32(PL_comppad_name_floor);
PL_comppad_name_floor = AvFILLp(PL_comppad_name);
U32
Perl_intro_my(pTHX)
{
- dVAR;
SV **svp;
I32 i;
U32 seq;
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
SV * const sv = svp[i];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ if (sv && PadnameLEN(sv) && !SvFAKE(sv)
&& COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO)
{
COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */
=cut
*/
-void
+OP *
Perl_pad_leavemy(pTHX)
{
- dVAR;
I32 off;
+ OP *o = NULL;
SV * const * const svp = AvARRAY(PL_comppad_name);
PL_pad_reset_pending = FALSE;
if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
const SV * const sv = svp[off];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
+ if (sv && PadnameLEN(sv) && !SvFAKE(sv))
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
"%"SVf" never introduced",
SVfARG(sv));
}
/* "Deintroduce" my variables that are leaving with this scope. */
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
- const SV * const sv = svp[off];
- if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
+ SV * const sv = svp[off];
+ if (sv && PadnameLEN(sv) && !SvFAKE(sv)
&& COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
{
COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax);
(unsigned long)COP_SEQ_RANGE_LOW(sv),
(unsigned long)COP_SEQ_RANGE_HIGH(sv))
);
+ if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
+ && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
+ OP *kid = newOP(OP_INTROCV, 0);
+ kid->op_targ = off;
+ o = op_prepend_elem(OP_LINESEQ, kid, o);
+ }
}
}
PL_cop_seqmax++;
PL_cop_seqmax++;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
+ return o;
}
/*
void
Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
{
- dVAR;
ASSERT_CURPAD_LEGAL("pad_swipe");
if (!PL_curpad)
return;
"Pad 0x%"UVxf"[0x%"UVxf"] swipe: %ld\n",
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po));
- if (PL_curpad[po])
- SvPADTMP_off(PL_curpad[po]);
if (refadjust)
SvREFCNT_dec(PL_curpad[po]);
PL_curpad[po] = newSV(0);
SvPADTMP_on(PL_curpad[po]);
#else
- PL_curpad[po] = &PL_sv_undef;
+ PL_curpad[po] = NULL;
#endif
+ if (PadnamelistMAX(PL_comppad_name) != -1
+ && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) {
+ if (PadnamelistARRAY(PL_comppad_name)[po]) {
+ assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po]));
+ }
+ PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef;
+ }
if ((I32)po < PL_padix)
PL_padix = po - 1;
}
static void
S_pad_reset(pTHX)
{
- dVAR;
#ifdef USE_BROKEN_PAD_RESET
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
)
);
- 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) {
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad clone on cv=0x%"UVxf"\n", PTR2UV(cv)));
CvCLONE_on(cv);
- CvHASEVAL_on(cv);
}
+ CvHASEVAL_on(cv);
}
}
- /* extend curpad to match namepad */
+ /* extend namepad to match curpad */
if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
av_store(PL_comppad_name, AvFILLp(PL_comppad), NULL);
if (type == padtidy_SUBCLONE) {
- SV * const * const namep = AvARRAY(PL_comppad_name);
+ SV ** const namep = AvARRAY(PL_comppad_name);
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
SV *namesv;
+ if (!namep[ix]) namep[ix] = &PL_sv_undef;
- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
- continue;
/*
* The only things that a clonable function needs in its
- * pad are anonymous subs.
+ * pad are anonymous subs, constants and GVs.
* The rest are created anew during cloning.
*/
- if (!((namesv = namep[ix]) != NULL &&
- namesv != &PL_sv_undef &&
- *SvPVX_const(namesv) == '&'))
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
+ || IS_PADGV(PL_curpad[ix]))
+ continue;
+ namesv = namep[ix];
+ if (!(PadnamePV(namesv) &&
+ (!PadnameLEN(namesv) || *SvPVX_const(namesv) == '&')))
{
SvREFCNT_dec(PL_curpad[ix]);
PL_curpad[ix] = NULL;
}
if (type == padtidy_SUB || type == padtidy_FORMAT) {
- SV * const * const namep = AvARRAY(PL_comppad_name);
+ SV ** const namep = AvARRAY(PL_comppad_name);
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
- if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
+ if (!namep[ix]) namep[ix] = &PL_sv_undef;
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
+ || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
continue;
if (!SvPADMY(PL_curpad[ix])) {
SvPADTMP_on(PL_curpad[ix]);
void
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;
}
void
Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
{
- dVAR;
const AV *pad_name;
const AV *pad;
SV **pname;
for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
const SV *namesv = pname[ix];
- if (namesv && namesv == &PL_sv_undef) {
+ if (namesv && !PadnameLEN(namesv)) {
namesv = NULL;
}
if (namesv) {
STATIC void
S_cv_dump(pTHX_ const CV *cv, const char *title)
{
- dVAR;
const CV * const outside = CvOUTSIDE(cv);
PADLIST* const padlist = CvPADLIST(cv);
=cut
*/
-CV *
-Perl_cv_clone(pTHX_ CV *proto)
+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, bool newcv)
{
- dVAR;
I32 ix;
PADLIST* const protopadlist = CvPADLIST(proto);
- const PAD *const protopad_name = *PadlistARRAY(protopadlist);
+ PAD *const protopad_name = *PadlistARRAY(protopadlist);
const PAD *const protopad = PadlistARRAY(protopadlist)[1];
SV** const pname = AvARRAY(protopad_name);
SV** const ppad = AvARRAY(protopad);
const I32 fname = AvFILLp(protopad_name);
const I32 fpad = AvFILLp(protopad);
- CV* cv;
SV** outpad;
- CV* outside;
long depth;
-
- PERL_ARGS_ASSERT_CV_CLONE;
+ bool subclones = FALSE;
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 (SvTYPE(proto) == SVt_PVCV)
+ if (!outside) {
+ if (CvWEAKOUTSIDE(proto))
outside = find_runcv(NULL);
- else {
+ 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;
- assert(depth || SvTYPE(proto) == SVt_PVFM);
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 */
- cv = PL_compcv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
- CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
- |CVf_SLABBED);
- CvCLONED_on(cv);
-
- CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
- : CvFILE(proto);
- CvGV_set(cv,CvGV(proto));
- CvSTASH_set(cv, CvSTASH(proto));
- OP_REFCNT_LOCK;
- CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
- OP_REFCNT_UNLOCK;
- CvSTART(cv) = CvSTART(proto);
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);
+ 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);
- for (ix = fname; ix > 0; ix--)
- av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
PL_curpad = AvARRAY(PL_comppad);
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;
SV *sv = NULL;
- if (namesv && namesv != &PL_sv_undef) { /* lexical */
+ if (namesv && PadnameLEN(namesv)) { /* lexical */
+ if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */
+ NOOP;
+ }
+ else {
if (SvFAKE(namesv)) { /* lexical from outside? */
/* formats may have an inactive, or even undefined, parent;
but state vars are always available. */
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
if (!sv) {
const char sigil = SvPVX_const(namesv)[0];
if (sigil == '&')
- sv = SvREFCNT_inc(ppad[ix]);
+ /* If there are state subs, we need to clone them, too.
+ But they may need to close over variables we have
+ not cloned yet. So we will have to do a second
+ pass. Furthermore, there may be state subs clos-
+ ing over other state subs’ entries, so we have
+ to put a stub here and then clone into it on the
+ second pass. */
+ if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
+ assert(SvTYPE(ppad[ix]) == SVt_PVCV);
+ subclones = 1;
+ sv = newSV_type(SVt_PVCV);
+ }
+ else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
+ {
+ /* my sub */
+ /* 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,
+ SvCUR(namesv) - 1
+ * (SvUTF8(namesv) ? -1 : 1),
+ 0)
+ );
+ }
+ else sv = SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
sv = MUTABLE_SV(newAV());
else if (sigil == '%')
sv = newSV(0);
SvPADMY_on(sv);
/* reset the 'assign only once' flag on each state var */
- if (SvPAD_STATE(namesv))
+ if (sigil != '&' && SvPAD_STATE(namesv))
SvPADSTALE_on(sv);
}
+ }
}
- else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
+ else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
sv = SvREFCNT_inc_NN(ppad[ix]);
}
else {
PL_curpad[ix] = sv;
}
+ if (subclones)
+ for (ix = fpad; ix > 0; ix--) {
+ SV* const namesv = (ix <= fname) ? pname[ix] : NULL;
+ if (namesv && namesv != &PL_sv_undef && !SvFAKE(namesv)
+ && SvPVX_const(namesv)[0] == '&' && SvPAD_STATE(namesv))
+ 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)
+{
+#ifdef USE_ITHREADS
+ dVAR;
+#endif
+ const bool newcv = !cv;
+
+ assert(!CvUNIQUE(proto));
+
+ if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto)));
+ CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC
+ |CVf_SLABBED);
+ CvCLONED_on(cv);
+
+ CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto))
+ : CvFILE(proto);
+ if (CvNAMED(proto))
+ CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto)));
+ else CvGV_set(cv,CvGV(proto));
+ CvSTASH_set(cv, CvSTASH(proto));
+ OP_REFCNT_LOCK;
+ CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
+ OP_REFCNT_UNLOCK;
+ CvSTART(cv) = CvSTART(proto);
+ CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
+
+ if (SvPOK(proto)) {
+ sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto));
+ if (SvUTF8(proto))
+ SvUTF8_on(MUTABLE_SV(cv));
+ }
+ if (SvMAGIC(proto))
+ mg_copy((SV *)proto, (SV *)cv, 0, 0);
+
+ if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
+
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
- if (outside) cv_dump(outside, "Outside");
+ if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside");
cv_dump(proto, "Proto");
cv_dump(cv, "To");
);
- LEAVE;
-
if (CvCONST(cv)) {
/* Constant sub () { $x } closing over $x - see lib/constant.pm:
* The prototype was marked as a candiate for const-ization,
*/
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. */
return cv;
}
+CV *
+Perl_cv_clone(pTHX_ CV *proto)
+{
+ PERL_ARGS_ASSERT_CV_CLONE;
+
+ if (!CvPADLIST(proto)) Perl_croak(aTHX_ "panic: no pad in cv_clone");
+ return S_cv_clone(aTHX_ proto, NULL, NULL);
+}
+
+/* Called only by pp_clonecv */
+CV *
+Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
+{
+ PERL_ARGS_ASSERT_CV_CLONE_INTO;
+ cv_undef(target);
+ return S_cv_clone(aTHX_ proto, target, NULL);
+}
+
/*
=for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
For any anon CVs in the pad, change CvOUTSIDE of that CV from
-old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
+old_cv to new_cv if necessary. Needed when a newly-compiled CV has to be
moved to a pre-existing CV struct.
=cut
void
Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
{
- dVAR;
I32 ix;
AV * const comppad_name = PadlistARRAY(padlist)[0];
AV * const comppad = PadlistARRAY(padlist)[1];
for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
const SV * const namesv = namepad[ix];
- if (namesv && namesv != &PL_sv_undef
+ if (namesv && namesv != &PL_sv_undef && !SvPAD_STATE(namesv)
&& *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;
+ MAGIC * const mg =
+ SvMAGICAL(curpad[ix])
+ ? mg_find(curpad[ix], PERL_MAGIC_proto)
+ : NULL;
+ CV * const innercv = MUTABLE_CV(mg ? mg->mg_obj : curpad[ix]);
+ if (CvOUTSIDE(innercv) == old_cv) {
+ if (!CvWEAKOUTSIDE(innercv)) {
+ SvREFCNT_dec(old_cv);
+ SvREFCNT_inc_simple_void_NN(new_cv);
+ }
+ CvOUTSIDE(innercv) = new_cv;
+ }
}
else { /* format reference */
SV * const rv = curpad[ix];
void
Perl_pad_push(pTHX_ PADLIST *padlist, int depth)
{
- dVAR;
-
PERL_ARGS_ASSERT_PAD_PUSH;
if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) {
AV *av;
for ( ;ix > 0; ix--) {
- if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+ if (names_fill >= ix && PadnameLEN(names[ix])) {
const char sigil = SvPVX_const(names[ix])[0];
if ((SvFLAGS(names[ix]) & SVf_FAKE)
|| (SvFLAGS(names[ix]) & SVpad_STATE)
SvPADMY_on(sv);
}
}
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
}
else {
HV *
Perl_pad_compname_type(pTHX_ const PADOFFSET po)
{
- dVAR;
- SV* const * const av = av_fetch(PL_comppad_name, po, FALSE);
- if ( SvPAD_TYPED(*av) ) {
- return SvSTASH(*av);
+ SV* const av = PAD_COMPNAME_SV(po);
+ if ( SvPAD_TYPED(av) ) {
+ return SvSTASH(av);
}
return NULL;
}
for ( ;ix > 0; ix--) {
if (!oldpad[ix]) {
pad1a[ix] = NULL;
- } else if (names_fill >= ix && names[ix] != &PL_sv_undef) {
+ } else if (names_fill >= ix && names[ix] &&
+ PadnameLEN(names[ix])) {
const char sigil = SvPVX_const(names[ix])[0];
if ((SvFLAGS(names[ix]) & SVf_FAKE)
|| (SvFLAGS(names[ix]) & SVpad_STATE)
}
}
}
- else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
+ else if (IS_PADGV(oldpad[ix])
+ || ( names_fill >= ix && names[ix]
+ && PadnamePV(names[ix]) )) {
pad1a[ix] = sv_dup_inc(oldpad[ix], param);
}
else {
#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;
SSize_t const oldmax = PadlistMAX(padlist);
https://perl5.git.perl.org / perl5.git / blobdiff