1 /* xsutils.c
2 *
3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
4 * by Larry Wall and others
5 *
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.
8 *
9 */
10
11 /*
12 * "Perilous to us all are the devices of an art deeper than we possess
13 * ourselves." --Gandalf
14 */
15
16
17 #include "EXTERN.h"
18 #define PERL_IN_XSUTILS_C
19 #include "perl.h"
20
21 /*
22 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
23 */
24
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);
32
33
34 /*
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.
39 *
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.
44 */
45
46 void
Perl_boot_core_xsutils(pTHX)47 Perl_boot_core_xsutils(pTHX)
48 {
49 char *file = __FILE__;
50
51 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
52 }
53
54 #include "XSUB.h"
55
56 static int
modify_SV_attributes(pTHX_ SV * sv,SV ** retlist,SV ** attrlist,int numattrs)57 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
58 {
59 SV *attr;
60 char *name;
61 STRLEN len;
62 bool negated;
63 int nret;
64
65 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
66 name = SvPV(attr, len);
67 if ((negated = (*name == '-'))) {
68 name++;
69 len--;
70 }
71 switch (SvTYPE(sv)) {
72 case SVt_PVCV:
73 switch ((int)len) {
74 case 6:
75 switch (*name) {
76 case 'l':
77 #ifdef CVf_LVALUE
78 if (strEQ(name, "lvalue")) {
79 if (negated)
80 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
81 else
82 CvFLAGS((CV*)sv) |= CVf_LVALUE;
83 continue;
84 }
85 #endif /* defined CVf_LVALUE */
86 if (strEQ(name, "locked")) {
87 if (negated)
88 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
89 else
90 CvFLAGS((CV*)sv) |= CVf_LOCKED;
91 continue;
92 }
93 break;
94 case 'm':
95 if (strEQ(name, "method")) {
96 if (negated)
97 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
98 else
99 CvFLAGS((CV*)sv) |= CVf_METHOD;
100 continue;
101 }
102 break;
103 }
104 break;
105 }
106 break;
107 default:
108 switch ((int)len) {
109 case 6:
110 switch (*name) {
111 case 's':
112 if (strEQ(name, "shared")) {
113 if (negated)
114 Perl_croak(aTHX_ "A variable may not be unshared");
115 SvSHARE(sv);
116 continue;
117 }
118 break;
119 case 'u':
120 if (strEQ(name, "unique")) {
121 if (SvTYPE(sv) == SVt_PVGV) {
122 if (negated)
123 GvUNIQUE_off(sv);
124 else
125 GvUNIQUE_on(sv);
126 }
127 /* Hope this came from toke.c if not a GV. */
128 continue;
129 }
130 }
131 }
132 break;
133 }
134 /* anything recognized had a 'continue' above */
135 *retlist++ = attr;
136 nret++;
137 }
138
139 return nret;
140 }
141
142
143
144 /* package attributes; */
145
XS(XS_attributes_bootstrap)146 XS(XS_attributes_bootstrap)
147 {
148 dXSARGS;
149 char *file = __FILE__;
150
151 if( items > 1 )
152 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
153
154 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
155 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
156 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
157 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
158 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
159
160 XSRETURN(0);
161 }
162
XS(XS_attributes__modify_attrs)163 XS(XS_attributes__modify_attrs)
164 {
165 dXSARGS;
166 SV *rv, *sv;
167
168 if (items < 1) {
169 usage:
170 Perl_croak(aTHX_
171 "Usage: attributes::_modify_attrs $reference, @attributes");
172 }
173
174 rv = ST(0);
175 if (!(SvOK(rv) && SvROK(rv)))
176 goto usage;
177 sv = SvRV(rv);
178 if (items > 1)
179 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
180
181 XSRETURN(0);
182 }
183
XS(XS_attributes__fetch_attrs)184 XS(XS_attributes__fetch_attrs)
185 {
186 dXSARGS;
187 SV *rv, *sv;
188 cv_flags_t cvflags;
189
190 if (items != 1) {
191 usage:
192 Perl_croak(aTHX_
193 "Usage: attributes::_fetch_attrs $reference");
194 }
195
196 rv = ST(0);
197 SP -= items;
198 if (!(SvOK(rv) && SvROK(rv)))
199 goto usage;
200 sv = SvRV(rv);
201
202 switch (SvTYPE(sv)) {
203 case SVt_PVCV:
204 cvflags = CvFLAGS((CV*)sv);
205 if (cvflags & CVf_LOCKED)
206 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
207 #ifdef CVf_LVALUE
208 if (cvflags & CVf_LVALUE)
209 XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
210 #endif
211 if (cvflags & CVf_METHOD)
212 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
213 if (GvUNIQUE(CvGV((CV*)sv)))
214 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
215 break;
216 case SVt_PVGV:
217 if (GvUNIQUE(sv))
218 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
219 break;
220 default:
221 break;
222 }
223
224 PUTBACK;
225 }
226
XS(XS_attributes__guess_stash)227 XS(XS_attributes__guess_stash)
228 {
229 dXSARGS;
230 SV *rv, *sv;
231 #ifdef dXSTARGET
232 dXSTARGET;
233 #else
234 SV * TARG = sv_newmortal();
235 #endif
236
237 if (items != 1) {
238 usage:
239 Perl_croak(aTHX_
240 "Usage: attributes::_guess_stash $reference");
241 }
242
243 rv = ST(0);
244 ST(0) = TARG;
245 if (!(SvOK(rv) && SvROK(rv)))
246 goto usage;
247 sv = SvRV(rv);
248
249 if (SvOBJECT(sv))
250 sv_setpv(TARG, HvNAME(SvSTASH(sv)));
251 #if 0 /* this was probably a bad idea */
252 else if (SvPADMY(sv))
253 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
254 #endif
255 else {
256 HV *stash = Nullhv;
257 switch (SvTYPE(sv)) {
258 case SVt_PVCV:
259 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
260 stash = GvSTASH(CvGV(sv));
261 else if (/* !CvANON(sv) && */ CvSTASH(sv))
262 stash = CvSTASH(sv);
263 break;
264 case SVt_PVMG:
265 if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
266 break;
267 /*FALLTHROUGH*/
268 case SVt_PVGV:
269 if (GvGP(sv) && GvESTASH((GV*)sv))
270 stash = GvESTASH((GV*)sv);
271 break;
272 default:
273 break;
274 }
275 if (stash)
276 sv_setpv(TARG, HvNAME(stash));
277 }
278
279 #ifdef dXSTARGET
280 SvSETMAGIC(TARG);
281 #endif
282 XSRETURN(1);
283 }
284
XS(XS_attributes_reftype)285 XS(XS_attributes_reftype)
286 {
287 dXSARGS;
288 SV *rv, *sv;
289 #ifdef dXSTARGET
290 dXSTARGET;
291 #else
292 SV * TARG = sv_newmortal();
293 #endif
294
295 if (items != 1) {
296 usage:
297 Perl_croak(aTHX_
298 "Usage: attributes::reftype $reference");
299 }
300
301 rv = ST(0);
302 ST(0) = TARG;
303 if (SvGMAGICAL(rv))
304 mg_get(rv);
305 if (!(SvOK(rv) && SvROK(rv)))
306 goto usage;
307 sv = SvRV(rv);
308 sv_setpv(TARG, sv_reftype(sv, 0));
309 #ifdef dXSTARGET
310 SvSETMAGIC(TARG);
311 #endif
312
313 XSRETURN(1);
314 }
315
XS(XS_attributes__warn_reserved)316 XS(XS_attributes__warn_reserved)
317 {
318 dXSARGS;
319 #ifdef dXSTARGET
320 dXSTARGET;
321 #else
322 SV * TARG = sv_newmortal();
323 #endif
324
325 if (items != 0) {
326 Perl_croak(aTHX_
327 "Usage: attributes::_warn_reserved ()");
328 }
329
330 EXTEND(SP,1);
331 ST(0) = TARG;
332 sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
333 #ifdef dXSTARGET
334 SvSETMAGIC(TARG);
335 #endif
336
337 XSRETURN(1);
338 }
339
340