Socket::my_inet_aton() tweak
[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;
0256094b 87 case 's':
c8a3bf85 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) {
102 case 6:
103 switch (*name) {
104 case 's':
c8a3bf85 105 if (strEQ(name, "unique")) {
7fb37951 106 /* toke.c has already marked as GVf_UNIQUE */
0256094b 107 continue;
108 }
109 }
110 }
09bef843 111 break;
112 }
113 /* anything recognized had a 'continue' above */
114 *retlist++ = attr;
115 nret++;
116 }
117
118 return nret;
119}
120
121
09bef843 122
123/* package attributes; */
124
125XS(XS_attributes_bootstrap)
126{
127 dXSARGS;
128 char *file = __FILE__;
129
592f5969 130 if( items > 1 )
131 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
b7953727 132
09bef843 133 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
134 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
135 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
136 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
137 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
138
139 XSRETURN(0);
140}
141
142XS(XS_attributes__modify_attrs)
143{
144 dXSARGS;
145 SV *rv, *sv;
146
147 if (items < 1) {
148usage:
149 Perl_croak(aTHX_
150 "Usage: attributes::_modify_attrs $reference, @attributes");
151 }
152
153 rv = ST(0);
154 if (!(SvOK(rv) && SvROK(rv)))
155 goto usage;
156 sv = SvRV(rv);
157 if (items > 1)
acfe0abc 158 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843 159
160 XSRETURN(0);
161}
162
163XS(XS_attributes__fetch_attrs)
164{
165 dXSARGS;
166 SV *rv, *sv;
167 cv_flags_t cvflags;
168
169 if (items != 1) {
170usage:
171 Perl_croak(aTHX_
172 "Usage: attributes::_fetch_attrs $reference");
173 }
174
175 rv = ST(0);
176 SP -= items;
177 if (!(SvOK(rv) && SvROK(rv)))
178 goto usage;
179 sv = SvRV(rv);
180
181 switch (SvTYPE(sv)) {
182 case SVt_PVCV:
183 cvflags = CvFLAGS((CV*)sv);
184 if (cvflags & CVf_LOCKED)
185 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
186#ifdef CVf_LVALUE
187 if (cvflags & CVf_LVALUE)
188 XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
189#endif
190 if (cvflags & CVf_METHOD)
191 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
7fb37951 192 if (GvUNIQUE(CvGV((CV*)sv)))
c8a3bf85 193 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
09bef843 194 break;
195 default:
196 break;
197 }
198
199 PUTBACK;
200}
201
202XS(XS_attributes__guess_stash)
203{
204 dXSARGS;
205 SV *rv, *sv;
206#ifdef dXSTARGET
207 dXSTARGET;
208#else
209 SV * TARG = sv_newmortal();
210#endif
211
212 if (items != 1) {
213usage:
214 Perl_croak(aTHX_
215 "Usage: attributes::_guess_stash $reference");
216 }
217
218 rv = ST(0);
219 ST(0) = TARG;
220 if (!(SvOK(rv) && SvROK(rv)))
221 goto usage;
222 sv = SvRV(rv);
223
224 if (SvOBJECT(sv))
225 sv_setpv(TARG, HvNAME(SvSTASH(sv)));
226#if 0 /* this was probably a bad idea */
227 else if (SvPADMY(sv))
228 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
229#endif
230 else {
231 HV *stash = Nullhv;
232 switch (SvTYPE(sv)) {
233 case SVt_PVCV:
6676db26 234 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843 235 stash = GvSTASH(CvGV(sv));
6676db26 236 else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843 237 stash = CvSTASH(sv);
238 break;
239 case SVt_PVMG:
14befaf4 240 if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
09bef843 241 break;
242 /*FALLTHROUGH*/
243 case SVt_PVGV:
6676db26 244 if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843 245 stash = GvESTASH((GV*)sv);
246 break;
247 default:
248 break;
249 }
250 if (stash)
251 sv_setpv(TARG, HvNAME(stash));
252 }
253
254#ifdef dXSTARGET
255 SvSETMAGIC(TARG);
256#endif
257 XSRETURN(1);
258}
259
260XS(XS_attributes_reftype)
261{
262 dXSARGS;
263 SV *rv, *sv;
264#ifdef dXSTARGET
265 dXSTARGET;
266#else
267 SV * TARG = sv_newmortal();
268#endif
269
270 if (items != 1) {
271usage:
272 Perl_croak(aTHX_
273 "Usage: attributes::reftype $reference");
274 }
275
276 rv = ST(0);
277 ST(0) = TARG;
4694d0ea 278 if (SvGMAGICAL(rv))
279 mg_get(rv);
121e869f 280 if (!(SvOK(rv) && SvROK(rv)))
09bef843 281 goto usage;
282 sv = SvRV(rv);
283 sv_setpv(TARG, sv_reftype(sv, 0));
284#ifdef dXSTARGET
285 SvSETMAGIC(TARG);
286#endif
287
288 XSRETURN(1);
289}
290
291XS(XS_attributes__warn_reserved)
292{
293 dXSARGS;
09bef843 294#ifdef dXSTARGET
295 dXSTARGET;
296#else
297 SV * TARG = sv_newmortal();
298#endif
299
300 if (items != 0) {
301 Perl_croak(aTHX_
302 "Usage: attributes::_warn_reserved ()");
303 }
304
305 EXTEND(SP,1);
306 ST(0) = TARG;
307 sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
308#ifdef dXSTARGET
309 SvSETMAGIC(TARG);
310#endif
311
312 XSRETURN(1);
313}
314