sub : attrlist

To: Mailing list Perl5 <perl5-porters@perl.org>
Message-Id: <199908290702.DAA32191@Orb.Nashua.NH.US>

p4raw-id: //depot/cfgperl@4043

1 files changed, 160 insertions, 10 deletions

diff --git a/op.c b/op.c
index e99ef60bc8..42ed8b201e 100644
--- a/op.c
+++ b/op.c
@@ -1576,8 +1576,60 @@ Perl_ref(pTHX_ OP *o, I32 type)
 
 }
 
-OP *
-Perl_my(pTHX_ OP *o)
+STATIC OP *
+S_dup_attrlist(pTHX_ OP *o)
+{
+    OP *rop = Nullop;
+
+    /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
+     * where the first kid is OP_PUSHMARK and the remaining ones
+     * are OP_CONST.  We need to push the OP_CONST values.
+     */
+    if (o->op_type == OP_CONST)
+	rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
+    else {
+	assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
+	for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
+	    if (o->op_type == OP_CONST)
+		rop = append_elem(OP_LIST, rop,
+				  newSVOP(OP_CONST, o->op_flags,
+					  SvREFCNT_inc(cSVOPo->op_sv)));
+	}
+    }
+    return rop;
+}
+
+STATIC void
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
+{
+    OP *modname;	/* for 'use' */
+    SV *stashsv;
+
+    /* fake up C<use attributes $pkg,$rv,@attrs> */
+    ENTER;		/* need to protect against side-effects of 'use' */
+    SAVEINT(PL_expect);
+    if (stash && HvNAME(stash))
+	stashsv = newSVpv(HvNAME(stash), 0);
+    else
+	stashsv = &PL_sv_no;
+#define ATTRSMODULE "attributes"
+    modname = newSVOP(OP_CONST, 0,
+		      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
+    modname->op_private |= OPpCONST_BARE;
+    /* that flag is required to make 'use' work right */
+    utilize(1, start_subparse(FALSE, 0),
+	    Nullop, /* version */
+	    modname,
+	    prepend_elem(OP_LIST,
+			 newSVOP(OP_CONST, 0, stashsv),
+			 prepend_elem(OP_LIST,
+				      newSVOP(OP_CONST, 0, newRV(target)),
+				      dup_attrlist(attrs))));
+    LEAVE;
+}
+
+STATIC OP *
+S_my_kid(pTHX_ OP *o, OP *attrs)
 {
     OP *kid;
     I32 type;
@@ -1588,7 +1640,7 @@ Perl_my(pTHX_ OP *o)
     type = o->op_type;
     if (type == OP_LIST) {
 	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
-	    my(kid);
+	    my_kid(kid, attrs);
     } else if (type == OP_UNDEF) {
 	return o;
     } else if (type != OP_PADSV &&
@@ -1599,12 +1651,44 @@ Perl_my(pTHX_ OP *o)
 	yyerror(Perl_form(aTHX_ "Can't declare %s in my", PL_op_desc[o->op_type]));
 	return o;
     }
+    else if (attrs && type != OP_PUSHMARK) {
+	HV *stash;
+	SV *padsv;
+	SV **namesvp;
+
+	/* check for C<my Dog $spot> when deciding package */
+	namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
+	if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
+	    stash = SvSTASH(*namesvp);
+	else
+	    stash = PL_curstash;
+	padsv = PAD_SV(o->op_targ);
+	apply_attrs(stash, padsv, attrs);
+    }
     o->op_flags |= OPf_MOD;
     o->op_private |= OPpLVAL_INTRO;
     return o;
 }
 
 OP *
+Perl_my_attrs(pTHX_ OP *o, OP *attrs)
+{
+    if (o->op_flags & OPf_PARENS)
+	list(o);
+    PL_in_my = FALSE;
+    PL_in_my_stash = Nullhv;
+    if (attrs)
+	SAVEFREEOP(attrs);
+    return my_kid(o, attrs);
+}
+
+OP *
+Perl_my(pTHX_ OP *o)
+{
+    return my_kid(o, Nullop);
+}
+
+OP *
 Perl_sawparens(pTHX_ OP *o)
 {
     if (o)
@@ -2807,9 +2891,10 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
     }
 
     /* Fake up the BEGIN {}, which does its thing immediately. */
-    newSUB(floor,
+    newATTRSUB(floor,
 	newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
 	Nullop,
+	Nullop,
 	append_elem(OP_LINESEQ,
 	    append_elem(OP_LINESEQ,
 	        newSTATEOP(0, Nullch, rqop),
@@ -3896,14 +3981,35 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
     return sv;
 }
 
+void
+Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+{
+    if (o)
+	SAVEFREEOP(o);
+    if (proto)
+	SAVEFREEOP(proto);
+    if (attrs)
+	SAVEFREEOP(attrs);
+    if (block)
+	SAVEFREEOP(block);
+    Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+}
+
 CV *
 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
 {
+    return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
+}
+
+CV *
+Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
+{
     dTHR;
     STRLEN n_a;
     char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
     GV *gv = gv_fetchpv(name ? name : "__ANON__",
-			GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV);
+			GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+			SVt_PVCV);
     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
     register CV *cv=0;
     I32 ix;
@@ -3912,8 +4018,10 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
 	SAVEFREEOP(o);
     if (proto)
 	SAVEFREEOP(proto);
+    if (attrs)
+	SAVEFREEOP(attrs);
 
-    if (SvTYPE(gv) != SVt_PVGV) {	/* Prototype now, and had
+    if (SvTYPE(gv) != SVt_PVGV) {	/* Maybe prototype now, and had at
 					   maximum a prototype before. */
 	if (SvTYPE(gv) > SVt_NULL) {
 	    if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
@@ -3941,7 +4049,7 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
 	if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
 	    SV* const_sv;
 	    bool const_changed = TRUE;
-	    if (!block) {
+	    if (!block && !attrs) {
 		/* just a "sub foo;" when &foo is already defined */
 		SAVEFREESV(PL_compcv);
 		goto done;
@@ -3949,6 +4057,8 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
 	    /* ahem, death to those who redefine active sort subs */
 	    if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
 		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
+	    if (!block)
+		goto withattrs;
 	    if(const_sv = cv_const_sv(cv))
 		const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
 	    if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE) 
@@ -3960,14 +4070,46 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
 		PL_curcop->cop_line = PL_copline;
 		Perl_warner(aTHX_ WARN_REDEFINE,
 			const_sv ? "Constant subroutine %s redefined"
-		                 : "Subroutine %s redefined", name);
+				 : "Subroutine %s redefined", name);
 		PL_curcop->cop_line = oldline;
 	    }
 	    SvREFCNT_dec(cv);
 	    cv = Nullcv;
 	}
     }
+  withattrs:
+    if (attrs) {
+	HV *stash;
+	SV *rcv;
+
+	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
+	 * before we clobber PL_compcv.
+	 */
+	if (cv && !block) {
+	    rcv = (SV*)cv;
+	    if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
+		stash = GvSTASH(CvGV(cv));
+	    else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
+		stash = CvSTASH(cv);
+	    else
+		stash = PL_curstash;
+	}
+	else {
+	    /* possibly about to re-define existing subr -- ignore old cv */
+	    rcv = (SV*)PL_compcv;
+	    if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
+		stash = GvSTASH(gv);
+	    else
+		stash = PL_curstash;
+	}
+	apply_attrs(stash, rcv, attrs);
+    }
     if (cv) {				/* must reuse cv if autoloaded */
+	if (!block) {
+	    /* got here with just attrs -- work done, so bug out */
+	    SAVEFREESV(PL_compcv);
+	    goto done;
+	}
 	cv_undef(cv);
 	CvFLAGS(cv) = CvFLAGS(PL_compcv);
 	CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
@@ -4155,10 +4297,11 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
     if(stash)
 	PL_curstash = PL_curcop->cop_stash = stash;
 
-    newSUB(
+    newATTRSUB(
 	start_subparse(FALSE, 0),
 	newSVOP(OP_CONST, 0, newSVpv(name,0)),
 	newSVOP(OP_CONST, 0, &PL_sv_no),	/* SvPV(&PL_sv_no) == "" -- GMB */
+	Nullop,
 	newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
     );
 
@@ -4311,8 +4454,15 @@ Perl_newANONHASH(pTHX_ OP *o)
 OP *
 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
 {
+    return newANONATTRSUB(floor, proto, Nullop, block);
+}
+
+OP *
+Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
+{
     return newUNOP(OP_REFGEN, 0,
-	newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block)));
+	newSVOP(OP_ANONCODE, 0,
+		(SV*)newATTRSUB(floor, 0, proto, attrs, block)));
 }
 
 OP *