f7eb6e0505a90da03c8d5a685f4198e79bce5b26
[perl.git] / ext / attributes / attributes.xs
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
27 static int
28 modify_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
87 MODULE = attributes             PACKAGE = attributes
88
89 void
90 _modify_attrs(...)
91   PREINIT:
92     SV *rv, *sv;
93   PPCODE:
94
95     if (items < 1) {
96 usage:
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
109 void
110 _fetch_attrs(...)
111   PREINIT:
112     SV *rv, *sv;
113     cv_flags_t cvflags;
114   PPCODE:
115     if (items != 1) {
116 usage:
117         croak_xs_usage(cv, "$reference");
118     }
119
120     rv = ST(0);
121     if (!(SvOK(rv) && SvROK(rv)))
122         goto usage;
123     sv = SvRV(rv);
124
125     switch (SvTYPE(sv)) {
126     case SVt_PVCV:
127         cvflags = CvFLAGS((const CV *)sv);
128         if (cvflags & CVf_LOCKED)
129             XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
130         if (cvflags & CVf_LVALUE)
131             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
132         if (cvflags & CVf_METHOD)
133             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
134         break;
135     default:
136         break;
137     }
138
139     PUTBACK;
140
141 void
142 _guess_stash(...)
143   PREINIT:
144     SV *rv, *sv;
145     dXSTARG;
146   PPCODE:
147     if (items != 1) {
148 usage:
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
187 void
188 reftype(...)
189   PREINIT:
190     SV *rv, *sv;
191     dXSTARG;
192   PPCODE:
193     if (items != 1) {
194 usage:
195         croak_xs_usage(cv, "$reference");
196     }
197
198     rv = ST(0);
199     ST(0) = TARG;
200     SvGETMAGIC(rv);
201     if (!(SvOK(rv) && SvROK(rv)))
202         goto usage;
203     sv = SvRV(rv);
204     sv_setpv(TARG, sv_reftype(sv, 0));
205     SvSETMAGIC(TARG);
206
207     XSRETURN(1);
208 /*
209  * Local variables:
210  * c-indentation-style: bsd
211  * c-basic-offset: 4
212  * indent-tabs-mode: t
213  * End:
214  *
215  * ex: set ts=8 sts=4 sw=4 noet:
216  */