executing). Require'd files are simply evals without any outer lexical
scope.
-XSUBs don't have CvPADLIST set - dXSTARG fetches values from PL_curpad,
+XSUBs do not have a CvPADLIST. dXSTARG fetches values from PL_curpad,
but that is really the callers pad (a slot of which is allocated by
-every entersub).
+every entersub). Do not get or set CvPADLIST if a CV is an XSUB (as
+determined by C<CvISXSUB()>), CvPADLIST slot is reused for a different
+internal purpose in XSUBs.
The PADLIST has a C array where pads are stored.
STRLEN cur1 = SvCUR(sv);
const char *pv2 = pv;
STRLEN cur2 = pvlen;
- if (PL_encoding) {
+ if (IN_ENCODING) {
SV* svrecode = NULL;
if (SvUTF8(sv)) {
svrecode = newSVpvn(pv2, cur2);
- sv_recode_to_utf8(svrecode, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
pv2 = SvPV_const(svrecode, cur2);
}
else {
svrecode = newSVpvn(pv1, cur1);
- sv_recode_to_utf8(svrecode, PL_encoding);
+ sv_recode_to_utf8(svrecode, _get_encoding());
pv1 = SvPV_const(svrecode, cur1);
}
SvREFCNT_dec_NN(svrecode);
|| memEQ(SvPVX_const(sv), pv, pvlen));
}
+#ifdef DEBUGGING
+void
+Perl_set_padlist(CV * cv, PADLIST *padlist){
+ PERL_ARGS_ASSERT_SET_PADLIST;
+# if PTRSIZE == 8
+ if((Size_t)padlist == UINT64_C(0xEFEFEFEFEFEFEFEF)){
+ assert(0);
+ }
+# elif PTRSIZE == 4
+ if((Size_t)padlist == UINT64_C(0xEFEFEFEF)){
+ assert(0);
+ }
+# else
+# error unknown pointer size
+# endif
+ if(CvISXSUB(cv)){
+ assert(0);
+ }
+ ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_padlist_u.xcv_padlist = padlist;
+}
+#endif
/*
=for apidoc Am|PADLIST *|pad_new|int flags
void
Perl_cv_undef(pTHX_ CV *cv)
{
- const PADLIST *padlist = CvPADLIST(cv);
- bool const slabbed = !!CvSLABBED(cv);
-
PERL_ARGS_ASSERT_CV_UNDEF;
+ cv_undef_flags(cv, 0);
+}
+
+void
+Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
+{
+ CV cvbody;/*CV body will never be realloced inside this func,
+ so dont read it more than once, use fake CV so existing macros
+ will work, the indirection and CV head struct optimized away*/
+ SvANY(&cvbody) = SvANY(cv);
+
+ PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
DEBUG_X(PerlIO_printf(Perl_debug_log,
"CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
PTR2UV(cv), PTR2UV(PL_comppad))
);
- if (CvFILE(cv) && CvDYNFILE(cv)) {
- Safefree(CvFILE(cv));
- }
- 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");
- ENTER;
-
- PAD_SAVE_SETNULLPAD();
-
- if (slabbed) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(cv)));
- op_free(CvROOT(cv));
- CvROOT(cv) = NULL;
- CvSTART(cv) = NULL;
- LEAVE;
+ if (CvFILE(&cvbody)) {
+ char * file = CvFILE(&cvbody);
+ CvFILE(&cvbody) = NULL;
+ if(CvDYNFILE(&cvbody))
+ Safefree(file);
}
- else if (slabbed && CvSTART(cv)) {
- ENTER;
- 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;
- }
+ /* CvSLABBED_off(&cvbody); *//* turned off below */
+ /* release the sub's body */
+ if (!CvISXSUB(&cvbody)) {
+ if(CvROOT(&cvbody)) {
+ assert(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); /*unsafe is safe */
+ if (CvDEPTHunsafe(&cvbody)) {
+ assert(SvTYPE(cv) == SVt_PVCV);
+ Perl_croak_nocontext("Can't undef active subroutine");
+ }
+ ENTER;
+
+ PAD_SAVE_SETNULLPAD();
+
+ if (CvSLABBED(&cvbody)) OpslabREFCNT_dec_padok(OpSLAB(CvROOT(&cvbody)));
+ op_free(CvROOT(&cvbody));
+ CvROOT(&cvbody) = NULL;
+ CvSTART(&cvbody) = NULL;
+ LEAVE;
+ }
+ else if (CvSLABBED(&cvbody)) {
+ if( CvSTART(&cvbody)) {
+ ENTER;
+ PAD_SAVE_SETNULLPAD();
+
+ /* discard any leaked ops */
+ if (PL_parser)
+ parser_free_nexttoke_ops(PL_parser, (OPSLAB *)CvSTART(&cvbody));
+ opslab_force_free((OPSLAB *)CvSTART(&cvbody));
+ CvSTART(&cvbody) = NULL;
+
+ LEAVE;
+ }
#ifdef DEBUGGING
- else if (slabbed) Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
+ else Perl_warn(aTHX_ "Slab leaked from cv %p", (void*)cv);
#endif
+ }
+ }
+ else { /* dont bother checking if CvXSUB(cv) is true, less branching */
+ CvXSUB(&cvbody) = NULL;
+ }
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
- if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL);
- else CvGV_set(cv, NULL);
+ if (!(flags & CV_UNDEF_KEEP_NAME)) {
+ if (CvNAMED(&cvbody)) {
+ CvNAME_HEK_set(&cvbody, NULL);
+ CvNAMED_off(&cvbody);
+ }
+ else CvGV_set(cv, NULL);
+ }
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
- if (padlist) {
+ if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) {
I32 ix;
+ const PADLIST *padlist = CvPADLIST(&cvbody);
/* Free the padlist associated with a CV.
If parts of it happen to be current, we null the relevant PL_*pad*
* children, or integrate this loop with general cleanup */
if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */
- CV * const outercv = CvOUTSIDE(cv);
- const U32 seq = CvOUTSIDE_SEQ(cv);
+ CV * const outercv = CvOUTSIDE(&cvbody);
+ const U32 seq = CvOUTSIDE_SEQ(&cvbody);
PAD * const comppad_name = PadlistARRAY(padlist)[0];
SV ** const namepad = AvARRAY(comppad_name);
PAD * const comppad = PadlistARRAY(padlist)[1];
}
if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist));
Safefree(padlist);
- CvPADLIST(cv) = NULL;
+ CvPADLIST_set(&cvbody, NULL);
}
+ else if (CvISXSUB(&cvbody))
+ CvHSCXT(&cvbody) = NULL;
+ /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */
/* remove CvOUTSIDE unless this is an undef rather than a free */
- if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
- if (!CvWEAKOUTSIDE(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
- CvOUTSIDE(cv) = NULL;
- }
- if (CvCONST(cv)) {
- SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
- CvCONST_off(cv);
+ if (!SvREFCNT(cv)) {
+ CV * outside = CvOUTSIDE(&cvbody);
+ if(outside) {
+ CvOUTSIDE(&cvbody) = NULL;
+ if (!CvWEAKOUTSIDE(&cvbody))
+ SvREFCNT_dec_NN(outside);
+ }
}
- if (CvISXSUB(cv) && CvXSUB(cv)) {
- CvXSUB(cv) = NULL;
+ if (CvCONST(&cvbody)) {
+ SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr));
+ /* CvCONST_off(cv); *//* turned off below */
}
/* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
- * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses
- * to choose an error message */
- CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON);
+ * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
+ * LEXICAL, which are used to determine the sub's name. */
+ CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
+ |CVf_NAMED);
}
/*
AvARRAY(PL_comppad), PL_curpad);
if (PL_pad_reset_pending)
pad_reset();
- if (tmptype & SVs_PADMY) {
+ if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */
/* For a my, simply push a null SV onto the end of PL_comppad. */
sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
retval = AvFILLp(PL_comppad);
* 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.
+ * If pad_reset is enabled, ‘current’ means different
+ * things depending on whether we are allocating a con-
+ * stant or a target. For a target, things marked PADTMP
+ * can be reused; not so for constants.
*/
if (++retval <= names_fill &&
(sv = names[retval]) && sv != &PL_sv_undef)
continue;
sv = *av_fetch(PL_comppad, retval, TRUE);
if (!(SvFLAGS(sv) &
-#ifdef USE_BROKEN_PAD_RESET
- (SVs_PADMY|(konst ? SVs_PADTMP : 0))
+#ifdef USE_PAD_RESET
+ (konst ? SVs_PADTMP : 0))
#else
- (SVs_PADMY|SVs_PADTMP)
+ SVs_PADTMP
#endif
- ) &&
- !IS_PADGV(sv))
+ ))
break;
}
if (konst) {
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 */
fake_offset = offset; /* in case we don't find a real one */
continue;
}
- /* is seq within the range _LOW to _HIGH ?
- * This is complicated by the fact that PL_cop_seqmax
- * may have wrapped around at some point */
- if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
- continue; /* not yet introduced */
-
- if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
- /* in compiling scope */
- if (
- (seq > COP_SEQ_RANGE_LOW(namesv))
- ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
- : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
- )
- break;
- }
- else if (
- (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
- ?
- ( seq > COP_SEQ_RANGE_LOW(namesv)
- || seq <= COP_SEQ_RANGE_HIGH(namesv))
-
- : ( seq > COP_SEQ_RANGE_LOW(namesv)
- && seq <= COP_SEQ_RANGE_HIGH(namesv))
- )
- break;
+ if (PadnameIN_SCOPE(namesv, seq))
+ break;
}
}
PL_min_intro_pending = 0;
SAVEI32(PL_comppad_name_fill);
SAVEI32(PL_padix_floor);
+ /* PL_padix_floor is what PL_padix is reset to at the start of each
+ statement, by pad_reset(). We set it when entering a new scope
+ to keep things like this working:
+ print "$foo$bar", do { this(); that() . "foo" };
+ We must not let "$foo$bar" and the later concatenation share the
+ same target. */
PL_padix_floor = PL_padix;
PL_pad_reset_pending = FALSE;
}
/*
-=for apidoc m|U32|intro_my
+=for apidoc Am|U32|intro_my
-"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.
+"Introduce" C<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
*/
U32 seq;
ASSERT_CURPAD_ACTIVE("intro_my");
+ if (PL_compiling.cop_seq) {
+ seq = PL_compiling.cop_seq;
+ PL_compiling.cop_seq = 0;
+ }
+ else
+ seq = PL_cop_seqmax;
if (! PL_min_intro_pending)
- return PL_cop_seqmax;
+ return seq;
svp = AvARRAY(PL_comppad_name);
for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
);
}
}
- seq = PL_cop_seqmax;
- PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ COP_SEQMAX_INC;
PL_min_intro_pending = 0;
PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
}
}
}
- PL_cop_seqmax++;
- if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
- PL_cop_seqmax++;
+ COP_SEQMAX_INC;
DEBUG_Xv(PerlIO_printf(Perl_debug_log,
"Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
return o;
/* if pad tmps aren't shared between ops, then there's no need to
* create a new tmp when an existing op is freed */
-#ifdef USE_BROKEN_PAD_RESET
+#ifdef USE_PAD_RESET
PL_curpad[po] = newSV(0);
SvPADTMP_on(PL_curpad[po]);
#else
=cut
*/
-/* XXX pad_reset() is currently disabled because it results in serious bugs.
- * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
- * on the stack by OPs that use them, there are several ways to get an alias
- * to a shared TARG. Such an alias will change randomly and unpredictably.
- * We avoid doing this until we can think of a Better Way.
- * GSAR 97-10-29 */
+/* pad_reset() causes pad temp TARGs (operator targets) to be shared
+ * between OPs from different statements. During compilation, at the start
+ * of each statement pad_reset resets PL_padix back to its previous value.
+ * When allocating a target, pad_alloc begins its scan through the pad at
+ * PL_padix+1. */
static void
S_pad_reset(pTHX)
{
-#ifdef USE_BROKEN_PAD_RESET
+#ifdef USE_PAD_RESET
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
AvARRAY(PL_comppad), PL_curpad);
* pad are anonymous subs, constants and GVs.
* The rest are created anew during cloning.
*/
- if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])
- || IS_PADGV(PL_curpad[ix]))
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
continue;
namesv = namep[ix];
if (!(PadnamePV(namesv) &&
PADOFFSET ix;
for (ix = AvFILLp(PL_comppad); ix > 0; 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]))
+ if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]))
continue;
- if (!SvPADMY(PL_curpad[ix])) {
- SvPADTMP_on(PL_curpad[ix]);
- } else if (!SvFAKE(namep[ix])) {
+ if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) {
/* This is a work around for how the current implementation of
?{ } blocks in regexps interacts with lexicals.
void
Perl_pad_free(pTHX_ PADOFFSET po)
{
-#ifndef USE_BROKEN_PAD_RESET
+#ifndef USE_PAD_RESET
SV *sv;
#endif
ASSERT_CURPAD_LEGAL("pad_free");
PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)
);
-#ifndef USE_BROKEN_PAD_RESET
+#ifndef USE_PAD_RESET
sv = PL_curpad[po];
if (sv && sv != &PL_sv_undef && !SvPADMY(sv))
SvFLAGS(sv) &= ~SVs_PADTMP;
static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
-static void
+static CV *
S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
{
I32 ix;
SAVESPTR(PL_comppad_name);
PL_comppad_name = protopad_name;
- CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE);
+ CvPADLIST_set(cv, pad_new(padnew_CLONE|padnew_SAVE));
av_fill(PL_comppad, fpad);
assert(SvTYPE(ppad[ix]) == SVt_PVCV);
subclones = 1;
sv = newSV_type(SVt_PVCV);
+ CvLEXICAL_on(sv);
}
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. */
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, SvPVX_const(namesv)+1,
+ SvCUR(namesv) - 1);
sv = newSV_type(SVt_PVCV);
CvNAME_HEK_set(
sv,
share_hek(SvPVX_const(namesv)+1,
- SvCUR(namesv) - 1
+ (SvCUR(namesv) - 1)
* (SvUTF8(namesv) ? -1 : 1),
- 0)
+ hash)
);
+ CvLEXICAL_on(sv);
}
else sv = SvREFCNT_inc(ppad[ix]);
else if (sigil == '@')
sv = MUTABLE_SV(newHV());
else
sv = newSV(0);
- SvPADMY_on(sv);
/* reset the 'assign only once' flag on each state var */
if (sigil != '&' && SvPAD_STATE(namesv))
SvPADSTALE_on(sv);
}
}
}
- else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
+ else if (namesv && PadnamePV(namesv)) {
sv = SvREFCNT_inc_NN(ppad[ix]);
}
else {
if (newcv) SvREFCNT_inc_simple_void_NN(cv);
LEAVE;
+
+ if (CvCONST(cv)) {
+ /* Constant sub () { $x } closing over $x:
+ * The prototype was marked as a candiate for const-ization,
+ * so try to grab the current const value, and if successful,
+ * turn into a const sub:
+ */
+ SV* const_sv;
+ OP *o = CvSTART(cv);
+ assert(newcv);
+ for (; o; o = o->op_next)
+ if (o->op_type == OP_PADSV)
+ break;
+ ASSUME(o->op_type == OP_PADSV);
+ const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+ /* the candidate should have 1 ref from this pad and 1 ref
+ * from the parent */
+ if (const_sv && SvREFCNT(const_sv) == 2) {
+ const bool was_method = cBOOL(CvMETHOD(cv));
+ bool copied = FALSE;
+ if (outside) {
+ PADNAME * const pn =
+ PadlistNAMESARRAY(CvPADLIST(outside))
+ [PARENT_PAD_INDEX(PadlistNAMESARRAY(
+ CvPADLIST(cv))[o->op_targ])];
+ assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
+ [o->op_targ]));
+ if (PadnameLVALUE(pn)) {
+ /* We have a lexical that is potentially modifiable
+ elsewhere, so making a constant will break clo-
+ sure behaviour. If this is a ‘simple lexical
+ op tree’, i.e., sub(){$x}, emit a deprecation
+ warning, but continue to exhibit the old behav-
+ iour of making it a constant based on the ref-
+ count of the candidate variable.
+
+ A simple lexical op tree looks like this:
+
+ leavesub
+ lineseq
+ nextstate
+ padsv
+ */
+ if (OP_SIBLING(
+ cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
+ ) == o
+ && !OP_SIBLING(o))
+ {
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_DEPRECATED),
+ "Constants from lexical "
+ "variables potentially "
+ "modified elsewhere are "
+ "deprecated");
+ /* We *copy* the lexical variable, and donate the
+ copy to newCONSTSUB. Yes, this is ugly, and
+ should be killed. We need to do this for the
+ time being, however, because turning on SvPADTMP
+ on a lexical will have observable effects
+ elsewhere. */
+ const_sv = newSVsv(const_sv);
+ copied = TRUE;
+ }
+ else
+ goto constoff;
+ }
+ }
+ if (!copied)
+ SvREFCNT_inc_simple_void_NN(const_sv);
+ /* If the lexical is not used elsewhere, it is safe to turn on
+ SvPADTMP, since it is only when it is used in lvalue con-
+ text that the difference is observable. */
+ SvREADONLY_on(const_sv);
+ SvPADTMP_on(const_sv);
+ SvREFCNT_dec_NN(cv);
+ cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
+ if (was_method)
+ CvMETHOD_on(cv);
+ }
+ else {
+ constoff:
+ CvCONST_off(cv);
+ }
+ }
+
+ return cv;
}
static CV *
if (SvMAGIC(proto))
mg_copy((SV *)proto, (SV *)cv, 0, 0);
- if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
+ if (CvPADLIST(proto))
+ cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
cv_dump(cv, "To");
);
- if (CvCONST(cv)) {
- /* Constant sub () { $x } closing over $x - see lib/constant.pm:
- * The prototype was marked as a candiate for const-ization,
- * so try to grab the current const value, and if successful,
- * turn into a const sub:
- */
- SV* const const_sv = op_const_sv(CvSTART(cv), cv);
- if (const_sv) {
- 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. */
- cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
- }
- else {
- CvCONST_off(cv);
- }
- }
-
return cv;
}
}
/*
+=for apidoc cv_name
+
+Returns an SV containing the name of the CV, mainly for use in error
+reporting. The CV may actually be a GV instead, in which case the returned
+SV holds the GV's name. Anything other than a GV or CV is treated as a
+string already holding the sub name, but this could change in the future.
+
+An SV may be passed as a second argument. If so, the name will be assigned
+to it and it will be returned. Otherwise the returned SV will be a new
+mortal.
+
+If the I<flags> include CV_NAME_NOTQUAL, then the package name will not be
+included. If the first argument is neither a CV nor a GV, this flag is
+ignored (subject to change).
+
+=cut
+*/
+
+SV *
+Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags)
+{
+ PERL_ARGS_ASSERT_CV_NAME;
+ if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) {
+ if (sv) sv_setsv(sv,(SV *)cv);
+ return sv ? (sv) : (SV *)cv;
+ }
+ {
+ SV * const retsv = sv ? (sv) : sv_newmortal();
+ if (SvTYPE(cv) == SVt_PVCV) {
+ if (CvNAMED(cv)) {
+ if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
+ sv_sethek(retsv, CvNAME_HEK(cv));
+ else {
+ sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
+ sv_catpvs(retsv, "::");
+ sv_cathek(retsv, CvNAME_HEK(cv));
+ }
+ }
+ else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL)
+ sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv))));
+ else gv_efullname3(retsv, CvGV(cv), NULL);
+ }
+ else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv));
+ else gv_efullname3(retsv,(GV *)cv,NULL);
+ return retsv;
+ }
+}
+
+/*
=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
else
sv = newSV(0);
av_store(newpad, ix, sv);
- SvPADMY_on(sv);
}
}
- else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) {
+ else if (PadnamePV(names[ix])) {
av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix]));
}
else {
PERL_ARGS_ASSERT_PADLIST_DUP;
- if (!srcpad)
- return NULL;
-
cloneall = param->flags & CLONEf_COPY_STACKS
|| SvREFCNT(PadlistARRAY(srcpad)[1]) > 1;
assert (SvREFCNT(PadlistARRAY(srcpad)[1]) == 1);
else
sv = newSV(0);
pad1a[ix] = sv;
- SvPADMY_on(sv);
}
}
}
- else if (IS_PADGV(oldpad[ix])
- || ( names_fill >= ix && names[ix]
+ else if (( names_fill >= ix && names[ix]
&& PadnamePV(names[ix]) )) {
pad1a[ix] = sv_dup_inc(oldpad[ix], param);
}
/* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs
FIXTHAT before merging this branch.
(And I know how to) */
- if (SvPADMY(oldpad[ix]))
- SvPADMY_on(sv);
- else
+ if (SvPADTMP(oldpad[ix]))
SvPADTMP_on(sv);
}
}
https://perl5.git.perl.org / perl5.git / blobdiff