More unpack cleanups.
[p5sagit/p5-mst-13.2.git] / xsutils.c
1 /*    xsutils.c
2  *
3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
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 void XS_attributes__warn_reserved(pTHX_ CV *cv);
27 void XS_attributes_reftype(pTHX_ CV *cv);
28 void XS_attributes__modify_attrs(pTHX_ CV *cv);
29 void XS_attributes__guess_stash(pTHX_ CV *cv);
30 void XS_attributes__fetch_attrs(pTHX_ CV *cv);
31 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     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             case 6:
75                 switch (*name) {
76                 case 'a':
77                     if (strEQ(name, "assertion")) {
78                         if (negated)
79                             CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
80                         else
81                             CvFLAGS((CV*)sv) |= CVf_ASSERTION;
82                         continue;
83                     }
84                     break;
85                 case 'l':
86 #ifdef CVf_LVALUE
87                     if (strEQ(name, "lvalue")) {
88                         if (negated)
89                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
90                         else
91                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
92                         continue;
93                     }
94 #endif /* defined CVf_LVALUE */
95                     if (strEQ(name, "locked")) {
96                         if (negated)
97                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
98                         else
99                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
100                         continue;
101                     }
102                     break;
103                 case 'm':
104                     if (strEQ(name, "method")) {
105                         if (negated)
106                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
107                         else
108                             CvFLAGS((CV*)sv) |= CVf_METHOD;
109                         continue;
110                     }
111                     break;
112                 }
113                 break;
114             }
115             break;
116         default:
117             switch ((int)len) {
118             case 6:
119                 switch (*name) {
120                 case 's':
121                     if (strEQ(name, "shared")) {
122                         if (negated)
123                             Perl_croak(aTHX_ "A variable may not be unshared");
124                         SvSHARE(sv);
125                         continue;
126                     }
127                     break;
128                 case 'u':
129                     if (strEQ(name, "unique")) {
130                         if (SvTYPE(sv) == SVt_PVGV) {
131                             if (negated)
132                                 GvUNIQUE_off(sv);
133                             else
134                                 GvUNIQUE_on(sv);
135                         }
136                         /* Hope this came from toke.c if not a GV. */
137                         continue;
138                     }
139                 }
140             }
141             break;
142         }
143         /* anything recognized had a 'continue' above */
144         *retlist++ = attr;
145         nret++;
146     }
147
148     return nret;
149 }
150
151
152
153 /* package attributes; */
154
155 XS(XS_attributes_bootstrap)
156 {
157     dXSARGS;
158     char *file = __FILE__;
159
160     if( items > 1 )
161         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
162
163     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
164     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
165     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
166     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
167     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
168
169     XSRETURN(0);
170 }
171
172 XS(XS_attributes__modify_attrs)
173 {
174     dXSARGS;
175     SV *rv, *sv;
176
177     if (items < 1) {
178 usage:
179         Perl_croak(aTHX_
180                    "Usage: attributes::_modify_attrs $reference, @attributes");
181     }
182
183     rv = ST(0);
184     if (!(SvOK(rv) && SvROK(rv)))
185         goto usage;
186     sv = SvRV(rv);
187     if (items > 1)
188         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
189
190     XSRETURN(0);
191 }
192
193 XS(XS_attributes__fetch_attrs)
194 {
195     dXSARGS;
196     SV *rv, *sv;
197     cv_flags_t cvflags;
198
199     if (items != 1) {
200 usage:
201         Perl_croak(aTHX_
202                    "Usage: attributes::_fetch_attrs $reference");
203     }
204
205     rv = ST(0);
206     SP -= items;
207     if (!(SvOK(rv) && SvROK(rv)))
208         goto usage;
209     sv = SvRV(rv);
210
211     switch (SvTYPE(sv)) {
212     case SVt_PVCV:
213         cvflags = CvFLAGS((CV*)sv);
214         if (cvflags & CVf_LOCKED)
215             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
216 #ifdef CVf_LVALUE
217         if (cvflags & CVf_LVALUE)
218             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
219 #endif
220         if (cvflags & CVf_METHOD)
221             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
222         if (GvUNIQUE(CvGV((CV*)sv)))
223             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
224         if (cvflags & CVf_ASSERTION)
225             XPUSHs(sv_2mortal(newSVpvn("assertion", 9)));
226         break;
227     case SVt_PVGV:
228         if (GvUNIQUE(sv))
229             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
230         break;
231     default:
232         break;
233     }
234
235     PUTBACK;
236 }
237
238 XS(XS_attributes__guess_stash)
239 {
240     dXSARGS;
241     SV *rv, *sv;
242 #ifdef dXSTARGET
243     dXSTARGET;
244 #else
245     SV * TARG = sv_newmortal();
246 #endif
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         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 #ifdef dXSTARGET
291     SvSETMAGIC(TARG);
292 #endif
293     XSRETURN(1);
294 }
295
296 XS(XS_attributes_reftype)
297 {
298     dXSARGS;
299     SV *rv, *sv;
300 #ifdef dXSTARGET
301     dXSTARGET;
302 #else
303     SV * TARG = sv_newmortal();
304 #endif
305
306     if (items != 1) {
307 usage:
308         Perl_croak(aTHX_
309                    "Usage: attributes::reftype $reference");
310     }
311
312     rv = ST(0);
313     ST(0) = TARG;
314     if (SvGMAGICAL(rv))
315         mg_get(rv);
316     if (!(SvOK(rv) && SvROK(rv)))
317         goto usage;
318     sv = SvRV(rv);
319     sv_setpv(TARG, sv_reftype(sv, 0));
320 #ifdef dXSTARGET
321     SvSETMAGIC(TARG);
322 #endif
323
324     XSRETURN(1);
325 }
326
327 XS(XS_attributes__warn_reserved)
328 {
329     dXSARGS;
330 #ifdef dXSTARGET
331     dXSTARGET;
332 #else
333     SV * TARG = sv_newmortal();
334 #endif
335
336     if (items != 0) {
337         Perl_croak(aTHX_
338                    "Usage: attributes::_warn_reserved ()");
339     }
340
341     EXTEND(SP,1);
342     ST(0) = TARG;
343     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
344 #ifdef dXSTARGET
345     SvSETMAGIC(TARG);
346 #endif
347
348     XSRETURN(1);
349 }
350