3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
4 * by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Perilous to us all are the devices of an art deeper than we possess
13 * ourselves." --Gandalf
18 #define PERL_IN_XSUTILS_C
22 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
25 /* package attributes; */
26 void XS_attributes__warn_reserved(pTHX_ CV *cv);
27 void XS_attributes_reftype(pTHX_ CV *cv);
28 void XS_attributes__modify_attrs(pTHX_ CV *cv);
29 void XS_attributes__guess_stash(pTHX_ CV *cv);
30 void XS_attributes__fetch_attrs(pTHX_ CV *cv);
31 void XS_attributes_bootstrap(pTHX_ CV *cv);
35 * Note that only ${pkg}::bootstrap definitions should go here.
36 * This helps keep down the start-up time, which is especially
37 * relevant for users who don't invoke any features which are
38 * (partially) implemented here.
40 * The various bootstrap definitions can take care of doing
41 * package-specific newXS() calls. Since the layout of the
42 * bundled *.pm files is in a version-specific directory,
43 * version checks in these bootstrap calls are optional.
47 Perl_boot_core_xsutils(pTHX)
49 const char file[] = __FILE__;
51 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
57 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
65 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
66 name = SvPV(attr, len);
67 if ((negated = (*name == '-'))) {
76 if (memEQ(name, "assertion", 9)) {
78 CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
80 CvFLAGS((CV*)sv) |= CVf_ASSERTION;
89 if (memEQ(name, "lvalue", 6)) {
91 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
93 CvFLAGS((CV*)sv) |= CVf_LVALUE;
98 #endif /* defined CVf_LVALUE */
99 if (memEQ(name, "locked", 6)) {
101 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
103 CvFLAGS((CV*)sv) |= CVf_LOCKED;
108 if (memEQ(name, "method", 6)) {
110 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
112 CvFLAGS((CV*)sv) |= CVf_METHOD;
125 if (memEQ(name, "share", 5)) {
127 Perl_croak(aTHX_ "A variable may not be unshared");
133 if (memEQ(name, "uniqu", 5)) {
134 if (SvTYPE(sv) == SVt_PVGV) {
140 /* Hope this came from toke.c if not a GV. */
147 /* anything recognized had a 'continue' above */
157 /* package attributes; */
159 XS(XS_attributes_bootstrap)
162 const char file[] = __FILE__;
166 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
168 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
169 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
170 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
171 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
172 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
177 XS(XS_attributes__modify_attrs)
186 "Usage: attributes::_modify_attrs $reference, @attributes");
190 if (!(SvOK(rv) && SvROK(rv)))
194 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
199 XS(XS_attributes__fetch_attrs)
209 "Usage: attributes::_fetch_attrs $reference");
214 if (!(SvOK(rv) && SvROK(rv)))
218 switch (SvTYPE(sv)) {
220 cvflags = CvFLAGS((CV*)sv);
221 if (cvflags & CVf_LOCKED)
222 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
224 if (cvflags & CVf_LVALUE)
225 XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
227 if (cvflags & CVf_METHOD)
228 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
229 if (GvUNIQUE(CvGV((CV*)sv)))
230 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
231 if (cvflags & CVf_ASSERTION)
232 XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
236 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
245 XS(XS_attributes__guess_stash)
255 "Usage: attributes::_guess_stash $reference");
260 if (!(SvOK(rv) && SvROK(rv)))
265 sv_setpv(TARG, HvNAME(SvSTASH(sv)));
266 #if 0 /* this was probably a bad idea */
267 else if (SvPADMY(sv))
268 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
271 const HV *stash = Nullhv;
272 switch (SvTYPE(sv)) {
274 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
275 stash = GvSTASH(CvGV(sv));
276 else if (/* !CvANON(sv) && */ CvSTASH(sv))
280 if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
284 if (GvGP(sv) && GvESTASH((GV*)sv))
285 stash = GvESTASH((GV*)sv);
291 sv_setpv(TARG, HvNAME(stash));
298 XS(XS_attributes_reftype)
308 "Usage: attributes::reftype $reference");
315 if (!(SvOK(rv) && SvROK(rv)))
318 sv_setpv(TARG, sv_reftype(sv, 0));
324 XS(XS_attributes__warn_reserved)
331 "Usage: attributes::_warn_reserved ()");
335 ST(0) = boolSV(ckWARN(WARN_RESERVED));