Remove Encode::Tcl::Extended, suggested by
[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 'u':
120                     if (strEQ(name, "unique")) {
121                         if (SvTYPE(sv) == SVt_PVGV) {
122                             if (negated)
123                                 GvUNIQUE_off(sv);
124                             else
125                                 GvUNIQUE_on(sv);
126                         }
127                         /* Hope this came from toke.c if not a GV. */
128                         continue;
129                     }
130                 }
131             }
132             break;
133         }
134         /* anything recognized had a 'continue' above */
135         *retlist++ = attr;
136         nret++;
137     }
138
139     return nret;
140 }
141
142
143
144 /* package attributes; */
145
146 XS(XS_attributes_bootstrap)
147 {
148     dXSARGS;
149     char *file = __FILE__;
150
151     if( items > 1 )
152         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
153
154     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
155     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
156     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
157     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
158     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
159
160     XSRETURN(0);
161 }
162
163 XS(XS_attributes__modify_attrs)
164 {
165     dXSARGS;
166     SV *rv, *sv;
167
168     if (items < 1) {
169 usage:
170         Perl_croak(aTHX_
171                    "Usage: attributes::_modify_attrs $reference, @attributes");
172     }
173
174     rv = ST(0);
175     if (!(SvOK(rv) && SvROK(rv)))
176         goto usage;
177     sv = SvRV(rv);
178     if (items > 1)
179         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
180
181     XSRETURN(0);
182 }
183
184 XS(XS_attributes__fetch_attrs)
185 {
186     dXSARGS;
187     SV *rv, *sv;
188     cv_flags_t cvflags;
189
190     if (items != 1) {
191 usage:
192         Perl_croak(aTHX_
193                    "Usage: attributes::_fetch_attrs $reference");
194     }
195
196     rv = ST(0);
197     SP -= items;
198     if (!(SvOK(rv) && SvROK(rv)))
199         goto usage;
200     sv = SvRV(rv);
201
202     switch (SvTYPE(sv)) {
203     case SVt_PVCV:
204         cvflags = CvFLAGS((CV*)sv);
205         if (cvflags & CVf_LOCKED)
206             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
207 #ifdef CVf_LVALUE
208         if (cvflags & CVf_LVALUE)
209             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
210 #endif
211         if (cvflags & CVf_METHOD)
212             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
213         if (GvUNIQUE(CvGV((CV*)sv)))
214             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
215         break;
216     case SVt_PVGV:
217         if (GvUNIQUE(sv))
218             XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
219         break;
220     default:
221         break;
222     }
223
224     PUTBACK;
225 }
226
227 XS(XS_attributes__guess_stash)
228 {
229     dXSARGS;
230     SV *rv, *sv;
231 #ifdef dXSTARGET
232     dXSTARGET;
233 #else
234     SV * TARG = sv_newmortal();
235 #endif
236
237     if (items != 1) {
238 usage:
239         Perl_croak(aTHX_
240                    "Usage: attributes::_guess_stash $reference");
241     }
242
243     rv = ST(0);
244     ST(0) = TARG;
245     if (!(SvOK(rv) && SvROK(rv)))
246         goto usage;
247     sv = SvRV(rv);
248
249     if (SvOBJECT(sv))
250         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
251 #if 0   /* this was probably a bad idea */
252     else if (SvPADMY(sv))
253         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
254 #endif
255     else {
256         HV *stash = Nullhv;
257         switch (SvTYPE(sv)) {
258         case SVt_PVCV:
259             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
260                 stash = GvSTASH(CvGV(sv));
261             else if (/* !CvANON(sv) && */ CvSTASH(sv))
262                 stash = CvSTASH(sv);
263             break;
264         case SVt_PVMG:
265             if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
266                 break;
267             /*FALLTHROUGH*/
268         case SVt_PVGV:
269             if (GvGP(sv) && GvESTASH((GV*)sv))
270                 stash = GvESTASH((GV*)sv);
271             break;
272         default:
273             break;
274         }
275         if (stash)
276             sv_setpv(TARG, HvNAME(stash));
277     }
278
279 #ifdef dXSTARGET
280     SvSETMAGIC(TARG);
281 #endif
282     XSRETURN(1);
283 }
284
285 XS(XS_attributes_reftype)
286 {
287     dXSARGS;
288     SV *rv, *sv;
289 #ifdef dXSTARGET
290     dXSTARGET;
291 #else
292     SV * TARG = sv_newmortal();
293 #endif
294
295     if (items != 1) {
296 usage:
297         Perl_croak(aTHX_
298                    "Usage: attributes::reftype $reference");
299     }
300
301     rv = ST(0);
302     ST(0) = TARG;
303     if (SvGMAGICAL(rv))
304         mg_get(rv);
305     if (!(SvOK(rv) && SvROK(rv)))
306         goto usage;
307     sv = SvRV(rv);
308     sv_setpv(TARG, sv_reftype(sv, 0));
309 #ifdef dXSTARGET
310     SvSETMAGIC(TARG);
311 #endif
312
313     XSRETURN(1);
314 }
315
316 XS(XS_attributes__warn_reserved)
317 {
318     dXSARGS;
319 #ifdef dXSTARGET
320     dXSTARGET;
321 #else
322     SV * TARG = sv_newmortal();
323 #endif
324
325     if (items != 0) {
326         Perl_croak(aTHX_
327                    "Usage: attributes::_warn_reserved ()");
328     }
329
330     EXTEND(SP,1);
331     ST(0) = TARG;
332     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
333 #ifdef dXSTARGET
334     SvSETMAGIC(TARG);
335 #endif
336
337     XSRETURN(1);
338 }
339