This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
4f7324f90be1b6f2ce610c7d3376f9ab4a80ef70
[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     (void)cv;
164
165     if( items > 1 )
166         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
167
168     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
169     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
170     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
171     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
172     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
173
174     XSRETURN(0);
175 }
176
177 XS(XS_attributes__modify_attrs)
178 {
179     dXSARGS;
180     SV *rv, *sv;
181     (void)cv;
182
183     if (items < 1) {
184 usage:
185         Perl_croak(aTHX_
186                    "Usage: attributes::_modify_attrs $reference, @attributes");
187     }
188
189     rv = ST(0);
190     if (!(SvOK(rv) && SvROK(rv)))
191         goto usage;
192     sv = SvRV(rv);
193     if (items > 1)
194         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
195
196     XSRETURN(0);
197 }
198
199 XS(XS_attributes__fetch_attrs)
200 {
201     dXSARGS;
202     SV *rv, *sv;
203     cv_flags_t cvflags;
204     (void)cv;
205
206     if (items != 1) {
207 usage:
208         Perl_croak(aTHX_
209                    "Usage: attributes::_fetch_attrs $reference");
210     }
211
212     rv = ST(0);
213     SP -= items;
214     if (!(SvOK(rv) && SvROK(rv)))
215         goto usage;
216     sv = SvRV(rv);
217
218     switch (SvTYPE(sv)) {
219     case SVt_PVCV:
220         cvflags = CvFLAGS((CV*)sv);
221         if (cvflags & CVf_LOCKED)
222             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
223 #ifdef CVf_LVALUE
224         if (cvflags & CVf_LVALUE)
225             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
226 #endif
227         if (cvflags & CVf_METHOD)
228             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
229         if (GvUNIQUE(CvGV((CV*)sv)))
230             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
231         if (cvflags & CVf_ASSERTION)
232             XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
233         break;
234     case SVt_PVGV:
235         if (GvUNIQUE(sv))
236             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
237         break;
238     default:
239         break;
240     }
241
242     PUTBACK;
243 }
244
245 XS(XS_attributes__guess_stash)
246 {
247     dXSARGS;
248     SV *rv, *sv;
249     dXSTARG;
250     (void)cv;
251
252     if (items != 1) {
253 usage:
254         Perl_croak(aTHX_
255                    "Usage: attributes::_guess_stash $reference");
256     }
257
258     rv = ST(0);
259     ST(0) = TARG;
260     if (!(SvOK(rv) && SvROK(rv)))
261         goto usage;
262     sv = SvRV(rv);
263
264     if (SvOBJECT(sv))
265         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
266 #if 0   /* this was probably a bad idea */
267     else if (SvPADMY(sv))
268         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
269 #endif
270     else {
271         const HV *stash = Nullhv;
272         switch (SvTYPE(sv)) {
273         case SVt_PVCV:
274             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
275                 stash = GvSTASH(CvGV(sv));
276             else if (/* !CvANON(sv) && */ CvSTASH(sv))
277                 stash = CvSTASH(sv);
278             break;
279         case SVt_PVMG:
280             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
281                 break;
282             /*FALLTHROUGH*/
283         case SVt_PVGV:
284             if (GvGP(sv) && GvESTASH((GV*)sv))
285                 stash = GvESTASH((GV*)sv);
286             break;
287         default:
288             break;
289         }
290         if (stash)
291             sv_setpv(TARG, HvNAME(stash));
292     }
293
294     SvSETMAGIC(TARG);
295     XSRETURN(1);
296 }
297
298 XS(XS_attributes_reftype)
299 {
300     dXSARGS;
301     SV *rv, *sv;
302     dXSTARG;
303     (void)cv;
304
305     if (items != 1) {
306 usage:
307         Perl_croak(aTHX_
308                    "Usage: attributes::reftype $reference");
309     }
310
311     rv = ST(0);
312     ST(0) = TARG;
313     if (SvGMAGICAL(rv))
314         mg_get(rv);
315     if (!(SvOK(rv) && SvROK(rv)))
316         goto usage;
317     sv = SvRV(rv);
318     sv_setpv(TARG, sv_reftype(sv, 0));
319     SvSETMAGIC(TARG);
320
321     XSRETURN(1);
322 }
323
324 XS(XS_attributes__warn_reserved)
325 {
326     dXSARGS;
327     (void)cv;
328
329     if (items != 0) {
330         Perl_croak(aTHX_
331                    "Usage: attributes::_warn_reserved ()");
332     }
333
334     EXTEND(SP,1);
335     ST(0) = boolSV(ckWARN(WARN_RESERVED));
336
337     XSRETURN(1);
338 }
339