This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
identifiers always in main (was: defining a _ function breaks File::Find)
[perl5.git] / xsutils.c
... / ...
CommitLineData
1/* xsutils.c
2 *
3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
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; */
26PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv);
27PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
28PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
29PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
30PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
31PERL_XS_EXPORT_C 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
46void
47Perl_boot_core_xsutils(pTHX)
48{
49 const char file[] = __FILE__;
50
51 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
52}
53
54#include "XSUB.h"
55
56static int
57modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
58{
59 dVAR;
60 SV *attr;
61 int nret;
62
63 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
64 STRLEN len;
65 const char *name = SvPV_const(attr, len);
66 const bool negated = (*name == '-');
67
68 if (negated) {
69 name++;
70 len--;
71 }
72 switch (SvTYPE(sv)) {
73 case SVt_PVCV:
74 switch ((int)len) {
75#ifdef CVf_ASSERTION
76 case 9:
77 if (memEQ(name, "assertion", 9)) {
78 if (negated)
79 CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
80 else
81 CvFLAGS((CV*)sv) |= CVf_ASSERTION;
82 continue;
83 }
84 break;
85#endif
86 case 6:
87 switch (name[3]) {
88 case 'l':
89#ifdef CVf_LVALUE
90 if (memEQ(name, "lvalue", 6)) {
91 if (negated)
92 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
93 else
94 CvFLAGS((CV*)sv) |= CVf_LVALUE;
95 continue;
96 }
97 break;
98 case 'k':
99#endif /* defined CVf_LVALUE */
100 if (memEQ(name, "locked", 6)) {
101 if (negated)
102 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
103 else
104 CvFLAGS((CV*)sv) |= CVf_LOCKED;
105 continue;
106 }
107 break;
108 case 'h':
109 if (memEQ(name, "method", 6)) {
110 if (negated)
111 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
112 else
113 CvFLAGS((CV*)sv) |= CVf_METHOD;
114 continue;
115 }
116 break;
117 }
118 break;
119 }
120 break;
121 default:
122 switch ((int)len) {
123 case 6:
124 switch (name[5]) {
125 case 'd':
126 if (memEQ(name, "share", 5)) {
127 if (negated)
128 Perl_croak(aTHX_ "A variable may not be unshared");
129 SvSHARE(sv);
130 continue;
131 }
132 break;
133 case 'e':
134 if (memEQ(name, "uniqu", 5)) {
135 if (SvTYPE(sv) == SVt_PVGV) {
136 if (negated) {
137 GvUNIQUE_off(sv);
138 } else {
139 GvUNIQUE_on(sv);
140 }
141 }
142 /* Hope this came from toke.c if not a GV. */
143 continue;
144 }
145 }
146 }
147 break;
148 }
149 /* anything recognized had a 'continue' above */
150 *retlist++ = attr;
151 nret++;
152 }
153
154 return nret;
155}
156
157
158
159/* package attributes; */
160
161XS(XS_attributes_bootstrap)
162{
163 dVAR;
164 dXSARGS;
165 const char file[] = __FILE__;
166
167 if( items > 1 )
168 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
169
170 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
171 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
172 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
173 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
174 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
175
176 XSRETURN(0);
177}
178
179XS(XS_attributes__modify_attrs)
180{
181 dVAR;
182 dXSARGS;
183 SV *rv, *sv;
184
185 if (items < 1) {
186usage:
187 Perl_croak(aTHX_
188 "Usage: attributes::_modify_attrs $reference, @attributes");
189 }
190
191 rv = ST(0);
192 if (!(SvOK(rv) && SvROK(rv)))
193 goto usage;
194 sv = SvRV(rv);
195 if (items > 1)
196 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
197
198 XSRETURN(0);
199}
200
201XS(XS_attributes__fetch_attrs)
202{
203 dVAR;
204 dXSARGS;
205 SV *rv, *sv;
206 cv_flags_t cvflags;
207
208 if (items != 1) {
209usage:
210 Perl_croak(aTHX_
211 "Usage: attributes::_fetch_attrs $reference");
212 }
213
214 rv = ST(0);
215 SP -= items;
216 if (!(SvOK(rv) && SvROK(rv)))
217 goto usage;
218 sv = SvRV(rv);
219
220 switch (SvTYPE(sv)) {
221 case SVt_PVCV:
222 cvflags = CvFLAGS((CV*)sv);
223 if (cvflags & CVf_LOCKED)
224 XPUSHs(sv_2mortal(newSVpvs("locked")));
225#ifdef CVf_LVALUE
226 if (cvflags & CVf_LVALUE)
227 XPUSHs(sv_2mortal(newSVpvs("lvalue")));
228#endif
229 if (cvflags & CVf_METHOD)
230 XPUSHs(sv_2mortal(newSVpvs("method")));
231 if (GvUNIQUE(CvGV((CV*)sv)))
232 XPUSHs(sv_2mortal(newSVpvs("unique")));
233 if (cvflags & CVf_ASSERTION)
234 XPUSHs(sv_2mortal(newSVpvs("assertion")));
235 break;
236 case SVt_PVGV:
237 if (GvUNIQUE(sv))
238 XPUSHs(sv_2mortal(newSVpvs("unique")));
239 break;
240 default:
241 break;
242 }
243
244 PUTBACK;
245}
246
247XS(XS_attributes__guess_stash)
248{
249 dVAR;
250 dXSARGS;
251 SV *rv, *sv;
252 dXSTARG;
253
254 if (items != 1) {
255usage:
256 Perl_croak(aTHX_
257 "Usage: attributes::_guess_stash $reference");
258 }
259
260 rv = ST(0);
261 ST(0) = TARG;
262 if (!(SvOK(rv) && SvROK(rv)))
263 goto usage;
264 sv = SvRV(rv);
265
266 if (SvOBJECT(sv))
267 sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
268#if 0 /* this was probably a bad idea */
269 else if (SvPADMY(sv))
270 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
271#endif
272 else {
273 const HV *stash = NULL;
274 switch (SvTYPE(sv)) {
275 case SVt_PVCV:
276 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
277 stash = GvSTASH(CvGV(sv));
278 else if (/* !CvANON(sv) && */ CvSTASH(sv))
279 stash = CvSTASH(sv);
280 break;
281 case SVt_PVMG:
282 if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
283 break;
284 /*FALLTHROUGH*/
285 case SVt_PVGV:
286 if (GvGP(sv) && GvESTASH((GV*)sv))
287 stash = GvESTASH((GV*)sv);
288 break;
289 default:
290 break;
291 }
292 if (stash)
293 sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
294 }
295
296 SvSETMAGIC(TARG);
297 XSRETURN(1);
298}
299
300XS(XS_attributes_reftype)
301{
302 dVAR;
303 dXSARGS;
304 SV *rv, *sv;
305 dXSTARG;
306
307 if (items != 1) {
308usage:
309 Perl_croak(aTHX_
310 "Usage: attributes::reftype $reference");
311 }
312
313 rv = ST(0);
314 ST(0) = TARG;
315 SvGETMAGIC(rv);
316 if (!(SvOK(rv) && SvROK(rv)))
317 goto usage;
318 sv = SvRV(rv);
319 sv_setpv(TARG, sv_reftype(sv, 0));
320 SvSETMAGIC(TARG);
321
322 XSRETURN(1);
323}
324
325XS(XS_attributes__warn_reserved)
326{
327 dVAR;
328 dXSARGS;
329
330 if (items != 0) {
331 Perl_croak(aTHX_
332 "Usage: attributes::_warn_reserved ()");
333 }
334
335 EXTEND(SP,1);
336 ST(0) = boolSV(ckWARN(WARN_RESERVED));
337
338 XSRETURN(1);
339}
340
341/*
342 * Local variables:
343 * c-indentation-style: bsd
344 * c-basic-offset: 4
345 * indent-tabs-mode: t
346 * End:
347 *
348 * ex: set ts=8 sts=4 sw=4 noet:
349 */