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