2 #define PERL_IN_XSUTILS_C
6 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
10 S_modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
18 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
19 name = SvPV(attr, len);
20 if (negated = (*name == '-')) {
31 if (strEQ(name, "lvalue")) {
33 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
35 CvFLAGS((CV*)sv) |= CVf_LVALUE;
38 #endif /* defined CVf_LVALUE */
39 if (strEQ(name, "locked")) {
41 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
43 CvFLAGS((CV*)sv) |= CVf_LOCKED;
48 if (strEQ(name, "method")) {
50 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
52 CvFLAGS((CV*)sv) |= CVf_METHOD;
64 /* anything recognized had a 'continue' above */
73 /* package attributes; */
74 void XS_attributes__warn_reserved(pTHXo_ CV *cv);
75 void XS_attributes_reftype(pTHXo_ CV *cv);
76 void XS_attributes__modify_attrs(pTHXo_ CV *cv);
77 void XS_attributes__guess_stash(pTHXo_ CV *cv);
78 void XS_attributes__fetch_attrs(pTHXo_ CV *cv);
79 void XS_attributes_bootstrap(pTHXo_ CV *cv);
83 * Note that only ${pkg}::bootstrap definitions should go here.
84 * This helps keep down the start-up time, which is especially
85 * relevant for users who don't invoke any features which are
86 * (partially) implemented here.
88 * The various bootstrap definitions can take care of doing
89 * package-specific newXS() calls. Since the layout of the
90 * bundled lib/*.pm files is in a version-specific directory,
91 * version checks in these bootstrap calls are optional.
95 Perl_boot_core_xsutils(pTHX)
97 char *file = __FILE__;
99 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
104 #endif /* PERL_OBJECT */
108 /* package attributes; */
110 XS(XS_attributes_bootstrap)
113 char *file = __FILE__;
115 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
116 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
117 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
118 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
119 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
124 XS(XS_attributes__modify_attrs)
132 "Usage: attributes::_modify_attrs $reference, @attributes");
136 if (!(SvOK(rv) && SvROK(rv)))
140 XSRETURN(modify_SV_attributes(sv, &ST(0), &ST(1), items-1));
145 XS(XS_attributes__fetch_attrs)
154 "Usage: attributes::_fetch_attrs $reference");
159 if (!(SvOK(rv) && SvROK(rv)))
163 switch (SvTYPE(sv)) {
165 cvflags = CvFLAGS((CV*)sv);
166 if (cvflags & CVf_LOCKED)
167 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
169 if (cvflags & CVf_LVALUE)
170 XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
172 if (cvflags & CVf_METHOD)
173 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
182 XS(XS_attributes__guess_stash)
189 SV * TARG = sv_newmortal();
195 "Usage: attributes::_guess_stash $reference");
200 if (!(SvOK(rv) && SvROK(rv)))
205 sv_setpv(TARG, HvNAME(SvSTASH(sv)));
206 #if 0 /* this was probably a bad idea */
207 else if (SvPADMY(sv))
208 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
212 switch (SvTYPE(sv)) {
214 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) &&
215 HvNAME(GvSTASH(CvGV(sv))))
216 stash = GvSTASH(CvGV(sv));
217 else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv)))
221 if (!(SvFAKE(sv) && SvTIED_mg(sv, '*')))
225 if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv)))
226 stash = GvESTASH((GV*)sv);
232 sv_setpv(TARG, HvNAME(stash));
241 XS(XS_attributes_reftype)
248 SV * TARG = sv_newmortal();
254 "Usage: attributes::reftype $reference");
266 sv_setpv(TARG, sv_reftype(sv, 0));
274 XS(XS_attributes__warn_reserved)
281 SV * TARG = sv_newmortal();
286 "Usage: attributes::_warn_reserved ()");
291 sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);