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