This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updates for building on Win32 with Visual C++ 2005 Express Edition
[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_reftype(pTHX_ CV *cv);
27PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
28PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
29PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
30PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
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
41 * bundled *.pm files is in a version-specific directory,
42 * version checks in these bootstrap calls are optional.
43 */
44
45static const char file[] = __FILE__;
46
47void
48Perl_boot_core_xsutils(pTHX)
49{
50 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
51}
52
53#include "XSUB.h"
54
55static int
56modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
57{
58 dVAR;
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#ifdef CVf_LVALUE
88 case 'l':
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#endif
98 case 'k':
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 dVAR;
163 dXSARGS;
164
165 if( items > 1 )
166 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
167
168 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
169 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
170 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
171 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
172
173 XSRETURN(0);
174}
175
176XS(XS_attributes__modify_attrs)
177{
178 dVAR;
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 dVAR;
201 dXSARGS;
202 SV *rv, *sv;
203 cv_flags_t cvflags;
204
205 if (items != 1) {
206usage:
207 Perl_croak(aTHX_
208 "Usage: attributes::_fetch_attrs $reference");
209 }
210
211 rv = ST(0);
212 SP -= items;
213 if (!(SvOK(rv) && SvROK(rv)))
214 goto usage;
215 sv = SvRV(rv);
216
217 switch (SvTYPE(sv)) {
218 case SVt_PVCV:
219 cvflags = CvFLAGS((CV*)sv);
220 if (cvflags & CVf_LOCKED)
221 XPUSHs(sv_2mortal(newSVpvs("locked")));
222#ifdef CVf_LVALUE
223 if (cvflags & CVf_LVALUE)
224 XPUSHs(sv_2mortal(newSVpvs("lvalue")));
225#endif
226 if (cvflags & CVf_METHOD)
227 XPUSHs(sv_2mortal(newSVpvs("method")));
228 if (GvUNIQUE(CvGV((CV*)sv)))
229 XPUSHs(sv_2mortal(newSVpvs("unique")));
230 if (cvflags & CVf_ASSERTION)
231 XPUSHs(sv_2mortal(newSVpvs("assertion")));
232 break;
233 case SVt_PVGV:
234 if (GvUNIQUE(sv))
235 XPUSHs(sv_2mortal(newSVpvs("unique")));
236 break;
237 default:
238 break;
239 }
240
241 PUTBACK;
242}
243
244XS(XS_attributes__guess_stash)
245{
246 dVAR;
247 dXSARGS;
248 SV *rv, *sv;
249 dXSTARG;
250
251 if (items != 1) {
252usage:
253 Perl_croak(aTHX_
254 "Usage: attributes::_guess_stash $reference");
255 }
256
257 rv = ST(0);
258 ST(0) = TARG;
259 if (!(SvOK(rv) && SvROK(rv)))
260 goto usage;
261 sv = SvRV(rv);
262
263 if (SvOBJECT(sv))
264 sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
265#if 0 /* this was probably a bad idea */
266 else if (SvPADMY(sv))
267 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
268#endif
269 else {
270 const HV *stash = NULL;
271 switch (SvTYPE(sv)) {
272 case SVt_PVCV:
273 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
274 stash = GvSTASH(CvGV(sv));
275 else if (/* !CvANON(sv) && */ CvSTASH(sv))
276 stash = CvSTASH(sv);
277 break;
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_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
287 }
288
289 SvSETMAGIC(TARG);
290 XSRETURN(1);
291}
292
293XS(XS_attributes_reftype)
294{
295 dVAR;
296 dXSARGS;
297 SV *rv, *sv;
298 dXSTARG;
299
300 if (items != 1) {
301usage:
302 Perl_croak(aTHX_
303 "Usage: attributes::reftype $reference");
304 }
305
306 rv = ST(0);
307 ST(0) = TARG;
308 SvGETMAGIC(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
318/*
319 * Local variables:
320 * c-indentation-style: bsd
321 * c-basic-offset: 4
322 * indent-tabs-mode: t
323 * End:
324 *
325 * ex: set ts=8 sts=4 sw=4 noet:
326 */