File::Spec bugs (spotted by Hack Kampbjorn <hack@hackdata.com>)
[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; */
10void XS_attributes__warn_reserved(pTHXo_ CV *cv);
11void XS_attributes_reftype(pTHXo_ CV *cv);
12void XS_attributes__modify_attrs(pTHXo_ CV *cv);
13void XS_attributes__guess_stash(pTHXo_ CV *cv);
14void XS_attributes__fetch_attrs(pTHXo_ CV *cv);
15void XS_attributes_bootstrap(pTHXo_ CV *cv);
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
41modify_SV_attributes(pTHXo_ 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);
51 if (negated = (*name == '-')) {
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;
87 }
88 break;
89 }
90 break;
91 default:
92 /* nothing, yet */
93 break;
94 }
95 /* anything recognized had a 'continue' above */
96 *retlist++ = attr;
97 nret++;
98 }
99
100 return nret;
101}
102
103
09bef843 104
105/* package attributes; */
106
107XS(XS_attributes_bootstrap)
108{
109 dXSARGS;
110 char *file = __FILE__;
111
112 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
113 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
114 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
115 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
116 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
117
118 XSRETURN(0);
119}
120
121XS(XS_attributes__modify_attrs)
122{
123 dXSARGS;
124 SV *rv, *sv;
125
126 if (items < 1) {
127usage:
128 Perl_croak(aTHX_
129 "Usage: attributes::_modify_attrs $reference, @attributes");
130 }
131
132 rv = ST(0);
133 if (!(SvOK(rv) && SvROK(rv)))
134 goto usage;
135 sv = SvRV(rv);
136 if (items > 1)
349fd7b7 137 XSRETURN(modify_SV_attributes(aTHXo_ sv, &ST(0), &ST(1), items-1));
09bef843 138
139 XSRETURN(0);
140}
141
142XS(XS_attributes__fetch_attrs)
143{
144 dXSARGS;
145 SV *rv, *sv;
146 cv_flags_t cvflags;
147
148 if (items != 1) {
149usage:
150 Perl_croak(aTHX_
151 "Usage: attributes::_fetch_attrs $reference");
152 }
153
154 rv = ST(0);
155 SP -= items;
156 if (!(SvOK(rv) && SvROK(rv)))
157 goto usage;
158 sv = SvRV(rv);
159
160 switch (SvTYPE(sv)) {
161 case SVt_PVCV:
162 cvflags = CvFLAGS((CV*)sv);
163 if (cvflags & CVf_LOCKED)
164 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
165#ifdef CVf_LVALUE
166 if (cvflags & CVf_LVALUE)
167 XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
168#endif
169 if (cvflags & CVf_METHOD)
170 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
171 break;
172 default:
173 break;
174 }
175
176 PUTBACK;
177}
178
179XS(XS_attributes__guess_stash)
180{
181 dXSARGS;
182 SV *rv, *sv;
183#ifdef dXSTARGET
184 dXSTARGET;
185#else
186 SV * TARG = sv_newmortal();
187#endif
188
189 if (items != 1) {
190usage:
191 Perl_croak(aTHX_
192 "Usage: attributes::_guess_stash $reference");
193 }
194
195 rv = ST(0);
196 ST(0) = TARG;
197 if (!(SvOK(rv) && SvROK(rv)))
198 goto usage;
199 sv = SvRV(rv);
200
201 if (SvOBJECT(sv))
202 sv_setpv(TARG, HvNAME(SvSTASH(sv)));
203#if 0 /* this was probably a bad idea */
204 else if (SvPADMY(sv))
205 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
206#endif
207 else {
208 HV *stash = Nullhv;
209 switch (SvTYPE(sv)) {
210 case SVt_PVCV:
211 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) &&
212 HvNAME(GvSTASH(CvGV(sv))))
213 stash = GvSTASH(CvGV(sv));
214 else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv)))
215 stash = CvSTASH(sv);
216 break;
217 case SVt_PVMG:
218 if (!(SvFAKE(sv) && SvTIED_mg(sv, '*')))
219 break;
220 /*FALLTHROUGH*/
221 case SVt_PVGV:
222 if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv)))
223 stash = GvESTASH((GV*)sv);
224 break;
225 default:
226 break;
227 }
228 if (stash)
229 sv_setpv(TARG, HvNAME(stash));
230 }
231
232#ifdef dXSTARGET
233 SvSETMAGIC(TARG);
234#endif
235 XSRETURN(1);
236}
237
238XS(XS_attributes_reftype)
239{
240 dXSARGS;
241 SV *rv, *sv;
242#ifdef dXSTARGET
243 dXSTARGET;
244#else
245 SV * TARG = sv_newmortal();
246#endif
247
248 if (items != 1) {
249usage:
250 Perl_croak(aTHX_
251 "Usage: attributes::reftype $reference");
252 }
253
254 rv = ST(0);
255 ST(0) = TARG;
256 if (!SvOK(rv)) {
257 ST(0) = &PL_sv_no;
258 XSRETURN(1);
259 }
260 if (!SvROK(rv))
261 goto usage;
262 sv = SvRV(rv);
263 sv_setpv(TARG, sv_reftype(sv, 0));
264#ifdef dXSTARGET
265 SvSETMAGIC(TARG);
266#endif
267
268 XSRETURN(1);
269}
270
271XS(XS_attributes__warn_reserved)
272{
273 dXSARGS;
274 SV *rv, *sv;
275#ifdef dXSTARGET
276 dXSTARGET;
277#else
278 SV * TARG = sv_newmortal();
279#endif
280
281 if (items != 0) {
282 Perl_croak(aTHX_
283 "Usage: attributes::_warn_reserved ()");
284 }
285
286 EXTEND(SP,1);
287 ST(0) = TARG;
288 sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
289#ifdef dXSTARGET
290 SvSETMAGIC(TARG);
291#endif
292
293 XSRETURN(1);
294}
295