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