Let's not assume how much memory has been allocated
[p5sagit/p5-mst-13.2.git] / xsutils.c
1 #include "EXTERN.h"
2 #define PERL_IN_XSUTILS_C
3 #include "perl.h"
4
5 /*
6  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
7  */
8
9 /* package attributes; */
10 void XS_attributes__warn_reserved(pTHX_ CV *cv);
11 void XS_attributes_reftype(pTHX_ CV *cv);
12 void XS_attributes__modify_attrs(pTHX_ CV *cv);
13 void XS_attributes__guess_stash(pTHX_ CV *cv);
14 void XS_attributes__fetch_attrs(pTHX_ CV *cv);
15 void XS_attributes_bootstrap(pTHX_ CV *cv);
16
17
18 /*
19  * Note that only ${pkg}::bootstrap definitions should go here.
20  * This helps keep down the start-up time, which is especially
21  * relevant for users who don't invoke any features which are
22  * (partially) implemented here.
23  *
24  * The various bootstrap definitions can take care of doing
25  * package-specific newXS() calls.  Since the layout of the
26  * bundled *.pm files is in a version-specific directory,
27  * version checks in these bootstrap calls are optional.
28  */
29
30 void
31 Perl_boot_core_xsutils(pTHX)
32 {
33     char *file = __FILE__;
34
35     newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
36 }
37
38 #include "XSUB.h"
39
40 static int
41 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
42 {
43     SV *attr;
44     char *name;
45     STRLEN len;
46     bool negated;
47     int nret;
48
49     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
50         name = SvPV(attr, len);
51         if ((negated = (*name == '-'))) {
52             name++;
53             len--;
54         }
55         switch (SvTYPE(sv)) {
56         case SVt_PVCV:
57             switch ((int)len) {
58             case 6:
59                 switch (*name) {
60                 case 'l':
61 #ifdef CVf_LVALUE
62                     if (strEQ(name, "lvalue")) {
63                         if (negated)
64                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
65                         else
66                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
67                         continue;
68                     }
69 #endif /* defined CVf_LVALUE */
70                     if (strEQ(name, "locked")) {
71                         if (negated)
72                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
73                         else
74                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
75                         continue;
76                     }
77                     break;
78                 case 'm':
79                     if (strEQ(name, "method")) {
80                         if (negated)
81                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
82                         else
83                             CvFLAGS((CV*)sv) |= CVf_METHOD;
84                         continue;
85                     }
86                     break;
87                 case 's':
88       if (strEQ(name, "unique")) {
89                         if (negated)
90                             GvUNIQUE_off(CvGV((CV*)sv));
91                         else
92                             GvUNIQUE_on(CvGV((CV*)sv));
93                         continue;
94                     }
95                     break;
96                 }
97                 break;
98             }
99             break;
100         default:
101             switch ((int)len) {
102               case 6:
103                 switch (*name) {
104                   case 's':
105       if (strEQ(name, "unique")) {
106                         /* toke.c has already marked as GVf_UNIQUE */
107                         continue;
108                     }
109                 }
110             }
111             break;
112         }
113         /* anything recognized had a 'continue' above */
114         *retlist++ = attr;
115         nret++;
116     }
117
118     return nret;
119 }
120
121
122
123 /* package attributes; */
124
125 XS(XS_attributes_bootstrap)
126 {
127     dXSARGS;
128     char *file = __FILE__;
129
130     if( items > 1 )
131         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
132
133     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
134     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
135     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
136     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
137     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
138
139     XSRETURN(0);
140 }
141
142 XS(XS_attributes__modify_attrs)
143 {
144     dXSARGS;
145     SV *rv, *sv;
146
147     if (items < 1) {
148 usage:
149         Perl_croak(aTHX_
150                    "Usage: attributes::_modify_attrs $reference, @attributes");
151     }
152
153     rv = ST(0);
154     if (!(SvOK(rv) && SvROK(rv)))
155         goto usage;
156     sv = SvRV(rv);
157     if (items > 1)
158         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
159
160     XSRETURN(0);
161 }
162
163 XS(XS_attributes__fetch_attrs)
164 {
165     dXSARGS;
166     SV *rv, *sv;
167     cv_flags_t cvflags;
168
169     if (items != 1) {
170 usage:
171         Perl_croak(aTHX_
172                    "Usage: attributes::_fetch_attrs $reference");
173     }
174
175     rv = ST(0);
176     SP -= items;
177     if (!(SvOK(rv) && SvROK(rv)))
178         goto usage;
179     sv = SvRV(rv);
180
181     switch (SvTYPE(sv)) {
182     case SVt_PVCV:
183         cvflags = CvFLAGS((CV*)sv);
184         if (cvflags & CVf_LOCKED)
185             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
186 #ifdef CVf_LVALUE
187         if (cvflags & CVf_LVALUE)
188             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
189 #endif
190         if (cvflags & CVf_METHOD)
191             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
192         if (GvUNIQUE(CvGV((CV*)sv)))
193      XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
194         break;
195     default:
196         break;
197     }
198
199     PUTBACK;
200 }
201
202 XS(XS_attributes__guess_stash)
203 {
204     dXSARGS;
205     SV *rv, *sv;
206 #ifdef dXSTARGET
207     dXSTARGET;
208 #else
209     SV * TARG = sv_newmortal();
210 #endif
211
212     if (items != 1) {
213 usage:
214         Perl_croak(aTHX_
215                    "Usage: attributes::_guess_stash $reference");
216     }
217
218     rv = ST(0);
219     ST(0) = TARG;
220     if (!(SvOK(rv) && SvROK(rv)))
221         goto usage;
222     sv = SvRV(rv);
223
224     if (SvOBJECT(sv))
225         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
226 #if 0   /* this was probably a bad idea */
227     else if (SvPADMY(sv))
228         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
229 #endif
230     else {
231         HV *stash = Nullhv;
232         switch (SvTYPE(sv)) {
233         case SVt_PVCV:
234             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
235                 stash = GvSTASH(CvGV(sv));
236             else if (/* !CvANON(sv) && */ CvSTASH(sv))
237                 stash = CvSTASH(sv);
238             break;
239         case SVt_PVMG:
240             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
241                 break;
242             /*FALLTHROUGH*/
243         case SVt_PVGV:
244             if (GvGP(sv) && GvESTASH((GV*)sv))
245                 stash = GvESTASH((GV*)sv);
246             break;
247         default:
248             break;
249         }
250         if (stash)
251             sv_setpv(TARG, HvNAME(stash));
252     }
253
254 #ifdef dXSTARGET
255     SvSETMAGIC(TARG);
256 #endif
257     XSRETURN(1);
258 }
259
260 XS(XS_attributes_reftype)
261 {
262     dXSARGS;
263     SV *rv, *sv;
264 #ifdef dXSTARGET
265     dXSTARGET;
266 #else
267     SV * TARG = sv_newmortal();
268 #endif
269
270     if (items != 1) {
271 usage:
272         Perl_croak(aTHX_
273                    "Usage: attributes::reftype $reference");
274     }
275
276     rv = ST(0);
277     ST(0) = TARG;
278     if (SvGMAGICAL(rv))
279         mg_get(rv);
280     if (!(SvOK(rv) && SvROK(rv)))
281         goto usage;
282     sv = SvRV(rv);
283     sv_setpv(TARG, sv_reftype(sv, 0));
284 #ifdef dXSTARGET
285     SvSETMAGIC(TARG);
286 #endif
287
288     XSRETURN(1);
289 }
290
291 XS(XS_attributes__warn_reserved)
292 {
293     dXSARGS;
294 #ifdef dXSTARGET
295     dXSTARGET;
296 #else
297     SV * TARG = sv_newmortal();
298 #endif
299
300     if (items != 0) {
301         Perl_croak(aTHX_
302                    "Usage: attributes::_warn_reserved ()");
303     }
304
305     EXTEND(SP,1);
306     ST(0) = TARG;
307     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
308 #ifdef dXSTARGET
309     SvSETMAGIC(TARG);
310 #endif
311
312     XSRETURN(1);
313 }
314