This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
handy.h: Make uniform the defns of strFOO, memFOO
[perl5.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 #define PERL_NO_GET_CONTEXT
19
20 #include "EXTERN.h"
21 #include "perl.h"
22 #include "XSUB.h"
23
24 /*
25  * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
26  */
27
28 static int
29 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
30 {
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 5:
47                 if (memEQs(name, 5, "const")) {
48                     if (negated)
49                         CvANONCONST_off(sv);
50                     else {
51                         const bool warn = (!CvANON(sv) || CvCLONED(sv))
52                                        && !CvANONCONST(sv);
53                         CvANONCONST_on(sv);
54                         if (warn)
55                             break;
56                     }
57                     continue;
58                 }
59                 break;
60             case 6:
61                 switch (name[3]) {
62                 case 'l':
63                     if (memEQs(name, 6, "lvalue")) {
64                         bool warn =
65                             !CvISXSUB(MUTABLE_CV(sv))
66                          && CvROOT(MUTABLE_CV(sv))
67                          && !CvLVALUE(MUTABLE_CV(sv)) != negated;
68                         if (negated)
69                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
70                         else
71                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
72                         if (warn) break;
73                         continue;
74                     }
75                     break;
76                 case 'h':
77                     if (memEQs(name, 6, "method")) {
78                         if (negated)
79                             CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
80                         else
81                             CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
82                         continue;
83                     }
84                     break;
85                 }
86                 break;
87             default:
88                 if (memBEGINPs(name, len, "prototype(")) {
89                     const STRLEN proto_len = sizeof("prototype(") - 1;
90                     SV * proto = newSVpvn(name + proto_len, len - proto_len - 1);
91                     HEK *const hek = CvNAME_HEK((CV *)sv);
92                     SV *subname;
93                     if (name[len-1] != ')')
94                         Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
95                     if (hek)
96                         subname = sv_2mortal(newSVhek(hek));
97                     else
98                         subname=(SV *)CvGV((const CV *)sv);
99                     if (ckWARN(WARN_ILLEGALPROTO))
100                         Perl_validate_proto(aTHX_ subname, proto, TRUE, 0);
101                     Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
102                                                     (const GV *)subname,
103                                                     name+10,
104                                                     len-11,
105                                                     SvUTF8(attr));
106                     sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
107                     if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
108                     continue;
109                 }
110                 break;
111             }
112             break;
113         default:
114             if (memEQs(name, len, "shared")) {
115                         if (negated)
116                             Perl_croak(aTHX_ "A variable may not be unshared");
117                         SvSHARE(sv);
118                         continue;
119             }
120             break;
121         }
122         /* anything recognized had a 'continue' above */
123         *retlist++ = attr;
124         nret++;
125     }
126
127     return nret;
128 }
129
130 MODULE = attributes             PACKAGE = attributes
131
132 void
133 _modify_attrs(...)
134   PREINIT:
135     SV *rv, *sv;
136   PPCODE:
137
138     if (items < 1) {
139 usage:
140         croak_xs_usage(cv, "@attributes");
141     }
142
143     rv = ST(0);
144     if (!(SvOK(rv) && SvROK(rv)))
145         goto usage;
146     sv = SvRV(rv);
147     if (items > 1)
148         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
149
150     XSRETURN(0);
151
152 void
153 _fetch_attrs(...)
154   PROTOTYPE: $
155   PREINIT:
156     SV *rv, *sv;
157     cv_flags_t cvflags;
158   PPCODE:
159     if (items != 1) {
160 usage:
161         croak_xs_usage(cv, "$reference");
162     }
163
164     rv = ST(0);
165     if (!(SvOK(rv) && SvROK(rv)))
166         goto usage;
167     sv = SvRV(rv);
168
169     switch (SvTYPE(sv)) {
170     case SVt_PVCV:
171         cvflags = CvFLAGS((const CV *)sv);
172         if (cvflags & CVf_LVALUE)
173             XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
174         if (cvflags & CVf_METHOD)
175             XPUSHs(newSVpvs_flags("method", SVs_TEMP));
176         break;
177     default:
178         break;
179     }
180
181     PUTBACK;
182
183 void
184 _guess_stash(...)
185   PROTOTYPE: $
186   PREINIT:
187     SV *rv, *sv;
188     dXSTARG;
189   PPCODE:
190     if (items != 1) {
191 usage:
192         croak_xs_usage(cv, "$reference");
193     }
194
195     rv = ST(0);
196     ST(0) = TARG;
197     if (!(SvOK(rv) && SvROK(rv)))
198         goto usage;
199     sv = SvRV(rv);
200
201     if (SvOBJECT(sv))
202         Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(SvSTASH(sv)));
203 #if 0   /* this was probably a bad idea */
204     else if (SvPADMY(sv))
205         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
206 #endif
207     else {
208         const HV *stash = NULL;
209         switch (SvTYPE(sv)) {
210         case SVt_PVCV:
211             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
212                 stash = GvSTASH(CvGV(sv));
213             else if (/* !CvANON(sv) && */ CvSTASH(sv))
214                 stash = CvSTASH(sv);
215             break;
216         case SVt_PVGV:
217             if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
218                 stash = GvESTASH(MUTABLE_GV(sv));
219             break;
220         default:
221             break;
222         }
223         if (stash)
224             Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(stash));
225     }
226
227     SvSETMAGIC(TARG);
228     XSRETURN(1);
229
230 void
231 reftype(...)
232   PROTOTYPE: $
233   PREINIT:
234     SV *rv, *sv;
235     dXSTARG;
236   PPCODE:
237     if (items != 1) {
238 usage:
239         croak_xs_usage(cv, "$reference");
240     }
241
242     rv = ST(0);
243     ST(0) = TARG;
244     SvGETMAGIC(rv);
245     if (!(SvOK(rv) && SvROK(rv)))
246         goto usage;
247     sv = SvRV(rv);
248     sv_setpv(TARG, sv_reftype(sv, 0));
249     SvSETMAGIC(TARG);
250
251     XSRETURN(1);
252 /*
253  * ex: set ts=8 sts=4 sw=4 et:
254  */