This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
XS() __attribute__
[perl5.git] / xsutils.c
1 /*    xsutils.c
2  *
3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
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; */
26 PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv);
27 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
28 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
29 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
30 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
31 PERL_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
46 void
47 Perl_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
56 static int
57 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
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);
67         if ((negated = (*name == '-'))) {
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                         /* Hope this came from toke.c if not a GV. */
141                         continue;
142                     }
143                 }
144             }
145             break;
146         }
147         /* anything recognized had a 'continue' above */
148         *retlist++ = attr;
149         nret++;
150     }
151
152     return nret;
153 }
154
155
156
157 /* package attributes; */
158
159 XS(XS_attributes_bootstrap)
160 {
161     dXSARGS;
162     const char file[] = __FILE__;
163
164     if( items > 1 )
165         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
166
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
176 XS(XS_attributes__modify_attrs)
177 {
178     dXSARGS;
179     SV *rv, *sv;
180
181     if (items < 1) {
182 usage:
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)
192         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
193
194     XSRETURN(0);
195 }
196
197 XS(XS_attributes__fetch_attrs)
198 {
199     dXSARGS;
200     SV *rv, *sv;
201     cv_flags_t cvflags;
202
203     if (items != 1) {
204 usage:
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)));
226         if (GvUNIQUE(CvGV((CV*)sv)))
227             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
228         if (cvflags & CVf_ASSERTION)
229             XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
230         break;
231     case SVt_PVGV:
232         if (GvUNIQUE(sv))
233             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
234         break;
235     default:
236         break;
237     }
238
239     PUTBACK;
240 }
241
242 XS(XS_attributes__guess_stash)
243 {
244     dXSARGS;
245     SV *rv, *sv;
246     dXSTARG;
247
248     if (items != 1) {
249 usage:
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 {
267         const HV *stash = Nullhv;
268         switch (SvTYPE(sv)) {
269         case SVt_PVCV:
270             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
271                 stash = GvSTASH(CvGV(sv));
272             else if (/* !CvANON(sv) && */ CvSTASH(sv))
273                 stash = CvSTASH(sv);
274             break;
275         case SVt_PVMG:
276             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
277                 break;
278             /*FALLTHROUGH*/
279         case SVt_PVGV:
280             if (GvGP(sv) && GvESTASH((GV*)sv))
281                 stash = GvESTASH((GV*)sv);
282             break;
283         default:
284             break;
285         }
286         if (stash)
287             sv_setpv(TARG, HvNAME(stash));
288     }
289
290     SvSETMAGIC(TARG);
291     XSRETURN(1);
292 }
293
294 XS(XS_attributes_reftype)
295 {
296     dXSARGS;
297     SV *rv, *sv;
298     dXSTARG;
299
300     if (items != 1) {
301 usage:
302         Perl_croak(aTHX_
303                    "Usage: attributes::reftype $reference");
304     }
305
306     rv = ST(0);
307     ST(0) = TARG;
308     if (SvGMAGICAL(rv))
309         mg_get(rv);
310     if (!(SvOK(rv) && SvROK(rv)))
311         goto usage;
312     sv = SvRV(rv);
313     sv_setpv(TARG, sv_reftype(sv, 0));
314     SvSETMAGIC(TARG);
315
316     XSRETURN(1);
317 }
318
319 XS(XS_attributes__warn_reserved)
320 {
321     dXSARGS;
322
323     if (items != 0) {
324         Perl_croak(aTHX_
325                    "Usage: attributes::_warn_reserved ()");
326     }
327
328     EXTEND(SP,1);
329     ST(0) = boolSV(ckWARN(WARN_RESERVED));
330
331     XSRETURN(1);
332 }
333