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