void
Perl_cv_undef(pTHX_ CV *cv)
{
+ PERL_ARGS_ASSERT_CV_UNDEF;
+ cv_undef_flags(cv, 0);
+}
+
+void
+Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags)
+{
const PADLIST *padlist = CvPADLIST(cv);
bool const slabbed = !!CvSLABBED(cv);
- PERL_ARGS_ASSERT_CV_UNDEF;
+ PERL_ARGS_ASSERT_CV_UNDEF_FLAGS;
DEBUG_X(PerlIO_printf(Perl_debug_log,
"CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
#endif
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(cv)) {
+ CvNAME_HEK_set(cv, NULL);
+ CvNAMED_off(cv);
+ }
+ else CvGV_set(cv, NULL);
+ }
/* This statement and the subsequence if block was pad_undef(). */
pad_peg("pad_undef");
CvXSUB(cv) = NULL;
}
/* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
- * ref status of CvOUTSIDE and CvGV, and ANON and
- * LEXICAL, which pp_entersub uses
- * to choose an error message */
- CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL);
+ * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and
+ * LEXICAL, which are used to determine the sub's name. */
+ CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL
+ |CVf_NAMED);
}
/*
#else
(SVs_PADMY|SVs_PADTMP)
#endif
- ) &&
- !IS_PADGV(sv))
+ ))
break;
}
if (konst) {
* 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.
}
}
}
- else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) {
+ else if (namesv && PadnamePV(namesv)) {
sv = SvREFCNT_inc_NN(ppad[ix]);
}
else {
return S_cv_clone(aTHX_ proto, target, NULL);
}
+/*
+=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.
+
+=cut
+*/
+
SV *
Perl_cv_name(pTHX_ CV *cv, SV *sv)
{
return sv ? (sv) : (SV *)cv;
}
{
- SV * const retsv = sv ? sv : sv_newmortal();
+ SV * const retsv = sv ? (sv) : sv_newmortal();
if (SvTYPE(cv) == SVt_PVCV) {
if (CvNAMED(cv)) {
if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv));
else {
sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv)));
sv_catpvs(retsv, "::");
- sv_catpvn_flags(retsv, HEK_KEY(CvNAME_HEK(cv)),
- HEK_LEN(CvNAME_HEK(cv)),
- HEK_UTF8(CvNAME_HEK(cv))
- ? SV_CATUTF8
- : SV_CATBYTES);
+ sv_cathek(retsv, CvNAME_HEK(cv));
}
}
else if (CvLEXICAL(cv))
else if (sigil == '%')
sv = MUTABLE_SV(newHV());
else
+ {
sv = newSV(0);
+ /* For flip-flop targets: */
+ if (SvPADTMP(oldpad[ix])) SvPADTMP_on(sv);
+ }
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 {
}
}
}
- 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);
}