source: trunk/third/perl/xsutils.c @ 20075

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