staticperl/perl/xsutils.c

/*    xsutils.c
 *
 *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
 *    by Larry Wall and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 * "Perilous to us all are the devices of an art deeper than we possess
 * ourselves." --Gandalf
 */


#include "EXTERN.h"
#define PERL_IN_XSUTILS_C
#include "perl.h"

/*
 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
 */

/* package attributes; */
void XS_attributes__warn_reserved(pTHX_ CV *cv);
void XS_attributes_reftype(pTHX_ CV *cv);
void XS_attributes__modify_attrs(pTHX_ CV *cv);
void XS_attributes__guess_stash(pTHX_ CV *cv);
void XS_attributes__fetch_attrs(pTHX_ CV *cv);
void XS_attributes_bootstrap(pTHX_ CV *cv);


/*
 * Note that only ${pkg}::bootstrap definitions should go here.
 * This helps keep down the start-up time, which is especially
 * relevant for users who don't invoke any features which are
 * (partially) implemented here.
 *
 * The various bootstrap definitions can take care of doing
 * package-specific newXS() calls.  Since the layout of the
 * bundled *.pm files is in a version-specific directory,
 * version checks in these bootstrap calls are optional.
 */

void
Perl_boot_core_xsutils(pTHX)
{
    char *file = __FILE__;

    newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
}

#include "XSUB.h"

static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
    SV *attr;
    char *name;
    STRLEN len;
    bool negated;
    int nret;

    for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
        name = SvPV(attr, len);
        if ((negated = (*name == '-'))) {
            name++;
            len--;
        }
        switch (SvTYPE(sv)) {
        case SVt_PVCV:
            switch ((int)len) {
#ifdef CVf_ASSERTION
            case 9:
                if (memEQ(name, "assertion", 9)) {
                    if (negated)
                        CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
                    else
                        CvFLAGS((CV*)sv) |= CVf_ASSERTION;
                    continue;
                }
                break;
#endif
            case 6:
                switch (name[3]) {
                case 'l':
#ifdef CVf_LVALUE
                    if (memEQ(name, "lvalue", 6)) {
                        if (negated)
                            CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
                        else
                            CvFLAGS((CV*)sv) |= CVf_LVALUE;
                        continue;
                    }
                    break;
                case 'k':
#endif /* defined CVf_LVALUE */
                    if (memEQ(name, "locked", 6)) {
                        if (negated)
                            CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
                        else
                            CvFLAGS((CV*)sv) |= CVf_LOCKED;
                        continue;
                    }
                    break;
                case 'h':
                    if (memEQ(name, "method", 6)) {
                        if (negated)
                            CvFLAGS((CV*)sv) &= ~CVf_METHOD;
                        else
                            CvFLAGS((CV*)sv) |= CVf_METHOD;
                        continue;
                    }
                    break;
                }
                break;
            }
            break;
        default:
            switch ((int)len) {
            case 6:
                switch (name[5]) {
                case 'd':
                    if (memEQ(name, "share", 5)) {
                        if (negated)
                            Perl_croak(aTHX_ "A variable may not be unshared");
                        SvSHARE(sv);
                        continue;
                    }
                    break;
                case 'e':
                    if (memEQ(name, "uniqu", 5)) {
                        if (SvTYPE(sv) == SVt_PVGV) {
                            if (negated)
                                GvUNIQUE_off(sv);
                            else
                                GvUNIQUE_on(sv);
                        }
                        /* Hope this came from toke.c if not a GV. */
                        continue;
                    }
                }
            }
            break;
        }
        /* anything recognized had a 'continue' above */
        *retlist++ = attr;
        nret++;
    }

    return nret;
}


/* package attributes; */

XS(XS_attributes_bootstrap)
{
    dXSARGS;
    char *file = __FILE__;

    if( items > 1 )
        Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");

    newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
    newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
    newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
    newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
    newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");

    XSRETURN(0);
}

XS(XS_attributes__modify_attrs)
{
    dXSARGS;
    SV *rv, *sv;

    if (items < 1) {
usage:
        Perl_croak(aTHX_
                   "Usage: attributes::_modify_attrs $reference, @attributes");
    }

    rv = ST(0);
    if (!(SvOK(rv) && SvROK(rv)))
        goto usage;
    sv = SvRV(rv);
    if (items > 1)
        XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));

    XSRETURN(0);
}

XS(XS_attributes__fetch_attrs)
{
    dXSARGS;
    SV *rv, *sv;
    cv_flags_t cvflags;

    if (items != 1) {
usage:
        Perl_croak(aTHX_
                   "Usage: attributes::_fetch_attrs $reference");
    }

    rv = ST(0);
    SP -= items;
    if (!(SvOK(rv) && SvROK(rv)))
        goto usage;
    sv = SvRV(rv);

    switch (SvTYPE(sv)) {
    case SVt_PVCV:
        cvflags = CvFLAGS((CV*)sv);
        if (cvflags & CVf_LOCKED)
            XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
#ifdef CVf_LVALUE
        if (cvflags & CVf_LVALUE)
            XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
#endif
        if (cvflags & CVf_METHOD)
            XPUSHs(sv_2mortal(newSVpvn("method", 6)));
        if (GvUNIQUE(CvGV((CV*)sv)))
            XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
        break;
    case SVt_PVGV:
        if (GvUNIQUE(sv))
            XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
        break;
    default:
        break;
    }

    PUTBACK;
}

XS(XS_attributes__guess_stash)
{
    dXSARGS;
    SV *rv, *sv;
    dXSTARG;

    if (items != 1) {
usage:
        Perl_croak(aTHX_
                   "Usage: attributes::_guess_stash $reference");
    }

    rv = ST(0);
    ST(0) = TARG;
    if (!(SvOK(rv) && SvROK(rv)))
        goto usage;
    sv = SvRV(rv);

    if (SvOBJECT(sv))
        sv_setpv(TARG, HvNAME(SvSTASH(sv)));
#if 0   /* this was probably a bad idea */
    else if (SvPADMY(sv))
        sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
#endif
    else {
        HV *stash = Nullhv;
        switch (SvTYPE(sv)) {
        case SVt_PVCV:
            if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
                stash = GvSTASH(CvGV(sv));
            else if (/* !CvANON(sv) && */ CvSTASH(sv))
                stash = CvSTASH(sv);
            break;
        case SVt_PVMG:
            if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
                break;
            /*FALLTHROUGH*/
        case SVt_PVGV:
            if (GvGP(sv) && GvESTASH((GV*)sv))
                stash = GvESTASH((GV*)sv);
            break;
        default:
            break;
        }
        if (stash)
            sv_setpv(TARG, HvNAME(stash));
    }

    SvSETMAGIC(TARG);
    XSRETURN(1);
}

XS(XS_attributes_reftype)
{
    dXSARGS;
    SV *rv, *sv;
    dXSTARG;

    if (items != 1) {
usage:
        Perl_croak(aTHX_
                   "Usage: attributes::reftype $reference");
    }

    rv = ST(0);
    ST(0) = TARG;
    if (SvGMAGICAL(rv))
        mg_get(rv);
    if (!(SvOK(rv) && SvROK(rv)))
        goto usage;
    sv = SvRV(rv);
    sv_setpv(TARG, sv_reftype(sv, 0));
    SvSETMAGIC(TARG);

    XSRETURN(1);
}

XS(XS_attributes__warn_reserved)
{
    dXSARGS;

    if (items != 0) {
        Perl_croak(aTHX_
                   "Usage: attributes::_warn_reserved ()");
    }

    EXTEND(SP,1);
    ST(0) = boolSV(ckWARN(WARN_RESERVED));

    XSRETURN(1);
}

Revision:	1.1
Committed:	Thu Jun 30 14:26:43 2005 UTC (21 years, 3 months ago) by root
Content type:	text/plain
Branch:	MAIN
CVS Tags:	PERL-5-8-7, HEAD
Branch point for:	PERL
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	/* xsutils.c
2			*
3			* Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
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			void XS_attributes__warn_reserved(pTHX_ CV *cv);
27			void XS_attributes_reftype(pTHX_ CV *cv);
28			void XS_attributes__modify_attrs(pTHX_ CV *cv);
29			void XS_attributes__guess_stash(pTHX_ CV *cv);
30			void XS_attributes__fetch_attrs(pTHX_ CV *cv);
31			void XS_attributes_bootstrap(pTHX_ CV *cv);
32
33
34			/*
35			* Note that only ${pkg}::bootstrap definitions should go here.
36			* This helps keep down the start-up time, which is especially
37			* relevant for users who don't invoke any features which are
38			* (partially) implemented here.
39			*
40			* The various bootstrap definitions can take care of doing
41			* package-specific newXS() calls. Since the layout of the
42			* bundled *.pm files is in a version-specific directory,
43			* version checks in these bootstrap calls are optional.
44			*/
45
46			void
47			Perl_boot_core_xsutils(pTHX)
48			{
49			char *file = __FILE__;
50
51			newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
52			}
53
54			#include "XSUB.h"
55
56			static int
57			modify_SV_attributes(pTHX_ SV sv, SV retlist, SV *attrlist, int numattrs)
58			{
59			SV *attr;
60			char *name;
61			STRLEN len;
62			bool negated;
63			int nret;
64
65			for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
66			name = SvPV(attr, len);
67			if ((negated = (*name == '-'))) {
68			name++;
69			len--;
70			}
71			switch (SvTYPE(sv)) {
72			case SVt_PVCV:
73			switch ((int)len) {
74			#ifdef CVf_ASSERTION
75			case 9:
76			if (memEQ(name, "assertion", 9)) {
77			if (negated)
78			CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
79			else
80			CvFLAGS((CV*)sv) \|= CVf_ASSERTION;
81			continue;
82			}
83			break;
84			#endif
85			case 6:
86			switch (name[3]) {
87			case 'l':
88			#ifdef CVf_LVALUE
89			if (memEQ(name, "lvalue", 6)) {
90			if (negated)
91			CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
92			else
93			CvFLAGS((CV*)sv) \|= CVf_LVALUE;
94			continue;
95			}
96			break;
97			case 'k':
98			#endif /* defined CVf_LVALUE */
99			if (memEQ(name, "locked", 6)) {
100			if (negated)
101			CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
102			else
103			CvFLAGS((CV*)sv) \|= CVf_LOCKED;
104			continue;
105			}
106			break;
107			case 'h':
108			if (memEQ(name, "method", 6)) {
109			if (negated)
110			CvFLAGS((CV*)sv) &= ~CVf_METHOD;
111			else
112			CvFLAGS((CV*)sv) \|= CVf_METHOD;
113			continue;
114			}
115			break;
116			}
117			break;
118			}
119			break;
120			default:
121			switch ((int)len) {
122			case 6:
123			switch (name[5]) {
124			case 'd':
125			if (memEQ(name, "share", 5)) {
126			if (negated)
127			Perl_croak(aTHX_ "A variable may not be unshared");
128			SvSHARE(sv);
129			continue;
130			}
131			break;
132			case 'e':
133			if (memEQ(name, "uniqu", 5)) {
134			if (SvTYPE(sv) == SVt_PVGV) {
135			if (negated)
136			GvUNIQUE_off(sv);
137			else
138			GvUNIQUE_on(sv);
139			}
140			/* Hope this came from toke.c if not a GV. */
141			continue;
142			}
143			}
144			}
145			break;
146			}
147			/* anything recognized had a 'continue' above */
148			*retlist++ = attr;
149			nret++;
150			}
151
152			return nret;
153			}
154
155
156
157			/* package attributes; */
158
159			XS(XS_attributes_bootstrap)
160			{
161			dXSARGS;
162			char *file = __FILE__;
163
164			if( items > 1 )
165			Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
166
167			newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
168			newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
169			newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
170			newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
171			newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
172
173			XSRETURN(0);
174			}
175
176			XS(XS_attributes__modify_attrs)
177			{
178			dXSARGS;
179			SV rv, sv;
180
181			if (items < 1) {
182			usage:
183			Perl_croak(aTHX_
184			"Usage: attributes::_modify_attrs $reference, @attributes");
185			}
186
187			rv = ST(0);
188			if (!(SvOK(rv) && SvROK(rv)))
189			goto usage;
190			sv = SvRV(rv);
191			if (items > 1)
192			XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
193
194			XSRETURN(0);
195			}
196
197			XS(XS_attributes__fetch_attrs)
198			{
199			dXSARGS;
200			SV rv, sv;
201			cv_flags_t cvflags;
202
203			if (items != 1) {
204			usage:
205			Perl_croak(aTHX_
206			"Usage: attributes::_fetch_attrs $reference");
207			}
208
209			rv = ST(0);
210			SP -= items;
211			if (!(SvOK(rv) && SvROK(rv)))
212			goto usage;
213			sv = SvRV(rv);
214
215			switch (SvTYPE(sv)) {
216			case SVt_PVCV:
217			cvflags = CvFLAGS((CV*)sv);
218			if (cvflags & CVf_LOCKED)
219			XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
220			#ifdef CVf_LVALUE
221			if (cvflags & CVf_LVALUE)
222			XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
223			#endif
224			if (cvflags & CVf_METHOD)
225			XPUSHs(sv_2mortal(newSVpvn("method", 6)));
226			if (GvUNIQUE(CvGV((CV*)sv)))
227			XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
228			break;
229			case SVt_PVGV:
230			if (GvUNIQUE(sv))
231			XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
232			break;
233			default:
234			break;
235			}
236
237			PUTBACK;
238			}
239
240			XS(XS_attributes__guess_stash)
241			{
242			dXSARGS;
243			SV rv, sv;
244			dXSTARG;
245
246			if (items != 1) {
247			usage:
248			Perl_croak(aTHX_
249			"Usage: attributes::_guess_stash $reference");
250			}
251
252			rv = ST(0);
253			ST(0) = TARG;
254			if (!(SvOK(rv) && SvROK(rv)))
255			goto usage;
256			sv = SvRV(rv);
257
258			if (SvOBJECT(sv))
259			sv_setpv(TARG, HvNAME(SvSTASH(sv)));
260			#if 0 /* this was probably a bad idea */
261			else if (SvPADMY(sv))
262			sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
263			#endif
264			else {
265			HV *stash = Nullhv;
266			switch (SvTYPE(sv)) {
267			case SVt_PVCV:
268			if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
269			stash = GvSTASH(CvGV(sv));
270			else if (/* !CvANON(sv) && */ CvSTASH(sv))
271			stash = CvSTASH(sv);
272			break;
273			case SVt_PVMG:
274			if (!(SvFAKE(sv) && SvTIED_mg(sv, PERL_MAGIC_glob)))
275			break;
276			/FALLTHROUGH/
277			case SVt_PVGV:
278			if (GvGP(sv) && GvESTASH((GV*)sv))
279			stash = GvESTASH((GV*)sv);
280			break;
281			default:
282			break;
283			}
284			if (stash)
285			sv_setpv(TARG, HvNAME(stash));
286			}
287
288			SvSETMAGIC(TARG);
289			XSRETURN(1);
290			}
291
292			XS(XS_attributes_reftype)
293			{
294			dXSARGS;
295			SV rv, sv;
296			dXSTARG;
297
298			if (items != 1) {
299			usage:
300			Perl_croak(aTHX_
301			"Usage: attributes::reftype $reference");
302			}
303
304			rv = ST(0);
305			ST(0) = TARG;
306			if (SvGMAGICAL(rv))
307			mg_get(rv);
308			if (!(SvOK(rv) && SvROK(rv)))
309			goto usage;
310			sv = SvRV(rv);
311			sv_setpv(TARG, sv_reftype(sv, 0));
312			SvSETMAGIC(TARG);
313
314			XSRETURN(1);
315			}
316
317			XS(XS_attributes__warn_reserved)
318			{
319			dXSARGS;
320
321			if (items != 0) {
322			Perl_croak(aTHX_
323			"Usage: attributes::_warn_reserved ()");
324			}
325
326			EXTEND(SP,1);
327			ST(0) = boolSV(ckWARN(WARN_RESERVED));
328
329			XSRETURN(1);
330			}
331