}
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;
dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
+ OP *o;
CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
- pad_leavemy();
+ o = pad_leavemy();
+
+ if (o) {
+ /* pad_leavemy has created a sequence of introcv ops for all my
+ subs declared in the block. We have to replicate that list with
+ clonecv ops, to deal with this situation:
+
+ sub {
+ my sub s1;
+ my sub s2;
+ sub s1 { state sub foo { \&s2 } }
+ }->()
+
+ Originally, I was going to have introcv clone the CV and turn
+ off the stale flag. Since &s1 is declared before &s2, the
+ introcv op for &s1 is executed (on sub entry) before the one for
+ &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
+ cloned, since it is a state sub) closes over &s2 and expects
+ to see it in its outer CV’s pad. If the introcv op clones &s1,
+ then &s2 is still marked stale. Since &s1 is not active, and
+ &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
+ ble will not stay shared’ warning. Because it is the same stub
+ that will be used when the introcv op for &s2 is executed, clos-
+ ing over it is safe. Hence, we have to turn off the stale flag
+ on all lexical subs in the block before we clone any of them.
+ Hence, having introcv clone the sub cannot work. So we create a
+ list of ops like this:
+
+ lineseq
+ |
+ +-- introcv
+ |
+ +-- introcv
+ |
+ +-- introcv
+ |
+ .
+ .
+ .
+ |
+ +-- clonecv
+ |
+ +-- clonecv
+ |
+ +-- clonecv
+ |
+ .
+ .
+ .
+ */
+ OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
+ OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
+ for (;; kid = kid->op_sibling) {
+ OP *newkid = newOP(OP_CLONECV, 0);
+ newkid->op_targ = kid->op_targ;
+ o = op_append_elem(OP_LINESEQ, o, newkid);
+ if (kid == last) break;
+ }
+ retval = op_prepend_elem(OP_LINESEQ, o, retval);
+ }
CALL_BLOCK_HOOKS(bhk_post_end, &retval);
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;
register CV *compcv = PL_compcv;
SV *const_sv;
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;
- /* PL_comppad is the pad owned by the new sub. Popping scope will make
- the PL_comppad point to the pad belonging to the enclosing sub,
- where we store the new one. */
- LEAVE_SCOPE(floor);
-
- name = PadnamelistARRAY(PL_comppad_name)[o->op_targ];
- if (!PadnameIsSTATE(name))
- Perl_croak(aTHX_ "\"my sub\" not yet implemented");
- svspot = &PL_curpad[o->op_targ];
+ /* Find the pad slot for storing the new sub.
+ We cannot use PL_comppad, as it is the pad owned by the new sub. We
+ need to look in CvOUTSIDE and find the pad belonging to the enclos-
+ ing sub. And then we need to dig deeper if this is a lexical from
+ outside, as in:
+ my sub foo; sub { sub foo { } }
+ */
+ redo:
+ name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
+ if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
+ pax = PARENT_PAD_INDEX(name);
+ outcv = CvOUTSIDE(outcv);
+ assert(outcv);
+ goto redo;
+ }
+ svspot =
+ &PadARRAY(PadlistARRAY(CvPADLIST(outcv))
+ [CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
spot = (CV **)svspot;
if (proto) {
ps = NULL;
if (!PL_madskills) {
- if (o)
- SAVEFREEOP(o);
if (proto)
SAVEFREEOP(proto);
if (attrs)
goto done;
}
- if (SvTYPE(*spot) != SVt_PVCV) { /* Maybe prototype now, and had at
- maximum a prototype before. */
-#if 0
- if (SvTYPE(*spot) > SVt_NULL) {
- cv_ckproto_len_flags(*spot, NULL, ps, ps_len, ps_utf8);
- }
- if (!block && !attrs && !(CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
- && !PL_madskills) {
- if (ps) {
- sv_setpvn(*svspot, ps, ps_len);
- if ( ps_utf8 ) SvUTF8_on(*svspot);
- }
- else
- sv_setiv(*svspot, -1);
-
- SvREFCNT_dec(compcv);
- cv = compcv = NULL;
- goto done;
+ 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 (CvNAMED(*spot))
+ hek = CvNAME_HEK(*spot);
+ else {
+ CvNAME_HEK_set(*spot, hek =
+ share_hek(
+ PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ )
+ );
}
-#endif
- SvREFCNT_dec(*spot);
- *spot = NULL;
+ if (mg) {
+ assert(mg->mg_obj);
+ cv = (CV *)mg->mg_obj;
+ }
+ else {
+ 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 = *spot;
-
if (!block || !ps || *ps || attrs
|| (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
#ifdef PERL_MAD
* skipping the prototype check
*/
if (exists || SvPOK(cv))
- cv_ckproto_len_flags(cv, (GV *)namesv, ps, ps_len, ps_utf8);
+ cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
/* already defined? */
if (exists) {
if ((!block
goto done;
}
else {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE)
+ /* redundant check that avoids creating the extra SV
+ most of the time: */
+ if (const_sv || ckWARN(WARN_REDEFINE)) {
+ const line_t oldline = CopLINE(PL_curcop);
+ SV *noamp = sv_2mortal(newSVpvn_utf8(
+ PadnamePV(name)+1,PadnameLEN(name)-1,
+ PadnameUTF8(name)
+ ));
+ if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
- report_redefined_cv(name, cv, &const_sv);
- CopLINE_set(PL_curcop, oldline);
+ report_redefined_cv(noamp, cv, &const_sv);
+ CopLINE_set(PL_curcop, oldline);
+ }
#ifdef PERL_MAD
if (!PL_minus_c) /* keep old one around for madskills */
#endif
cv = NULL;
}
}
+ else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
+ cv = NULL;
+ reusable = TRUE;
+ }
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
goto install_block;
op_free(block);
SvREFCNT_dec(compcv);
- goto done;
+ PL_compcv = NULL;
+ goto clone;
+ }
+ /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
+ determine whether this sub definition is in the same scope as its
+ declaration. If this sub definition is inside an inner named pack-
+ age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
+ the package sub. So check PadnameOUTER(name) too.
+ */
+ if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) {
+ assert(!CvWEAKOUTSIDE(compcv));
+ SvREFCNT_dec(CvOUTSIDE(compcv));
+ CvWEAKOUTSIDE_on(compcv);
}
- SvREFCNT_dec(CvOUTSIDE(compcv));
- CvWEAKOUTSIDE_on(compcv);
+ /* XXX else do we have a circular reference? */
if (cv) { /* must reuse cv in case stub is referenced elsewhere */
/* transfer PL_compcv to cv */
if (block
&& block->op_type != OP_NULL
#endif
) {
- cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
+ cv_flags_t preserved_flags =
+ CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
PADLIST *const temp_padl = CvPADLIST(cv);
CV *const temp_cv = CvOUTSIDE(cv);
- const cv_flags_t slabbed = CvSLABBED(cv);
+ const cv_flags_t other_flags =
+ CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
OP * const cvstart = CvSTART(cv);
- assert(CvWEAKOUTSIDE(cv));
- assert(CvNAMED(cv));
- assert(CvNAME_HEK(cv));
-
SvPOK_off(cv);
CvFLAGS(cv) =
- CvFLAGS(compcv) | existing_builtin_attrs | CVf_NAMED;
+ CvFLAGS(compcv) | preserved_flags;
CvOUTSIDE(cv) = CvOUTSIDE(compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
CvPADLIST(cv) = CvPADLIST(compcv);
CvPADLIST(compcv) = temp_padl;
CvSTART(cv) = CvSTART(compcv);
CvSTART(compcv) = cvstart;
- if (slabbed) CvSLABBED_on(compcv);
- else CvSLABBED_off(compcv);
+ CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+ CvFLAGS(compcv) |= other_flags;
if (CvFILE(cv) && CvDYNFILE(cv)) {
Safefree(CvFILE(cv));
}
/* ... before we throw it away */
SvREFCNT_dec(compcv);
- compcv = cv;
+ PL_compcv = compcv = cv;
}
else {
cv = compcv;
*spot = cv;
- SvANY(cv)->xcv_gv_u.xcv_hek =
- share_hek(SvPVX(namesv)+1,
- SvCUR(namesv)-1 * (SvUTF8(namesv) ? -1 : 1), 0);
- CvNAMED_on(cv);
+ }
+ if (!CvNAME_HEK(cv)) {
+ CvNAME_HEK_set(cv,
+ hek
+ ? share_hek_hek(hek)
+ : share_hek(PadnamePV(name)+1,
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
+ 0)
+ );
}
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
/* now that optimizer has done its work, adjust pad values */
- ENTER;
- SAVESPTR(PL_compcv);
- SAVECOMPPAD();
- PL_compcv = cv;
- PL_comppad = *PadlistARRAY(CvPADLIST(cv));
- PL_curpad = PadARRAY(PL_comppad);
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- LEAVE;
if (CvCLONE(cv)) {
assert(!CvCONST(cv));
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) {
sv_catpvs(tmpstr, "::");
}
else sv_setpvs(tmpstr, "__ANON__::");
- sv_catpvn_flags(tmpstr, SvPVX(namesv)+1, SvCUR(namesv)-1,
- SvUTF8(namesv) ? SV_CATUTF8 : SV_CATBYTES);
+ sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
+ PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
}
}
+ 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;
+ LEAVE_SCOPE(floor);
+ if (o) op_free(o);
return cv;
}
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) {
if (o->op_type == OP_PADANY) {
o->op_type = OP_PADCV;
o->op_ppaddr = PL_ppaddr[OP_PADCV];
+ return o;
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
cv = (CV*)SvRV(rv);
gv = NULL;
} break;
+ case OP_PADCV: {
+ PADNAME *name = PAD_COMPNAME(rvop->op_targ);
+ CV *compcv = PL_compcv;
+ PADOFFSET off = rvop->op_targ;
+ while (PadnameOUTER(name)) {
+ assert(PARENT_PAD_INDEX(name));
+ compcv = CvOUTSIDE(PL_compcv);
+ name = PadlistNAMESARRAY(CvPADLIST(compcv))
+ [off = PARENT_PAD_INDEX(name)];
+ }
+ 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 *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+ gv = NULL;
+ } break;
default: {
return NULL;
} break;
Perl_call_checker ckfun;
SV *ckobj;
cv_get_call_checker(cv, &ckfun, &ckobj);
+ if (!namegv) { /* expletive! */
+ /* XXX The call checker API is public. And it guarantees that
+ a GV will be provided with the right name. So we have
+ to create a GV. But it is still not correct, as its
+ stringification will include the package. What we
+ really need is a new call checker API that accepts a
+ GV or string (or GV or CV). */
+ HEK * const hek = CvNAME_HEK(cv);
+ assert(hek);
+ namegv = (GV *)sv_newmortal();
+ gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
+ SVf_UTF8 * !!HEK_UTF8(hek));
+ }
return ckfun(aTHX_ o, namegv, ckobj);
}
}
https://perl5.git.perl.org / perl5.git / blobdiff