Add MANIFEST sort test
[perl.git] / xsutils.c
1 /*    xsutils.c
2  *
3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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  *     [p.597 of _The Lord of the Rings_, III/xi: "The Palant�r"]
16  */
17
18
19 #include "EXTERN.h"
20 #define PERL_IN_XSUTILS_C
21 #include "perl.h"
22
23 /*
24  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
25  */
26
27 /* package attributes; */
28 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
29 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
30 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
31 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
32 PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
33
34
35 /*
36  * Note that only ${pkg}::bootstrap definitions should go here.
37  * This helps keep down the start-up time, which is especially
38  * relevant for users who don't invoke any features which are
39  * (partially) implemented here.
40  *
41  * The various bootstrap definitions can take care of doing
42  * package-specific newXS() calls.  Since the layout of the
43  * bundled *.pm files is in a version-specific directory,
44  * version checks in these bootstrap calls are optional.
45  */
46
47 static const char file[] = __FILE__;
48
49 void
50 Perl_boot_core_xsutils(pTHX)
51 {
52     newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
53 }
54
55 #include "XSUB.h"
56
57 static int
58 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
59 {
60     dVAR;
61     SV *attr;
62     int nret;
63
64     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
65         STRLEN len;
66         const char *name = SvPV_const(attr, len);
67         const bool negated = (*name == '-');
68
69         if (negated) {
70             name++;
71             len--;
72         }
73         switch (SvTYPE(sv)) {
74         case SVt_PVCV:
75             switch ((int)len) {
76             case 6:
77                 switch (name[3]) {
78                 case 'l':
79                     if (memEQ(name, "lvalue", 6)) {
80                         if (negated)
81                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
82                         else
83                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
84                         continue;
85                     }
86                     break;
87                 case 'k':
88                     if (memEQ(name, "locked", 6)) {
89                         if (negated)
90                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LOCKED;
91                         else
92                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LOCKED;
93                         continue;
94                     }
95                     break;
96                 case 'h':
97                     if (memEQ(name, "method", 6)) {
98                         if (negated)
99                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
100                         else
101                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
102                         continue;
103                     }
104                     break;
105                 }
106                 break;
107             }
108             break;
109         default:
110             switch ((int)len) {
111             case 6:
112                 switch (name[5]) {
113                 case 'd':
114                     if (memEQ(name, "share", 5)) {
115                         if (negated)
116                             Perl_croak(aTHX_ "A variable may not be unshared");
117                         SvSHARE(sv);
118                         continue;
119                     }
120                     break;
121                 case 'e':
122                     if (memEQ(name, "uniqu", 5)) {
123                         if (isGV_with_GP(sv)) {
124                             if (negated) {
125                                 GvUNIQUE_off(sv);
126                             } else {
127                                 GvUNIQUE_on(sv);
128                             }
129                         }
130                         /* Hope this came from toke.c if not a GV. */
131                         continue;
132                     }
133                 }
134             }
135             break;
136         }
137         /* anything recognized had a 'continue' above */
138         *retlist++ = attr;
139         nret++;
140     }
141
142     return nret;
143 }
144
145
146
147 /* package attributes; */
148
149 XS(XS_attributes_bootstrap)
150 {
151     dVAR;
152     dXSARGS;
153
154     if( items > 1 )
155         croak_xs_usage(cv, "$module");
156
157     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
158     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
159     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
160     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
161
162     XSRETURN(0);
163 }
164
165 XS(XS_attributes__modify_attrs)
166 {
167     dVAR;
168     dXSARGS;
169     SV *rv, *sv;
170
171     if (items < 1) {
172 usage:
173         croak_xs_usage(cv, "@attributes");
174     }
175
176     rv = ST(0);
177     if (!(SvOK(rv) && SvROK(rv)))
178         goto usage;
179     sv = SvRV(rv);
180     if (items > 1)
181         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
182
183     XSRETURN(0);
184 }
185
186 XS(XS_attributes__fetch_attrs)
187 {
188     dVAR;
189     dXSARGS;
190     SV *rv, *sv;
191     cv_flags_t cvflags;
192
193     if (items != 1) {
194 usage:
195         croak_xs_usage(cv, "$reference");
196     }
197
198     rv = ST(0);
199     SP -= items;
200     if (!(SvOK(rv) && SvROK(rv)))
201         goto usage;
202     sv = SvRV(rv);
203
204     switch (SvTYPE(sv)) {
205     case SVt_PVCV:
206         cvflags = CvFLAGS((const CV *)sv);
207         if (cvflags & CVf_LOCKED)
208             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
209         if (cvflags & CVf_LVALUE)
210             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
211         if (cvflags & CVf_METHOD)
212             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
213         if (GvUNIQUE(CvGV((const CV *)sv)))
214             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
215         break;
216     case SVt_PVGV:
217         if (isGV_with_GP(sv) && GvUNIQUE(sv))
218             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
219         break;
220     default:
221         break;
222     }
223
224     PUTBACK;
225 }
226
227 XS(XS_attributes__guess_stash)
228 {
229     dVAR;
230     dXSARGS;
231     SV *rv, *sv;
232     dXSTARG;
233
234     if (items != 1) {
235 usage:
236         croak_xs_usage(cv, "$reference");
237     }
238
239     rv = ST(0);
240     ST(0) = TARG;
241     if (!(SvOK(rv) && SvROK(rv)))
242         goto usage;
243     sv = SvRV(rv);
244
245     if (SvOBJECT(sv))
246         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
247 #if 0   /* this was probably a bad idea */
248     else if (SvPADMY(sv))
249         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
250 #endif
251     else {
252         const HV *stash = NULL;
253         switch (SvTYPE(sv)) {
254         case SVt_PVCV:
255             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
256                 stash = GvSTASH(CvGV(sv));
257             else if (/* !CvANON(sv) && */ CvSTASH(sv))
258                 stash = CvSTASH(sv);
259             break;
260         case SVt_PVGV:
261             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
262                 stash = GvESTASH(MUTABLE_GV(sv));
263             break;
264         default:
265             break;
266         }
267         if (stash)
268             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
269     }
270
271     SvSETMAGIC(TARG);
272     XSRETURN(1);
273 }
274
275 XS(XS_attributes_reftype)
276 {
277     dVAR;
278     dXSARGS;
279     SV *rv, *sv;
280     dXSTARG;
281
282     if (items != 1) {
283 usage:
284         croak_xs_usage(cv, "$reference");
285     }
286
287     rv = ST(0);
288     ST(0) = TARG;
289     SvGETMAGIC(rv);
290     if (!(SvOK(rv) && SvROK(rv)))
291         goto usage;
292     sv = SvRV(rv);
293     sv_setpv(TARG, sv_reftype(sv, 0));
294     SvSETMAGIC(TARG);
295
296     XSRETURN(1);
297 }
298
299 /*
300  * Local variables:
301  * c-indentation-style: bsd
302  * c-basic-offset: 4
303  * indent-tabs-mode: t
304  * End:
305  *
306  * ex: set ts=8 sts=4 sw=4 noet:
307  */