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
CommitLineData
d6376244
JH
1/* xsutils.c
2 *
1129b882 3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
371fce9b 4 * by Larry Wall and others
d6376244
JH
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
d31a8517 11/*
4ac71550
TC
12 * 'Perilous to us all are the devices of an art deeper than we possess
13 * ourselves.' --Gandalf
14 *
cdad3b53 15 * [p.597 of _The Lord of the Rings_, III/xi: "The Palantír"]
d31a8517
AT
16 */
17
60895166
KW
18#define PERL_EXT
19
55cb46d5 20#define PERL_NO_GET_CONTEXT
d31a8517 21
09bef843 22#include "EXTERN.h"
09bef843 23#include "perl.h"
48462a74 24#include "XSUB.h"
09bef843
SB
25
26/*
27 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
28 */
29
349fd7b7 30static int
acfe0abc 31modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
09bef843
SB
32{
33 SV *attr;
09bef843
SB
34 int nret;
35
36 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
4373e329 37 STRLEN len;
cfd0369c 38 const char *name = SvPV_const(attr, len);
4373e329
AL
39 const bool negated = (*name == '-');
40
41 if (negated) {
09bef843
SB
42 name++;
43 len--;
44 }
45 switch (SvTYPE(sv)) {
46 case SVt_PVCV:
47 switch ((int)len) {
3108f4df 48 case 5:
b59bf0b2 49 if (memEQs(name, 5, "const")) {
3108f4df
FC
50 if (negated)
51 CvANONCONST_off(sv);
52 else {
64016071 53 const bool warn = (!CvANON(sv) || CvCLONED(sv))
3108f4df
FC
54 && !CvANONCONST(sv);
55 CvANONCONST_on(sv);
56 if (warn)
57 break;
58 }
59 continue;
60 }
61 break;
09bef843 62 case 6:
8cad210e 63 switch (name[3]) {
d5adc3a1 64 case 'l':
b59bf0b2 65 if (memEQs(name, 6, "lvalue")) {
345d70e3
FC
66 bool warn =
67 !CvISXSUB(MUTABLE_CV(sv))
bb3abb05 68 && CvROOT(MUTABLE_CV(sv))
4dcaa956 69 && cBOOL(CvLVALUE(MUTABLE_CV(sv))) == negated;
09bef843 70 if (negated)
ea726b52 71 CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
09bef843 72 else
ea726b52 73 CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
345d70e3 74 if (warn) break;
09bef843
SB
75 continue;
76 }
8cad210e 77 break;
8cad210e 78 case 'h':
b59bf0b2 79 if (memEQs(name, 6, "method")) {
09bef843 80 if (negated)
ea726b52 81 CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
09bef843 82 else
ea726b52 83 CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
09bef843
SB
84 continue;
85 }
86 break;
87 }
88 break;
eedb00fa 89 default:
de627158
KW
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);
eedb00fa
PM
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))
5783dc51 102 Perl_validate_proto(aTHX_ subname, proto, TRUE, 0);
eedb00fa
PM
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;
09bef843
SB
113 }
114 break;
115 default:
46fa4d93 116 if (memEQs(name, len, "shared")) {
13c1b207
DM
117 if (negated)
118 Perl_croak(aTHX_ "A variable may not be unshared");
119 SvSHARE(sv);
120 continue;
f1a3ce43 121 }
09bef843
SB
122 break;
123 }
124 /* anything recognized had a 'continue' above */
125 *retlist++ = attr;
126 nret++;
127 }
128
129 return nret;
130}
131
48462a74 132MODULE = attributes PACKAGE = attributes
09bef843 133
48462a74
NC
134void
135_modify_attrs(...)
136 PREINIT:
09bef843 137 SV *rv, *sv;
48462a74 138 PPCODE:
09bef843
SB
139
140 if (items < 1) {
141usage:
afa74d42 142 croak_xs_usage(cv, "@attributes");
09bef843
SB
143 }
144
145 rv = ST(0);
146 if (!(SvOK(rv) && SvROK(rv)))
147 goto usage;
148 sv = SvRV(rv);
149 if (items > 1)
acfe0abc 150 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843
SB
151
152 XSRETURN(0);
09bef843 153
48462a74
NC
154void
155_fetch_attrs(...)
6e0da8f3 156 PROTOTYPE: $
48462a74 157 PREINIT:
09bef843
SB
158 SV *rv, *sv;
159 cv_flags_t cvflags;
48462a74 160 PPCODE:
09bef843
SB
161 if (items != 1) {
162usage:
afa74d42 163 croak_xs_usage(cv, "$reference");
09bef843
SB
164 }
165
166 rv = ST(0);
09bef843
SB
167 if (!(SvOK(rv) && SvROK(rv)))
168 goto usage;
169 sv = SvRV(rv);
170
171 switch (SvTYPE(sv)) {
172 case SVt_PVCV:
ea726b52 173 cvflags = CvFLAGS((const CV *)sv);
09bef843 174 if (cvflags & CVf_LVALUE)
84bafc02 175 XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
09bef843 176 if (cvflags & CVf_METHOD)
84bafc02 177 XPUSHs(newSVpvs_flags("method", SVs_TEMP));
09bef843
SB
178 break;
179 default:
180 break;
181 }
182
183 PUTBACK;
09bef843 184
48462a74
NC
185void
186_guess_stash(...)
6e0da8f3 187 PROTOTYPE: $
48462a74 188 PREINIT:
09bef843 189 SV *rv, *sv;
d277572a 190 dXSTARG;
48462a74 191 PPCODE:
09bef843
SB
192 if (items != 1) {
193usage:
afa74d42 194 croak_xs_usage(cv, "$reference");
09bef843
SB
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))
89a5757c 204 Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(SvSTASH(sv)));
09bef843
SB
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 {
5c284bb0 210 const HV *stash = NULL;
09bef843
SB
211 switch (SvTYPE(sv)) {
212 case SVt_PVCV:
6676db26 213 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843 214 stash = GvSTASH(CvGV(sv));
6676db26 215 else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843
SB
216 stash = CvSTASH(sv);
217 break;
09bef843 218 case SVt_PVGV:
159b6efe
NC
219 if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
220 stash = GvESTASH(MUTABLE_GV(sv));
09bef843
SB
221 break;
222 default:
223 break;
224 }
225 if (stash)
89a5757c 226 Perl_sv_sethek(aTHX_ TARG, HvNAME_HEK(stash));
09bef843
SB
227 }
228
09bef843 229 SvSETMAGIC(TARG);
09bef843 230 XSRETURN(1);
09bef843 231
48462a74
NC
232void
233reftype(...)
6e0da8f3 234 PROTOTYPE: $
48462a74 235 PREINIT:
09bef843 236 SV *rv, *sv;
d277572a 237 dXSTARG;
48462a74 238 PPCODE:
09bef843
SB
239 if (items != 1) {
240usage:
afa74d42 241 croak_xs_usage(cv, "$reference");
09bef843
SB
242 }
243
244 rv = ST(0);
245 ST(0) = TARG;
5b295bef 246 SvGETMAGIC(rv);
121e869f 247 if (!(SvOK(rv) && SvROK(rv)))
09bef843
SB
248 goto usage;
249 sv = SvRV(rv);
250 sv_setpv(TARG, sv_reftype(sv, 0));
09bef843 251 SvSETMAGIC(TARG);
09bef843
SB
252
253 XSRETURN(1);
66610fdd 254/*
14d04a33 255 * ex: set ts=8 sts=4 sw=4 et:
f1a3ce43 256 */