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