}
STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
{
dVAR;
- SV *stashsv;
+ SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
PERL_ARGS_ASSERT_APPLY_ATTRS;
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
- stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
#define ATTRSMODULE "attributes"
#define ATTRSMODULE_PM "attributes.pm"
- if (for_my) {
- /* Don't force the C<use> if we don't need it. */
- SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
- if (svp && *svp != &PL_sv_undef)
- NOOP; /* already in %INC */
- else
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs(ATTRSMODULE), NULL);
- }
- else {
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
newSVpvs(ATTRSMODULE),
NULL,
op_prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0,
newRV(target)),
dup_attrlist(attrs))));
- }
LEAVE;
}
{
dVAR;
OP *pack, *imop, *arg;
- SV *meth, *stashsv;
+ SV *meth, *stashsv, **svp;
PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
target->op_type == OP_PADAV);
/* Ensure that attributes.pm is loaded. */
- apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
+ ENTER; /* need to protect against side-effects of 'use' */
+ /* Don't force the C<use> if we don't need it. */
+ svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
+ if (svp && *svp != &PL_sv_undef)
+ NOOP; /* already in %INC */
+ else
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvs(ATTRSMODULE), NULL);
+ LEAVE;
/* Need package name for method call. */
pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
- attrs, FALSE);
+ attrs);
}
o->op_private |= OPpOUR_INTRO;
return o;
maybe other things) also take this path, because they set up
PL_main_start and PL_main_root directly, without generating an
optree.
+
+ If the parsing the main program aborts (due to parse errors,
+ or due to BEGIN or similar calling exit), then newPROG()
+ isn't even called, and hence this code path and its cleanups
+ are skipped. This shouldn't make a make a difference:
+ * a non-zero return from perl_parse is a failure, and
+ perl_destruct() should be called immediately.
+ * however, if exit(0) is called during the parse, then
+ perl_parse() returns 0, and perl_run() is called. As
+ PL_main_start will be NULL, perl_run() will return
+ promptly, and the exit code will remain 0.
*/
PL_comppad_name = 0;
PADNAME *name;
PADOFFSET pax = o->op_targ;
CV *outcv = CvOUTSIDE(PL_compcv);
+ CV *clonee = NULL;
HEK *hek = NULL;
+ bool reusable = FALSE;
PERL_ARGS_ASSERT_NEWMYSUB;
goto redo;
}
svspot =
- &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[1])[pax];
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
+ [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
spot = (CV **)svspot;
if (proto) {
goto done;
}
- if (PadnameIsSTATE(name))
+ if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = *spot;
+ svspot = (SV **)(spot = &clonee);
+ }
+ else if (PadnameIsSTATE(name) || CvDEPTH(outcv))
cv = *spot;
else {
MAGIC *mg;
+ SvUPGRADE(name, SVt_PVMG);
+ mg = mg_find(name, PERL_MAGIC_proto);
assert (SvTYPE(*spot) == SVt_PVCV);
- if (CvROOT(*spot)) {
- cv = *spot;
- *svspot = newSV_type(SVt_PVCV);
- SvPADMY_on(*spot);
- }
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
else {
)
);
}
- mg = mg_find(*svspot, PERL_MAGIC_proto);
if (mg) {
assert(mg->mg_obj);
cv = (CV *)mg->mg_obj;
}
else {
- sv_magic(*svspot, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
- mg = mg_find(*svspot, PERL_MAGIC_proto);
+ sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
+ mg = mg_find(name, PERL_MAGIC_proto);
}
spot = (CV **)(svspot = &mg->mg_obj);
}
cv = NULL;
}
}
+ else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = NULL;
+ reusable = TRUE;
+ }
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
- goto done;
+ goto clone;
}
/* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
determine whether this sub definition is in the same scope as its
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
- apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs, FALSE);
+ apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs);
}
if (block) {
}
}
+ clone:
+ if (clonee) {
+ assert(CvDEPTH(outcv));
+ spot = (CV **)
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
+ if (reusable) cv_clone_into(clonee, *spot);
+ else *spot = cv_clone(clonee);
+ SvREFCNT_dec(clonee);
+ cv = *spot;
+ SvPADMY_on(cv);
+ }
+ if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
+ PADOFFSET depth = CvDEPTH(outcv);
+ while (--depth) {
+ SV *oldcv;
+ svspot = &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[depth])[pax];
+ oldcv = *svspot;
+ *svspot = SvREFCNT_inc_simple_NN(cv);
+ SvREFCNT_dec(oldcv);
+ }
+ }
+
done:
if (PL_parser)
PL_parser->copline = NOLINE;
cv = PL_compcv;
if (name) {
GvCV_set(gv, cv);
- if (PL_madskills) {
- if (strEQ(name, "import")) {
- PL_formfeed = MUTABLE_SV(cv);
- /* diag_listed_as: SKIPME */
- Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
- }
- }
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
/* sub Foo::bar { (shift)+1 } */
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
- apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
+ apply_attrs(stash, MUTABLE_SV(cv), attrs);
}
if (block && has_name) {
case OP_PADCV: {
PADNAME *name = PAD_COMPNAME(rvop->op_targ);
CV *compcv = PL_compcv;
- SV *sv = PAD_SV(rvop->op_targ);
- while (SvTYPE(sv) != SVt_PVCV) {
- assert(PadnameOUTER(name));
+ PADOFFSET off = rvop->op_targ;
+ while (PadnameOUTER(name)) {
assert(PARENT_PAD_INDEX(name));
compcv = CvOUTSIDE(PL_compcv);
- sv = AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])
- [PARENT_PAD_INDEX(name)];
name = PadlistNAMESARRAY(CvPADLIST(compcv))
- [PARENT_PAD_INDEX(name)];
+ [off = PARENT_PAD_INDEX(name)];
}
- if (!PadnameIsOUR(name) && !PadnameIsSTATE(name)) {
- MAGIC * mg = mg_find(sv, PERL_MAGIC_proto);
+ assert(!PadnameIsOUR(name));
+ if (!PadnameIsSTATE(name)) {
+ MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
assert(mg);
assert(mg->mg_obj);
cv = (CV *)mg->mg_obj;
}
- else cv = (CV *)sv;
+ else cv =
+ (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
gv = NULL;
} break;
default: {