This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
XS() __attribute__
[perl5.git] / xsutils.c
CommitLineData
d6376244
JH
1/* xsutils.c
2 *
cbdf9ef8 3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
371fce9b 4 * by Larry Wall and others
d6376244
JH
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
d31a8517
AT
11/*
12 * "Perilous to us all are the devices of an art deeper than we possess
13 * ourselves." --Gandalf
14 */
15
16
09bef843
SB
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
349fd7b7 25/* package attributes; */
27da23d5
JH
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);
349fd7b7
GS
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
6a34af38 42 * bundled *.pm files is in a version-specific directory,
349fd7b7
GS
43 * version checks in these bootstrap calls are optional.
44 */
45
46void
47Perl_boot_core_xsutils(pTHX)
48{
e1ec3a88 49 const char file[] = __FILE__;
349fd7b7
GS
50
51 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
52}
53
349fd7b7
GS
54#include "XSUB.h"
55
56static int
acfe0abc 57modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
09bef843
SB
58{
59 SV *attr;
60 char *name;
61 STRLEN len;
62 bool negated;
63 int nret;
64
65 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
66 name = SvPV(attr, len);
155aba94 67 if ((negated = (*name == '-'))) {
09bef843
SB
68 name++;
69 len--;
70 }
71 switch (SvTYPE(sv)) {
72 case SVt_PVCV:
73 switch ((int)len) {
77c9267e 74#ifdef CVf_ASSERTION
42262798 75 case 9:
8cad210e 76 if (memEQ(name, "assertion", 9)) {
42262798
NC
77 if (negated)
78 CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
79 else
80 CvFLAGS((CV*)sv) |= CVf_ASSERTION;
81 continue;
82 }
83 break;
77c9267e 84#endif
09bef843 85 case 6:
8cad210e 86 switch (name[3]) {
09bef843
SB
87 case 'l':
88#ifdef CVf_LVALUE
8cad210e 89 if (memEQ(name, "lvalue", 6)) {
09bef843
SB
90 if (negated)
91 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
92 else
93 CvFLAGS((CV*)sv) |= CVf_LVALUE;
94 continue;
95 }
8cad210e
NC
96 break;
97 case 'k':
09bef843 98#endif /* defined CVf_LVALUE */
8cad210e 99 if (memEQ(name, "locked", 6)) {
09bef843
SB
100 if (negated)
101 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
102 else
103 CvFLAGS((CV*)sv) |= CVf_LOCKED;
104 continue;
105 }
106 break;
8cad210e
NC
107 case 'h':
108 if (memEQ(name, "method", 6)) {
09bef843
SB
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:
0256094b 121 switch ((int)len) {
95f0a2f1 122 case 6:
8cad210e
NC
123 switch (name[5]) {
124 case 'd':
125 if (memEQ(name, "share", 5)) {
13c1b207
DM
126 if (negated)
127 Perl_croak(aTHX_ "A variable may not be unshared");
128 SvSHARE(sv);
129 continue;
130 }
131 break;
8cad210e
NC
132 case 'e':
133 if (memEQ(name, "uniqu", 5)) {
95f0a2f1
SB
134 if (SvTYPE(sv) == SVt_PVGV) {
135 if (negated)
136 GvUNIQUE_off(sv);
137 else
138 GvUNIQUE_on(sv);
139 }
140 /* Hope this came from toke.c if not a GV. */
0256094b
DM
141 continue;
142 }
143 }
144 }
09bef843
SB
145 break;
146 }
147 /* anything recognized had a 'continue' above */
148 *retlist++ = attr;
149 nret++;
150 }
151
152 return nret;
153}
154
155
09bef843
SB
156
157/* package attributes; */
158
159XS(XS_attributes_bootstrap)
160{
161 dXSARGS;
e1ec3a88 162 const char file[] = __FILE__;
09bef843 163
592f5969
MS
164 if( items > 1 )
165 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
b7953727 166
09bef843
SB
167 newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
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 dXSARGS;
179 SV *rv, *sv;
180
181 if (items < 1) {
182usage:
183 Perl_croak(aTHX_
184 "Usage: attributes::_modify_attrs $reference, @attributes");
185 }
186
187 rv = ST(0);
188 if (!(SvOK(rv) && SvROK(rv)))
189 goto usage;
190 sv = SvRV(rv);
191 if (items > 1)
acfe0abc 192 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843
SB
193
194 XSRETURN(0);
195}
196
197XS(XS_attributes__fetch_attrs)
198{
199 dXSARGS;
200 SV *rv, *sv;
201 cv_flags_t cvflags;
202
203 if (items != 1) {
204usage:
205 Perl_croak(aTHX_
206 "Usage: attributes::_fetch_attrs $reference");
207 }
208
209 rv = ST(0);
210 SP -= items;
211 if (!(SvOK(rv) && SvROK(rv)))
212 goto usage;
213 sv = SvRV(rv);
214
215 switch (SvTYPE(sv)) {
216 case SVt_PVCV:
217 cvflags = CvFLAGS((CV*)sv);
218 if (cvflags & CVf_LOCKED)
219 XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
220#ifdef CVf_LVALUE
221 if (cvflags & CVf_LVALUE)
222 XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
223#endif
224 if (cvflags & CVf_METHOD)
225 XPUSHs(sv_2mortal(newSVpvn("method", 6)));
7fb37951 226 if (GvUNIQUE(CvGV((CV*)sv)))
95f0a2f1 227 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
06492da6
SF
228 if (cvflags & CVf_ASSERTION)
229 XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
95f0a2f1
SB
230 break;
231 case SVt_PVGV:
232 if (GvUNIQUE(sv))
233 XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
09bef843
SB
234 break;
235 default:
236 break;
237 }
238
239 PUTBACK;
240}
241
242XS(XS_attributes__guess_stash)
243{
244 dXSARGS;
245 SV *rv, *sv;
d277572a 246 dXSTARG;
09bef843
SB
247
248 if (items != 1) {
249usage:
250 Perl_croak(aTHX_
251 "Usage: attributes::_guess_stash $reference");
252 }
253
254 rv = ST(0);
255 ST(0) = TARG;
256 if (!(SvOK(rv) && SvROK(rv)))
257 goto usage;
258 sv = SvRV(rv);
259
260 if (SvOBJECT(sv))
261 sv_setpv(TARG, HvNAME(SvSTASH(sv)));
262#if 0 /* this was probably a bad idea */
263 else if (SvPADMY(sv))
264 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
265#endif
266 else {
6867be6d 267 const HV *stash = Nullhv;
09bef843
SB
268 switch (SvTYPE(sv)) {
269 case SVt_PVCV:
6676db26 270 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843 271 stash = GvSTASH(CvGV(sv));
6676db26 272 else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843
SB
273 stash = CvSTASH(sv);
274 break;
275 case SVt_PVMG:
14befaf4 276 if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
09bef843
SB
277 break;
278 /*FALLTHROUGH*/
279 case SVt_PVGV:
6676db26 280 if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843
SB
281 stash = GvESTASH((GV*)sv);
282 break;
283 default:
284 break;
285 }
286 if (stash)
287 sv_setpv(TARG, HvNAME(stash));
288 }
289
09bef843 290 SvSETMAGIC(TARG);
09bef843
SB
291 XSRETURN(1);
292}
293
294XS(XS_attributes_reftype)
295{
296 dXSARGS;
297 SV *rv, *sv;
d277572a 298 dXSTARG;
09bef843
SB
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;
4694d0ea
GS
308 if (SvGMAGICAL(rv))
309 mg_get(rv);
121e869f 310 if (!(SvOK(rv) && SvROK(rv)))
09bef843
SB
311 goto usage;
312 sv = SvRV(rv);
313 sv_setpv(TARG, sv_reftype(sv, 0));
09bef843 314 SvSETMAGIC(TARG);
09bef843
SB
315
316 XSRETURN(1);
317}
318
319XS(XS_attributes__warn_reserved)
320{
321 dXSARGS;
09bef843
SB
322
323 if (items != 0) {
324 Perl_croak(aTHX_
325 "Usage: attributes::_warn_reserved ()");
326 }
327
328 EXTEND(SP,1);
0006dff7 329 ST(0) = boolSV(ckWARN(WARN_RESERVED));
09bef843
SB
330
331 XSRETURN(1);
332}
333