Missing argument.
[p5sagit/p5-mst-13.2.git] / xsutils.c
CommitLineData
09bef843 1#include "EXTERN.h"
2#define PERL_IN_XSUTILS_C
3#include "perl.h"
4
5/*
6 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
7 */
8
349fd7b7 9/* package attributes; */
acfe0abc 10void XS_attributes__warn_reserved(pTHX_ CV *cv);
11void XS_attributes_reftype(pTHX_ CV *cv);
12void XS_attributes__modify_attrs(pTHX_ CV *cv);
13void XS_attributes__guess_stash(pTHX_ CV *cv);
14void XS_attributes__fetch_attrs(pTHX_ CV *cv);
15void XS_attributes_bootstrap(pTHX_ CV *cv);
349fd7b7 16
17
18/*
19 * Note that only ${pkg}::bootstrap definitions should go here.
20 * This helps keep down the start-up time, which is especially
21 * relevant for users who don't invoke any features which are
22 * (partially) implemented here.
23 *
24 * The various bootstrap definitions can take care of doing
25 * package-specific newXS() calls. Since the layout of the
6a34af38 26 * bundled *.pm files is in a version-specific directory,
349fd7b7 27 * version checks in these bootstrap calls are optional.
28 */
29
30void
31Perl_boot_core_xsutils(pTHX)
32{
33 char *file = __FILE__;
34
35 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
36}
37
349fd7b7 38#include "XSUB.h"
39
40static int
acfe0abc 41modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
09bef843 42{
43 SV *attr;
44 char *name;
45 STRLEN len;
46 bool negated;
47 int nret;
48
49 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
50 name = SvPV(attr, len);
155aba94 51 if ((negated = (*name == '-'))) {
09bef843 52 name++;
53 len--;
54 }
55 switch (SvTYPE(sv)) {
56 case SVt_PVCV:
57 switch ((int)len) {
58 case 6:
59 switch (*name) {
60 case 'l':
61#ifdef CVf_LVALUE
62 if (strEQ(name, "lvalue")) {
63 if (negated)
64 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
65 else
66 CvFLAGS((CV*)sv) |= CVf_LVALUE;
67 continue;
68 }
69#endif /* defined CVf_LVALUE */
70 if (strEQ(name, "locked")) {
71 if (negated)
72 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
73 else
74 CvFLAGS((CV*)sv) |= CVf_LOCKED;
75 continue;
76 }
77 break;
78 case 'm':
79 if (strEQ(name, "method")) {
80 if (negated)
81 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
82 else
83 CvFLAGS((CV*)sv) |= CVf_METHOD;
84 continue;
85 }
86 break;
95f0a2f1 87 case 'u':
88 if (strEQ(name, "unique")) {
0256094b 89 if (negated)
7fb37951 90 GvUNIQUE_off(CvGV((CV*)sv));
0256094b 91 else
7fb37951 92 GvUNIQUE_on(CvGV((CV*)sv));
0256094b 93 continue;
94 }
95 break;
09bef843 96 }
97 break;
98 }
99 break;
100 default:
0256094b 101 switch ((int)len) {
95f0a2f1 102 case 6:
0256094b 103 switch (*name) {
95f0a2f1 104 case 'u':
105 if (strEQ(name, "unique")) {
106 if (SvTYPE(sv) == SVt_PVGV) {
107 if (negated)
108 GvUNIQUE_off(sv);
109 else
110 GvUNIQUE_on(sv);
111 }
112 /* Hope this came from toke.c if not a GV. */
0256094b 113 continue;
114 }
115 }
116 }
09bef843 117 break;
118 }
119 /* anything recognized had a 'continue' above */
120 *retlist++ = attr;
121 nret++;
122 }
123
124 return nret;
125}
126
127
09bef843 128
129/* package attributes; */
130
131XS(XS_attributes_bootstrap)
132{
133 dXSARGS;
134 char *file = __FILE__;
135
592f5969 136 if( items > 1 )
137 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
b7953727 138
09bef843 139 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
140 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
141 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
142 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
143 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
144
145 XSRETURN(0);
146}
147
148XS(XS_attributes__modify_attrs)
149{
150 dXSARGS;
151 SV *rv, *sv;
152
153 if (items < 1) {
154usage:
155 Perl_croak(aTHX_
156 "Usage: attributes::_modify_attrs $reference, @attributes");
157 }
158
159 rv = ST(0);
160 if (!(SvOK(rv) && SvROK(rv)))
161 goto usage;
162 sv = SvRV(rv);
163 if (items > 1)
acfe0abc 164 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843 165
166 XSRETURN(0);
167}
168
169XS(XS_attributes__fetch_attrs)
170{
171 dXSARGS;
172 SV *rv, *sv;
173 cv_flags_t cvflags;
174
175 if (items != 1) {
176usage:
177 Perl_croak(aTHX_
178 "Usage: attributes::_fetch_attrs $reference");
179 }
180
181 rv = ST(0);
182 SP -= items;
183 if (!(SvOK(rv) && SvROK(rv)))
184 goto usage;
185 sv = SvRV(rv);
186
187 switch (SvTYPE(sv)) {
188 case SVt_PVCV:
189 cvflags = CvFLAGS((CV*)sv);
190 if (cvflags & CVf_LOCKED)
191 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
192#ifdef CVf_LVALUE
193 if (cvflags & CVf_LVALUE)
194 XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
195#endif
196 if (cvflags & CVf_METHOD)
197 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
7fb37951 198 if (GvUNIQUE(CvGV((CV*)sv)))
95f0a2f1 199 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
200 break;
201 case SVt_PVGV:
202 if (GvUNIQUE(sv))
203 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
09bef843 204 break;
205 default:
206 break;
207 }
208
209 PUTBACK;
210}
211
212XS(XS_attributes__guess_stash)
213{
214 dXSARGS;
215 SV *rv, *sv;
216#ifdef dXSTARGET
217 dXSTARGET;
218#else
219 SV * TARG = sv_newmortal();
220#endif
221
222 if (items != 1) {
223usage:
224 Perl_croak(aTHX_
225 "Usage: attributes::_guess_stash $reference");
226 }
227
228 rv = ST(0);
229 ST(0) = TARG;
230 if (!(SvOK(rv) && SvROK(rv)))
231 goto usage;
232 sv = SvRV(rv);
233
234 if (SvOBJECT(sv))
235 sv_setpv(TARG, HvNAME(SvSTASH(sv)));
236#if 0 /* this was probably a bad idea */
237 else if (SvPADMY(sv))
238 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
239#endif
240 else {
241 HV *stash = Nullhv;
242 switch (SvTYPE(sv)) {
243 case SVt_PVCV:
6676db26 244 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843 245 stash = GvSTASH(CvGV(sv));
6676db26 246 else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843 247 stash = CvSTASH(sv);
248 break;
249 case SVt_PVMG:
14befaf4 250 if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
09bef843 251 break;
252 /*FALLTHROUGH*/
253 case SVt_PVGV:
6676db26 254 if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843 255 stash = GvESTASH((GV*)sv);
256 break;
257 default:
258 break;
259 }
260 if (stash)
261 sv_setpv(TARG, HvNAME(stash));
262 }
263
264#ifdef dXSTARGET
265 SvSETMAGIC(TARG);
266#endif
267 XSRETURN(1);
268}
269
270XS(XS_attributes_reftype)
271{
272 dXSARGS;
273 SV *rv, *sv;
274#ifdef dXSTARGET
275 dXSTARGET;
276#else
277 SV * TARG = sv_newmortal();
278#endif
279
280 if (items != 1) {
281usage:
282 Perl_croak(aTHX_
283 "Usage: attributes::reftype $reference");
284 }
285
286 rv = ST(0);
287 ST(0) = TARG;
4694d0ea 288 if (SvGMAGICAL(rv))
289 mg_get(rv);
121e869f 290 if (!(SvOK(rv) && SvROK(rv)))
09bef843 291 goto usage;
292 sv = SvRV(rv);
293 sv_setpv(TARG, sv_reftype(sv, 0));
294#ifdef dXSTARGET
295 SvSETMAGIC(TARG);
296#endif
297
298 XSRETURN(1);
299}
300
301XS(XS_attributes__warn_reserved)
302{
303 dXSARGS;
09bef843 304#ifdef dXSTARGET
305 dXSTARGET;
306#else
307 SV * TARG = sv_newmortal();
308#endif
309
310 if (items != 0) {
311 Perl_croak(aTHX_
312 "Usage: attributes::_warn_reserved ()");
313 }
314
315 EXTEND(SP,1);
316 ST(0) = TARG;
317 sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
318#ifdef dXSTARGET
319 SvSETMAGIC(TARG);
320#endif
321
322 XSRETURN(1);
323}
324