Commit | Line | Data |
09bef843 |
1 | #include "EXTERN.h" |
2 | #define PERL_IN_XSUTILS_C |
3 | #include "perl.h" |
4 | |
5 | /* |
6 | * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us). |
7 | */ |
8 | |
9 | STATIC int |
10 | S_modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) |
11 | { |
12 | SV *attr; |
13 | char *name; |
14 | STRLEN len; |
15 | bool negated; |
16 | int nret; |
17 | |
18 | for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { |
19 | name = SvPV(attr, len); |
20 | if (negated = (*name == '-')) { |
21 | name++; |
22 | len--; |
23 | } |
24 | switch (SvTYPE(sv)) { |
25 | case SVt_PVCV: |
26 | switch ((int)len) { |
27 | case 6: |
28 | switch (*name) { |
29 | case 'l': |
30 | #ifdef CVf_LVALUE |
31 | if (strEQ(name, "lvalue")) { |
32 | if (negated) |
33 | CvFLAGS((CV*)sv) &= ~CVf_LVALUE; |
34 | else |
35 | CvFLAGS((CV*)sv) |= CVf_LVALUE; |
36 | continue; |
37 | } |
38 | #endif /* defined CVf_LVALUE */ |
39 | if (strEQ(name, "locked")) { |
40 | if (negated) |
41 | CvFLAGS((CV*)sv) &= ~CVf_LOCKED; |
42 | else |
43 | CvFLAGS((CV*)sv) |= CVf_LOCKED; |
44 | continue; |
45 | } |
46 | break; |
47 | case 'm': |
48 | if (strEQ(name, "method")) { |
49 | if (negated) |
50 | CvFLAGS((CV*)sv) &= ~CVf_METHOD; |
51 | else |
52 | CvFLAGS((CV*)sv) |= CVf_METHOD; |
53 | continue; |
54 | } |
55 | break; |
56 | } |
57 | break; |
58 | } |
59 | break; |
60 | default: |
61 | /* nothing, yet */ |
62 | break; |
63 | } |
64 | /* anything recognized had a 'continue' above */ |
65 | *retlist++ = attr; |
66 | nret++; |
67 | } |
68 | |
69 | return nret; |
70 | } |
71 | |
72 | |
73 | /* package attributes; */ |
74 | void XS_attributes__warn_reserved(pTHXo_ CV *cv); |
75 | void XS_attributes_reftype(pTHXo_ CV *cv); |
76 | void XS_attributes__modify_attrs(pTHXo_ CV *cv); |
77 | void XS_attributes__guess_stash(pTHXo_ CV *cv); |
78 | void XS_attributes__fetch_attrs(pTHXo_ CV *cv); |
79 | void XS_attributes_bootstrap(pTHXo_ CV *cv); |
80 | |
81 | |
82 | /* |
83 | * Note that only ${pkg}::bootstrap definitions should go here. |
84 | * This helps keep down the start-up time, which is especially |
85 | * relevant for users who don't invoke any features which are |
86 | * (partially) implemented here. |
87 | * |
88 | * The various bootstrap definitions can take care of doing |
89 | * package-specific newXS() calls. Since the layout of the |
90 | * bundled lib/*.pm files is in a version-specific directory, |
91 | * version checks in these bootstrap calls are optional. |
92 | */ |
93 | |
94 | void |
95 | Perl_boot_core_xsutils(pTHX) |
96 | { |
97 | char *file = __FILE__; |
98 | |
99 | newXS("attributes::bootstrap", XS_attributes_bootstrap, file); |
100 | } |
101 | |
102 | #ifdef PERL_OBJECT |
103 | #define NO_XSLOCKS |
104 | #endif /* PERL_OBJECT */ |
105 | |
106 | #include "XSUB.h" |
107 | |
108 | /* package attributes; */ |
109 | |
110 | XS(XS_attributes_bootstrap) |
111 | { |
112 | dXSARGS; |
113 | char *file = __FILE__; |
114 | |
115 | newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, ""); |
116 | newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file); |
117 | newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$"); |
118 | newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$"); |
119 | newXSproto("attributes::reftype", XS_attributes_reftype, file, "$"); |
120 | |
121 | XSRETURN(0); |
122 | } |
123 | |
124 | XS(XS_attributes__modify_attrs) |
125 | { |
126 | dXSARGS; |
127 | SV *rv, *sv; |
128 | |
129 | if (items < 1) { |
130 | usage: |
131 | Perl_croak(aTHX_ |
132 | "Usage: attributes::_modify_attrs $reference, @attributes"); |
133 | } |
134 | |
135 | rv = ST(0); |
136 | if (!(SvOK(rv) && SvROK(rv))) |
137 | goto usage; |
138 | sv = SvRV(rv); |
139 | if (items > 1) |
140 | XSRETURN(modify_SV_attributes(sv, &ST(0), &ST(1), items-1)); |
141 | |
142 | XSRETURN(0); |
143 | } |
144 | |
145 | XS(XS_attributes__fetch_attrs) |
146 | { |
147 | dXSARGS; |
148 | SV *rv, *sv; |
149 | cv_flags_t cvflags; |
150 | |
151 | if (items != 1) { |
152 | usage: |
153 | Perl_croak(aTHX_ |
154 | "Usage: attributes::_fetch_attrs $reference"); |
155 | } |
156 | |
157 | rv = ST(0); |
158 | SP -= items; |
159 | if (!(SvOK(rv) && SvROK(rv))) |
160 | goto usage; |
161 | sv = SvRV(rv); |
162 | |
163 | switch (SvTYPE(sv)) { |
164 | case SVt_PVCV: |
165 | cvflags = CvFLAGS((CV*)sv); |
166 | if (cvflags & CVf_LOCKED) |
167 | XPUSHs(sv_2mortal(newSVpvn("locked", 6))); |
168 | #ifdef CVf_LVALUE |
169 | if (cvflags & CVf_LVALUE) |
170 | XPUSHs(sv_2mortal(newSVpvn("lvalue", 6))); |
171 | #endif |
172 | if (cvflags & CVf_METHOD) |
173 | XPUSHs(sv_2mortal(newSVpvn("method", 6))); |
174 | break; |
175 | default: |
176 | break; |
177 | } |
178 | |
179 | PUTBACK; |
180 | } |
181 | |
182 | XS(XS_attributes__guess_stash) |
183 | { |
184 | dXSARGS; |
185 | SV *rv, *sv; |
186 | #ifdef dXSTARGET |
187 | dXSTARGET; |
188 | #else |
189 | SV * TARG = sv_newmortal(); |
190 | #endif |
191 | |
192 | if (items != 1) { |
193 | usage: |
194 | Perl_croak(aTHX_ |
195 | "Usage: attributes::_guess_stash $reference"); |
196 | } |
197 | |
198 | rv = ST(0); |
199 | ST(0) = TARG; |
200 | if (!(SvOK(rv) && SvROK(rv))) |
201 | goto usage; |
202 | sv = SvRV(rv); |
203 | |
204 | if (SvOBJECT(sv)) |
205 | sv_setpv(TARG, HvNAME(SvSTASH(sv))); |
206 | #if 0 /* this was probably a bad idea */ |
207 | else if (SvPADMY(sv)) |
208 | sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */ |
209 | #endif |
210 | else { |
211 | HV *stash = Nullhv; |
212 | switch (SvTYPE(sv)) { |
213 | case SVt_PVCV: |
214 | if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) && |
215 | HvNAME(GvSTASH(CvGV(sv)))) |
216 | stash = GvSTASH(CvGV(sv)); |
217 | else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv))) |
218 | stash = CvSTASH(sv); |
219 | break; |
220 | case SVt_PVMG: |
221 | if (!(SvFAKE(sv) && SvTIED_mg(sv, '*'))) |
222 | break; |
223 | /*FALLTHROUGH*/ |
224 | case SVt_PVGV: |
225 | if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv))) |
226 | stash = GvESTASH((GV*)sv); |
227 | break; |
228 | default: |
229 | break; |
230 | } |
231 | if (stash) |
232 | sv_setpv(TARG, HvNAME(stash)); |
233 | } |
234 | |
235 | #ifdef dXSTARGET |
236 | SvSETMAGIC(TARG); |
237 | #endif |
238 | XSRETURN(1); |
239 | } |
240 | |
241 | XS(XS_attributes_reftype) |
242 | { |
243 | dXSARGS; |
244 | SV *rv, *sv; |
245 | #ifdef dXSTARGET |
246 | dXSTARGET; |
247 | #else |
248 | SV * TARG = sv_newmortal(); |
249 | #endif |
250 | |
251 | if (items != 1) { |
252 | usage: |
253 | Perl_croak(aTHX_ |
254 | "Usage: attributes::reftype $reference"); |
255 | } |
256 | |
257 | rv = ST(0); |
258 | ST(0) = TARG; |
259 | if (!SvOK(rv)) { |
260 | ST(0) = &PL_sv_no; |
261 | XSRETURN(1); |
262 | } |
263 | if (!SvROK(rv)) |
264 | goto usage; |
265 | sv = SvRV(rv); |
266 | sv_setpv(TARG, sv_reftype(sv, 0)); |
267 | #ifdef dXSTARGET |
268 | SvSETMAGIC(TARG); |
269 | #endif |
270 | |
271 | XSRETURN(1); |
272 | } |
273 | |
274 | XS(XS_attributes__warn_reserved) |
275 | { |
276 | dXSARGS; |
277 | SV *rv, *sv; |
278 | #ifdef dXSTARGET |
279 | dXSTARGET; |
280 | #else |
281 | SV * TARG = sv_newmortal(); |
282 | #endif |
283 | |
284 | if (items != 0) { |
285 | Perl_croak(aTHX_ |
286 | "Usage: attributes::_warn_reserved ()"); |
287 | } |
288 | |
289 | EXTEND(SP,1); |
290 | ST(0) = TARG; |
291 | sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0); |
292 | #ifdef dXSTARGET |
293 | SvSETMAGIC(TARG); |
294 | #endif |
295 | |
296 | XSRETURN(1); |
297 | } |
298 | |