More efficient API choices for string appending.
[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 #ifdef CVf_LVALUE
79                 case 'l':
80                     if (memEQ(name, "lvalue", 6)) {
81                         if (negated)
82                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
83                         else
84                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
85                         continue;
86                     }
87                     break;
88 #endif
89                 case 'k':
90                     if (memEQ(name, "locked", 6)) {
91                         if (negated)
92                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LOCKED;
93                         else
94                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LOCKED;
95                         continue;
96                     }
97                     break;
98                 case 'h':
99                     if (memEQ(name, "method", 6)) {
100                         if (negated)
101                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
102                         else
103                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
104                         continue;
105                     }
106                     break;
107                 }
108                 break;
109             }
110             break;
111         default:
112             switch ((int)len) {
113             case 6:
114                 switch (name[5]) {
115                 case 'd':
116                     if (memEQ(name, "share", 5)) {
117                         if (negated)
118                             Perl_croak(aTHX_ "A variable may not be unshared");
119                         SvSHARE(sv);
120                         continue;
121                     }
122                     break;
123                 case 'e':
124                     if (memEQ(name, "uniqu", 5)) {
125                         if (isGV_with_GP(sv)) {
126                             if (negated) {
127                                 GvUNIQUE_off(sv);
128                             } else {
129                                 GvUNIQUE_on(sv);
130                             }
131                         }
132                         /* Hope this came from toke.c if not a GV. */
133                         continue;
134                     }
135                 }
136             }
137             break;
138         }
139         /* anything recognized had a 'continue' above */
140         *retlist++ = attr;
141         nret++;
142     }
143
144     return nret;
145 }
146
147
148
149 /* package attributes; */
150
151 XS(XS_attributes_bootstrap)
152 {
153     dVAR;
154     dXSARGS;
155
156     if( items > 1 )
157         croak_xs_usage(cv, "$module");
158
159     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
160     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
161     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
162     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
163
164     XSRETURN(0);
165 }
166
167 XS(XS_attributes__modify_attrs)
168 {
169     dVAR;
170     dXSARGS;
171     SV *rv, *sv;
172
173     if (items < 1) {
174 usage:
175         croak_xs_usage(cv, "@attributes");
176     }
177
178     rv = ST(0);
179     if (!(SvOK(rv) && SvROK(rv)))
180         goto usage;
181     sv = SvRV(rv);
182     if (items > 1)
183         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
184
185     XSRETURN(0);
186 }
187
188 XS(XS_attributes__fetch_attrs)
189 {
190     dVAR;
191     dXSARGS;
192     SV *rv, *sv;
193     cv_flags_t cvflags;
194
195     if (items != 1) {
196 usage:
197         croak_xs_usage(cv, "$reference");
198     }
199
200     rv = ST(0);
201     SP -= items;
202     if (!(SvOK(rv) && SvROK(rv)))
203         goto usage;
204     sv = SvRV(rv);
205
206     switch (SvTYPE(sv)) {
207     case SVt_PVCV:
208         cvflags = CvFLAGS((const CV *)sv);
209         if (cvflags & CVf_LOCKED)
210             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
211 #ifdef CVf_LVALUE
212         if (cvflags & CVf_LVALUE)
213             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
214 #endif
215         if (cvflags & CVf_METHOD)
216             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
217         if (GvUNIQUE(CvGV((const CV *)sv)))
218             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
219         break;
220     case SVt_PVGV:
221         if (isGV_with_GP(sv) && GvUNIQUE(sv))
222             XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
223         break;
224     default:
225         break;
226     }
227
228     PUTBACK;
229 }
230
231 XS(XS_attributes__guess_stash)
232 {
233     dVAR;
234     dXSARGS;
235     SV *rv, *sv;
236     dXSTARG;
237
238     if (items != 1) {
239 usage:
240         croak_xs_usage(cv, "$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_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(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         const HV *stash = NULL;
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_PVGV:
265             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
266                 stash = GvESTASH(MUTABLE_GV(sv));
267             break;
268         default:
269             break;
270         }
271         if (stash)
272             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
273     }
274
275     SvSETMAGIC(TARG);
276     XSRETURN(1);
277 }
278
279 XS(XS_attributes_reftype)
280 {
281     dVAR;
282     dXSARGS;
283     SV *rv, *sv;
284     dXSTARG;
285
286     if (items != 1) {
287 usage:
288         croak_xs_usage(cv, "$reference");
289     }
290
291     rv = ST(0);
292     ST(0) = TARG;
293     SvGETMAGIC(rv);
294     if (!(SvOK(rv) && SvROK(rv)))
295         goto usage;
296     sv = SvRV(rv);
297     sv_setpv(TARG, sv_reftype(sv, 0));
298     SvSETMAGIC(TARG);
299
300     XSRETURN(1);
301 }
302
303 /*
304  * Local variables:
305  * c-indentation-style: bsd
306  * c-basic-offset: 4
307  * indent-tabs-mode: t
308  * End:
309  *
310  * ex: set ts=8 sts=4 sw=4 noet:
311  */