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