3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
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 PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv);
27 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
28 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
29 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
30 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
31 PERL_XS_EXPORT_C 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)
63 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
65 const char *name = SvPV_const(attr, len);
66 const bool negated = (*name == '-');
77 if (memEQ(name, "assertion", 9)) {
79 CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
81 CvFLAGS((CV*)sv) |= CVf_ASSERTION;
90 if (memEQ(name, "lvalue", 6)) {
92 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
94 CvFLAGS((CV*)sv) |= CVf_LVALUE;
99 #endif /* defined CVf_LVALUE */
100 if (memEQ(name, "locked", 6)) {
102 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
104 CvFLAGS((CV*)sv) |= CVf_LOCKED;
109 if (memEQ(name, "method", 6)) {
111 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
113 CvFLAGS((CV*)sv) |= CVf_METHOD;
126 if (memEQ(name, "share", 5)) {
128 Perl_croak(aTHX_ "A variable may not be unshared");
134 if (memEQ(name, "uniqu", 5)) {
135 if (SvTYPE(sv) == SVt_PVGV) {
142 /* Hope this came from toke.c if not a GV. */
149 /* anything recognized had a 'continue' above */
159 /* package attributes; */
161 XS(XS_attributes_bootstrap)
165 const char file[] = __FILE__;
168 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
170 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
171 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
172 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
173 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
174 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
179 XS(XS_attributes__modify_attrs)
188 "Usage: attributes::_modify_attrs $reference, @attributes");
192 if (!(SvOK(rv) && SvROK(rv)))
196 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
201 XS(XS_attributes__fetch_attrs)
211 "Usage: attributes::_fetch_attrs $reference");
216 if (!(SvOK(rv) && SvROK(rv)))
220 switch (SvTYPE(sv)) {
222 cvflags = CvFLAGS((CV*)sv);
223 if (cvflags & CVf_LOCKED)
224 XPUSHs(sv_2mortal(newSVpvs("locked")));
226 if (cvflags & CVf_LVALUE)
227 XPUSHs(sv_2mortal(newSVpvs("lvalue")));
229 if (cvflags & CVf_METHOD)
230 XPUSHs(sv_2mortal(newSVpvs("method")));
231 if (GvUNIQUE(CvGV((CV*)sv)))
232 XPUSHs(sv_2mortal(newSVpvs("unique")));
233 if (cvflags & CVf_ASSERTION)
234 XPUSHs(sv_2mortal(newSVpvs("assertion")));
238 XPUSHs(sv_2mortal(newSVpvs("unique")));
247 XS(XS_attributes__guess_stash)
257 "Usage: attributes::_guess_stash $reference");
262 if (!(SvOK(rv) && SvROK(rv)))
267 sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
268 #if 0 /* this was probably a bad idea */
269 else if (SvPADMY(sv))
270 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
273 const HV *stash = NULL;
274 switch (SvTYPE(sv)) {
276 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
277 stash = GvSTASH(CvGV(sv));
278 else if (/* !CvANON(sv) && */ CvSTASH(sv))
282 if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
286 if (GvGP(sv) && GvESTASH((GV*)sv))
287 stash = GvESTASH((GV*)sv);
293 sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
300 XS(XS_attributes_reftype)
310 "Usage: attributes::reftype $reference");
316 if (!(SvOK(rv) && SvROK(rv)))
319 sv_setpv(TARG, sv_reftype(sv, 0));
325 XS(XS_attributes__warn_reserved)
332 "Usage: attributes::_warn_reserved ()");
336 ST(0) = boolSV(ckWARN(WARN_RESERVED));
343 * c-indentation-style: bsd
345 * indent-tabs-mode: t
348 * ex: set ts=8 sts=4 sw=4 noet: