attributes.xs revision 1.1 
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#include "perl.h"
21#include "XSUB.h"
22
23/*
24 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
25 */
26
27static int
28modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
29{
30    dVAR;
31    SV *attr;
32    int nret;
33
34    for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
35	STRLEN len;
36	const char *name = SvPV_const(attr, len);
37	const bool negated = (*name == '-');
38
39	if (negated) {
40	    name++;
41	    len--;
42	}
43	switch (SvTYPE(sv)) {
44	case SVt_PVCV:
45	    switch ((int)len) {
46	    case 6:
47		switch (name[3]) {
48		case 'l':
49		    if (memEQ(name, "lvalue", 6)) {
50			if (negated)
51			    CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
52			else
53			    CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
54			continue;
55		    }
56		    break;
57		case 'h':
58		    if (memEQ(name, "method", 6)) {
59			if (negated)
60			    CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
61			else
62			    CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
63			continue;
64		    }
65		    break;
66		}
67		break;
68	    }
69	    break;
70	default:
71	    if (memEQs(name, 6, "shared")) {
72			if (negated)
73			    Perl_croak(aTHX_ "A variable may not be unshared");
74			SvSHARE(sv);
75                        continue;
76	    }
77	    break;
78	}
79	/* anything recognized had a 'continue' above */
80	*retlist++ = attr;
81	nret++;
82    }
83
84    return nret;
85}
86
87MODULE = attributes		PACKAGE = attributes
88
89void
90_modify_attrs(...)
91  PREINIT:
92    SV *rv, *sv;
93  PPCODE:
94
95    if (items < 1) {
96usage:
97	croak_xs_usage(cv, "@attributes");
98    }
99
100    rv = ST(0);
101    if (!(SvOK(rv) && SvROK(rv)))
102	goto usage;
103    sv = SvRV(rv);
104    if (items > 1)
105	XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
106
107    XSRETURN(0);
108
109void
110_fetch_attrs(...)
111  PROTOTYPE: $
112  PREINIT:
113    SV *rv, *sv;
114    cv_flags_t cvflags;
115  PPCODE:
116    if (items != 1) {
117usage:
118	croak_xs_usage(cv, "$reference");
119    }
120
121    rv = ST(0);
122    if (!(SvOK(rv) && SvROK(rv)))
123	goto usage;
124    sv = SvRV(rv);
125
126    switch (SvTYPE(sv)) {
127    case SVt_PVCV:
128	cvflags = CvFLAGS((const CV *)sv);
129	if (cvflags & CVf_LVALUE)
130	    XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
131	if (cvflags & CVf_METHOD)
132	    XPUSHs(newSVpvs_flags("method", SVs_TEMP));
133	break;
134    default:
135	break;
136    }
137
138    PUTBACK;
139
140void
141_guess_stash(...)
142  PROTOTYPE: $
143  PREINIT:
144    SV *rv, *sv;
145    dXSTARG;
146  PPCODE:
147    if (items != 1) {
148usage:
149	croak_xs_usage(cv, "$reference");
150    }
151
152    rv = ST(0);
153    ST(0) = TARG;
154    if (!(SvOK(rv) && SvROK(rv)))
155	goto usage;
156    sv = SvRV(rv);
157
158    if (SvOBJECT(sv))
159	sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
160#if 0	/* this was probably a bad idea */
161    else if (SvPADMY(sv))
162	sv_setsv(TARG, &PL_sv_no);	/* unblessed lexical */
163#endif
164    else {
165	const HV *stash = NULL;
166	switch (SvTYPE(sv)) {
167	case SVt_PVCV:
168	    if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
169		stash = GvSTASH(CvGV(sv));
170	    else if (/* !CvANON(sv) && */ CvSTASH(sv))
171		stash = CvSTASH(sv);
172	    break;
173	case SVt_PVGV:
174	    if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
175		stash = GvESTASH(MUTABLE_GV(sv));
176	    break;
177	default:
178	    break;
179	}
180	if (stash)
181	    sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
182    }
183
184    SvSETMAGIC(TARG);
185    XSRETURN(1);
186
187void
188reftype(...)
189  PROTOTYPE: $
190  PREINIT:
191    SV *rv, *sv;
192    dXSTARG;
193  PPCODE:
194    if (items != 1) {
195usage:
196	croak_xs_usage(cv, "$reference");
197    }
198
199    rv = ST(0);
200    ST(0) = TARG;
201    SvGETMAGIC(rv);
202    if (!(SvOK(rv) && SvROK(rv)))
203	goto usage;
204    sv = SvRV(rv);
205    sv_setpv(TARG, sv_reftype(sv, 0));
206    SvSETMAGIC(TARG);
207
208    XSRETURN(1);
209/*
210 * Local variables:
211 * c-indentation-style: bsd
212 * c-basic-offset: 4
213 * indent-tabs-mode: t
214 * End:
215 *
216 * ex: set ts=8 sts=4 sw=4 noet:
217 */
218