Re: [PATCH] Stop DTrace config option looping in non-interactive mode
[perl.git] / xsutils.c
1 /*    xsutils.c
2  *
3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
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 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
27 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
28 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
29 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
30 PERL_XS_EXPORT_C 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 static const char file[] = __FILE__;
46
47 void
48 Perl_boot_core_xsutils(pTHX)
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     dVAR;
59     SV *attr;
60     int nret;
61
62     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
63         STRLEN len;
64         const char *name = SvPV_const(attr, len);
65         const bool negated = (*name == '-');
66
67         if (negated) {
68             name++;
69             len--;
70         }
71         switch (SvTYPE(sv)) {
72         case SVt_PVCV:
73             switch ((int)len) {
74             case 6:
75                 switch (name[3]) {
76 #ifdef CVf_LVALUE
77                 case 'l':
78                     if (memEQ(name, "lvalue", 6)) {
79                         if (negated)
80                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
81                         else
82                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
83                         continue;
84                     }
85                     break;
86 #endif
87                 case 'k':
88                     if (memEQ(name, "locked", 6)) {
89                         if (negated)
90                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
91                         else
92                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
93                         continue;
94                     }
95                     break;
96                 case 'h':
97                     if (memEQ(name, "method", 6)) {
98                         if (negated)
99                             CvFLAGS((CV*)sv) &= ~CVf_METHOD;
100                         else
101                             CvFLAGS((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 (SvTYPE(sv) == SVt_PVGV) {
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     PERL_UNUSED_ARG(cv);
154
155     if( items > 1 )
156         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
157
158     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
159     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
160     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
161     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
162
163     XSRETURN(0);
164 }
165
166 XS(XS_attributes__modify_attrs)
167 {
168     dVAR;
169     dXSARGS;
170     SV *rv, *sv;
171     PERL_UNUSED_ARG(cv);
172
173     if (items < 1) {
174 usage:
175         Perl_croak(aTHX_
176                    "Usage: attributes::_modify_attrs $reference, @attributes");
177     }
178
179     rv = ST(0);
180     if (!(SvOK(rv) && SvROK(rv)))
181         goto usage;
182     sv = SvRV(rv);
183     if (items > 1)
184         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
185
186     XSRETURN(0);
187 }
188
189 XS(XS_attributes__fetch_attrs)
190 {
191     dVAR;
192     dXSARGS;
193     SV *rv, *sv;
194     cv_flags_t cvflags;
195     PERL_UNUSED_ARG(cv);
196
197     if (items != 1) {
198 usage:
199         Perl_croak(aTHX_
200                    "Usage: attributes::_fetch_attrs $reference");
201     }
202
203     rv = ST(0);
204     SP -= items;
205     if (!(SvOK(rv) && SvROK(rv)))
206         goto usage;
207     sv = SvRV(rv);
208
209     switch (SvTYPE(sv)) {
210     case SVt_PVCV:
211         cvflags = CvFLAGS((CV*)sv);
212         if (cvflags & CVf_LOCKED)
213             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
214 #ifdef CVf_LVALUE
215         if (cvflags & CVf_LVALUE)
216             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
217 #endif
218         if (cvflags & CVf_METHOD)
219             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
220         if (GvUNIQUE(CvGV((CV*)sv)))
221             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
222         break;
223     case SVt_PVGV:
224         if (GvUNIQUE(sv))
225             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
226         break;
227     default:
228         break;
229     }
230
231     PUTBACK;
232 }
233
234 XS(XS_attributes__guess_stash)
235 {
236     dVAR;
237     dXSARGS;
238     SV *rv, *sv;
239     dXSTARG;
240     PERL_UNUSED_ARG(cv);
241
242     if (items != 1) {
243 usage:
244         Perl_croak(aTHX_
245                    "Usage: attributes::_guess_stash $reference");
246     }
247
248     rv = ST(0);
249     ST(0) = TARG;
250     if (!(SvOK(rv) && SvROK(rv)))
251         goto usage;
252     sv = SvRV(rv);
253
254     if (SvOBJECT(sv))
255         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
256 #if 0   /* this was probably a bad idea */
257     else if (SvPADMY(sv))
258         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
259 #endif
260     else {
261         const HV *stash = NULL;
262         switch (SvTYPE(sv)) {
263         case SVt_PVCV:
264             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
265                 stash = GvSTASH(CvGV(sv));
266             else if (/* !CvANON(sv) && */ CvSTASH(sv))
267                 stash = CvSTASH(sv);
268             break;
269         case SVt_PVGV:
270             if (GvGP(sv) && GvESTASH((GV*)sv))
271                 stash = GvESTASH((GV*)sv);
272             break;
273         default:
274             break;
275         }
276         if (stash)
277             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
278     }
279
280     SvSETMAGIC(TARG);
281     XSRETURN(1);
282 }
283
284 XS(XS_attributes_reftype)
285 {
286     dVAR;
287     dXSARGS;
288     SV *rv, *sv;
289     dXSTARG;
290     PERL_UNUSED_ARG(cv);
291
292     if (items != 1) {
293 usage:
294         Perl_croak(aTHX_
295                    "Usage: attributes::reftype $reference");
296     }
297
298     rv = ST(0);
299     ST(0) = TARG;
300     SvGETMAGIC(rv);
301     if (!(SvOK(rv) && SvROK(rv)))
302         goto usage;
303     sv = SvRV(rv);
304     sv_setpv(TARG, sv_reftype(sv, 0));
305     SvSETMAGIC(TARG);
306
307     XSRETURN(1);
308 }
309
310 /*
311  * Local variables:
312  * c-indentation-style: bsd
313  * c-basic-offset: 4
314  * indent-tabs-mode: t
315  * End:
316  *
317  * ex: set ts=8 sts=4 sw=4 noet:
318  */