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