(?p{}) has been deprecated for a long time.
[p5sagit/p5-mst-13.2.git] / xsutils.c
CommitLineData
d6376244 1/* xsutils.c
2 *
acde74e1 3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
371fce9b 4 * by Larry Wall and others
d6376244 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/*
12 * "Perilous to us all are the devices of an art deeper than we possess
13 * ourselves." --Gandalf
14 */
15
16
09bef843 17#include "EXTERN.h"
18#define PERL_IN_XSUTILS_C
19#include "perl.h"
20
21/*
22 * Contributed by Spider Boardman (spider.boardman@orb.nashua.nh.us).
23 */
24
349fd7b7 25/* package attributes; */
27da23d5 26PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
27PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
28PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
29PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
30PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
349fd7b7 31
32
33/*
34 * Note that only ${pkg}::bootstrap definitions should go here.
35 * This helps keep down the start-up time, which is especially
36 * relevant for users who don't invoke any features which are
37 * (partially) implemented here.
38 *
39 * The various bootstrap definitions can take care of doing
40 * package-specific newXS() calls. Since the layout of the
6a34af38 41 * bundled *.pm files is in a version-specific directory,
349fd7b7 42 * version checks in these bootstrap calls are optional.
43 */
44
a4c98449 45static const char file[] = __FILE__;
46
349fd7b7 47void
48Perl_boot_core_xsutils(pTHX)
49{
349fd7b7 50 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
51}
52
349fd7b7 53#include "XSUB.h"
54
55static int
acfe0abc 56modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
09bef843 57{
97aff369 58 dVAR;
09bef843 59 SV *attr;
09bef843 60 int nret;
61
62 for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
4373e329 63 STRLEN len;
cfd0369c 64 const char *name = SvPV_const(attr, len);
4373e329 65 const bool negated = (*name == '-');
66
67 if (negated) {
09bef843 68 name++;
69 len--;
70 }
71 switch (SvTYPE(sv)) {
72 case SVt_PVCV:
73 switch ((int)len) {
77c9267e 74#ifdef CVf_ASSERTION
42262798 75 case 9:
8cad210e 76 if (memEQ(name, "assertion", 9)) {
42262798 77 if (negated)
78 CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
79 else
80 CvFLAGS((CV*)sv) |= CVf_ASSERTION;
81 continue;
82 }
83 break;
77c9267e 84#endif
09bef843 85 case 6:
8cad210e 86 switch (name[3]) {
09bef843 87#ifdef CVf_LVALUE
d5adc3a1 88 case 'l':
8cad210e 89 if (memEQ(name, "lvalue", 6)) {
09bef843 90 if (negated)
91 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
92 else
93 CvFLAGS((CV*)sv) |= CVf_LVALUE;
94 continue;
95 }
8cad210e 96 break;
d5adc3a1 97#endif
8cad210e 98 case 'k':
8cad210e 99 if (memEQ(name, "locked", 6)) {
09bef843 100 if (negated)
101 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
102 else
103 CvFLAGS((CV*)sv) |= CVf_LOCKED;
104 continue;
105 }
106 break;
8cad210e 107 case 'h':
108 if (memEQ(name, "method", 6)) {
09bef843 109 if (negated)
110 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
111 else
112 CvFLAGS((CV*)sv) |= CVf_METHOD;
113 continue;
114 }
115 break;
116 }
117 break;
118 }
119 break;
120 default:
0256094b 121 switch ((int)len) {
95f0a2f1 122 case 6:
8cad210e 123 switch (name[5]) {
124 case 'd':
125 if (memEQ(name, "share", 5)) {
13c1b207 126 if (negated)
127 Perl_croak(aTHX_ "A variable may not be unshared");
128 SvSHARE(sv);
129 continue;
130 }
131 break;
8cad210e 132 case 'e':
133 if (memEQ(name, "uniqu", 5)) {
95f0a2f1 134 if (SvTYPE(sv) == SVt_PVGV) {
44f8325f 135 if (negated) {
95f0a2f1 136 GvUNIQUE_off(sv);
44f8325f 137 } else {
95f0a2f1 138 GvUNIQUE_on(sv);
44f8325f 139 }
95f0a2f1 140 }
141 /* Hope this came from toke.c if not a GV. */
0256094b 142 continue;
143 }
144 }
145 }
09bef843 146 break;
147 }
148 /* anything recognized had a 'continue' above */
149 *retlist++ = attr;
150 nret++;
151 }
152
153 return nret;
154}
155
156
09bef843 157
158/* package attributes; */
159
160XS(XS_attributes_bootstrap)
161{
97aff369 162 dVAR;
09bef843 163 dXSARGS;
09bef843 164
592f5969 165 if( items > 1 )
166 Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
b7953727 167
09bef843 168 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
169 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
170 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
171 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
172
173 XSRETURN(0);
174}
175
176XS(XS_attributes__modify_attrs)
177{
97aff369 178 dVAR;
09bef843 179 dXSARGS;
180 SV *rv, *sv;
181
182 if (items < 1) {
183usage:
184 Perl_croak(aTHX_
185 "Usage: attributes::_modify_attrs $reference, @attributes");
186 }
187
188 rv = ST(0);
189 if (!(SvOK(rv) && SvROK(rv)))
190 goto usage;
191 sv = SvRV(rv);
192 if (items > 1)
acfe0abc 193 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843 194
195 XSRETURN(0);
196}
197
198XS(XS_attributes__fetch_attrs)
199{
97aff369 200 dVAR;
09bef843 201 dXSARGS;
202 SV *rv, *sv;
203 cv_flags_t cvflags;
204
205 if (items != 1) {
206usage:
207 Perl_croak(aTHX_
208 "Usage: attributes::_fetch_attrs $reference");
209 }
210
211 rv = ST(0);
212 SP -= items;
213 if (!(SvOK(rv) && SvROK(rv)))
214 goto usage;
215 sv = SvRV(rv);
216
217 switch (SvTYPE(sv)) {
218 case SVt_PVCV:
219 cvflags = CvFLAGS((CV*)sv);
220 if (cvflags & CVf_LOCKED)
396482e1 221 XPUSHs(sv_2mortal(newSVpvs("locked")));
09bef843 222#ifdef CVf_LVALUE
223 if (cvflags & CVf_LVALUE)
396482e1 224 XPUSHs(sv_2mortal(newSVpvs("lvalue")));
09bef843 225#endif
226 if (cvflags & CVf_METHOD)
396482e1 227 XPUSHs(sv_2mortal(newSVpvs("method")));
7fb37951 228 if (GvUNIQUE(CvGV((CV*)sv)))
396482e1 229 XPUSHs(sv_2mortal(newSVpvs("unique")));
06492da6 230 if (cvflags & CVf_ASSERTION)
396482e1 231 XPUSHs(sv_2mortal(newSVpvs("assertion")));
95f0a2f1 232 break;
233 case SVt_PVGV:
234 if (GvUNIQUE(sv))
396482e1 235 XPUSHs(sv_2mortal(newSVpvs("unique")));
09bef843 236 break;
237 default:
238 break;
239 }
240
241 PUTBACK;
242}
243
244XS(XS_attributes__guess_stash)
245{
97aff369 246 dVAR;
09bef843 247 dXSARGS;
248 SV *rv, *sv;
d277572a 249 dXSTARG;
09bef843 250
251 if (items != 1) {
252usage:
253 Perl_croak(aTHX_
254 "Usage: attributes::_guess_stash $reference");
255 }
256
257 rv = ST(0);
258 ST(0) = TARG;
259 if (!(SvOK(rv) && SvROK(rv)))
260 goto usage;
261 sv = SvRV(rv);
262
263 if (SvOBJECT(sv))
7423f6db 264 sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
09bef843 265#if 0 /* this was probably a bad idea */
266 else if (SvPADMY(sv))
267 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
268#endif
269 else {
5c284bb0 270 const HV *stash = NULL;
09bef843 271 switch (SvTYPE(sv)) {
272 case SVt_PVCV:
6676db26 273 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843 274 stash = GvSTASH(CvGV(sv));
6676db26 275 else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843 276 stash = CvSTASH(sv);
277 break;
09bef843 278 case SVt_PVGV:
6676db26 279 if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843 280 stash = GvESTASH((GV*)sv);
281 break;
282 default:
283 break;
284 }
285 if (stash)
7423f6db 286 sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
09bef843 287 }
288
09bef843 289 SvSETMAGIC(TARG);
09bef843 290 XSRETURN(1);
291}
292
293XS(XS_attributes_reftype)
294{
97aff369 295 dVAR;
09bef843 296 dXSARGS;
297 SV *rv, *sv;
d277572a 298 dXSTARG;
09bef843 299
300 if (items != 1) {
301usage:
302 Perl_croak(aTHX_
303 "Usage: attributes::reftype $reference");
304 }
305
306 rv = ST(0);
307 ST(0) = TARG;
5b295bef 308 SvGETMAGIC(rv);
121e869f 309 if (!(SvOK(rv) && SvROK(rv)))
09bef843 310 goto usage;
311 sv = SvRV(rv);
312 sv_setpv(TARG, sv_reftype(sv, 0));
09bef843 313 SvSETMAGIC(TARG);
09bef843 314
315 XSRETURN(1);
316}
317
66610fdd 318/*
319 * Local variables:
320 * c-indentation-style: bsd
321 * c-basic-offset: 4
322 * indent-tabs-mode: t
323 * End:
324 *
37442d52 325 * ex: set ts=8 sts=4 sw=4 noet:
326 */