source: vendor/perl/5.8.8/xsutils.c@ 3611

Last change on this file since 3611 was 3181, checked in by bird, 19 years ago

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