This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Perl_croak_xs_usage(), which reduces a lot of explicit calls of
[perl5.git] / xsutils.c
CommitLineData
d6376244
JH
1/* xsutils.c
2 *
663f364b 3 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
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
AT
11/*
12 * "Perilous to us all are the devices of an art deeper than we possess
13 * ourselves." --Gandalf
14 */
15
16
09bef843
SB
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
JH
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
GS
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
GS
42 * version checks in these bootstrap calls are optional.
43 */
44
a4c98449
NC
45static const char file[] = __FILE__;
46
349fd7b7
GS
47void
48Perl_boot_core_xsutils(pTHX)
49{
349fd7b7
GS
50 newXS("attributes::bootstrap", XS_attributes_bootstrap, file);
51}
52
349fd7b7
GS
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
SB
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
AL
65 const bool negated = (*name == '-');
66
67 if (negated) {
09bef843
SB
68 name++;
69 len--;
70 }
71 switch (SvTYPE(sv)) {
72 case SVt_PVCV:
73 switch ((int)len) {
74 case 6:
8cad210e 75 switch (name[3]) {
09bef843 76#ifdef CVf_LVALUE
d5adc3a1 77 case 'l':
8cad210e 78 if (memEQ(name, "lvalue", 6)) {
09bef843
SB
79 if (negated)
80 CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
81 else
82 CvFLAGS((CV*)sv) |= CVf_LVALUE;
83 continue;
84 }
8cad210e 85 break;
d5adc3a1 86#endif
8cad210e 87 case 'k':
8cad210e 88 if (memEQ(name, "locked", 6)) {
09bef843
SB
89 if (negated)
90 CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
91 else
92 CvFLAGS((CV*)sv) |= CVf_LOCKED;
93 continue;
94 }
95 break;
8cad210e
NC
96 case 'h':
97 if (memEQ(name, "method", 6)) {
09bef843
SB
98 if (negated)
99 CvFLAGS((CV*)sv) &= ~CVf_METHOD;
100 else
101 CvFLAGS((CV*)sv) |= CVf_METHOD;
102 continue;
103 }
104 break;
105 }
106 break;
107 }
108 break;
109 default:
0256094b 110 switch ((int)len) {
95f0a2f1 111 case 6:
8cad210e
NC
112 switch (name[5]) {
113 case 'd':
114 if (memEQ(name, "share", 5)) {
13c1b207
DM
115 if (negated)
116 Perl_croak(aTHX_ "A variable may not be unshared");
117 SvSHARE(sv);
118 continue;
119 }
120 break;
8cad210e
NC
121 case 'e':
122 if (memEQ(name, "uniqu", 5)) {
95f0a2f1 123 if (SvTYPE(sv) == SVt_PVGV) {
44f8325f 124 if (negated) {
95f0a2f1 125 GvUNIQUE_off(sv);
44f8325f 126 } else {
95f0a2f1 127 GvUNIQUE_on(sv);
44f8325f 128 }
95f0a2f1
SB
129 }
130 /* Hope this came from toke.c if not a GV. */
0256094b
DM
131 continue;
132 }
133 }
134 }
09bef843
SB
135 break;
136 }
137 /* anything recognized had a 'continue' above */
138 *retlist++ = attr;
139 nret++;
140 }
141
142 return nret;
143}
144
145
09bef843
SB
146
147/* package attributes; */
148
149XS(XS_attributes_bootstrap)
150{
97aff369 151 dVAR;
09bef843 152 dXSARGS;
09bef843 153
592f5969 154 if( items > 1 )
afa74d42 155 croak_xs_usage(cv, "$module");
b7953727 156
09bef843
SB
157 newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file);
158 newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
159 newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
160 newXSproto("attributes::reftype", XS_attributes_reftype, file, "$");
161
162 XSRETURN(0);
163}
164
165XS(XS_attributes__modify_attrs)
166{
97aff369 167 dVAR;
09bef843
SB
168 dXSARGS;
169 SV *rv, *sv;
170
171 if (items < 1) {
172usage:
afa74d42 173 croak_xs_usage(cv, "@attributes");
09bef843
SB
174 }
175
176 rv = ST(0);
177 if (!(SvOK(rv) && SvROK(rv)))
178 goto usage;
179 sv = SvRV(rv);
180 if (items > 1)
acfe0abc 181 XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
09bef843
SB
182
183 XSRETURN(0);
184}
185
186XS(XS_attributes__fetch_attrs)
187{
97aff369 188 dVAR;
09bef843
SB
189 dXSARGS;
190 SV *rv, *sv;
191 cv_flags_t cvflags;
192
193 if (items != 1) {
194usage:
afa74d42 195 croak_xs_usage(cv, "$reference");
09bef843
SB
196 }
197
198 rv = ST(0);
199 SP -= items;
200 if (!(SvOK(rv) && SvROK(rv)))
201 goto usage;
202 sv = SvRV(rv);
203
204 switch (SvTYPE(sv)) {
205 case SVt_PVCV:
206 cvflags = CvFLAGS((CV*)sv);
207 if (cvflags & CVf_LOCKED)
84bafc02 208 XPUSHs(newSVpvs_flags("locked", SVs_TEMP));
09bef843
SB
209#ifdef CVf_LVALUE
210 if (cvflags & CVf_LVALUE)
84bafc02 211 XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP));
09bef843
SB
212#endif
213 if (cvflags & CVf_METHOD)
84bafc02 214 XPUSHs(newSVpvs_flags("method", SVs_TEMP));
7fb37951 215 if (GvUNIQUE(CvGV((CV*)sv)))
84bafc02 216 XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
95f0a2f1
SB
217 break;
218 case SVt_PVGV:
219 if (GvUNIQUE(sv))
84bafc02 220 XPUSHs(newSVpvs_flags("unique", SVs_TEMP));
09bef843
SB
221 break;
222 default:
223 break;
224 }
225
226 PUTBACK;
227}
228
229XS(XS_attributes__guess_stash)
230{
97aff369 231 dVAR;
09bef843
SB
232 dXSARGS;
233 SV *rv, *sv;
d277572a 234 dXSTARG;
09bef843
SB
235
236 if (items != 1) {
237usage:
afa74d42 238 croak_xs_usage(cv, "$reference");
09bef843
SB
239 }
240
241 rv = ST(0);
242 ST(0) = TARG;
243 if (!(SvOK(rv) && SvROK(rv)))
244 goto usage;
245 sv = SvRV(rv);
246
247 if (SvOBJECT(sv))
7423f6db 248 sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
09bef843
SB
249#if 0 /* this was probably a bad idea */
250 else if (SvPADMY(sv))
251 sv_setsv(TARG, &PL_sv_no); /* unblessed lexical */
252#endif
253 else {
5c284bb0 254 const HV *stash = NULL;
09bef843
SB
255 switch (SvTYPE(sv)) {
256 case SVt_PVCV:
6676db26 257 if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
09bef843 258 stash = GvSTASH(CvGV(sv));
6676db26 259 else if (/* !CvANON(sv) && */ CvSTASH(sv))
09bef843
SB
260 stash = CvSTASH(sv);
261 break;
09bef843 262 case SVt_PVGV:
6676db26 263 if (GvGP(sv) && GvESTASH((GV*)sv))
09bef843
SB
264 stash = GvESTASH((GV*)sv);
265 break;
266 default:
267 break;
268 }
269 if (stash)
7423f6db 270 sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
09bef843
SB
271 }
272
09bef843 273 SvSETMAGIC(TARG);
09bef843
SB
274 XSRETURN(1);
275}
276
277XS(XS_attributes_reftype)
278{
97aff369 279 dVAR;
09bef843
SB
280 dXSARGS;
281 SV *rv, *sv;
d277572a 282 dXSTARG;
09bef843
SB
283
284 if (items != 1) {
285usage:
afa74d42 286 croak_xs_usage(cv, "$reference");
09bef843
SB
287 }
288
289 rv = ST(0);
290 ST(0) = TARG;
5b295bef 291 SvGETMAGIC(rv);
121e869f 292 if (!(SvOK(rv) && SvROK(rv)))
09bef843
SB
293 goto usage;
294 sv = SvRV(rv);
295 sv_setpv(TARG, sv_reftype(sv, 0));
09bef843 296 SvSETMAGIC(TARG);
09bef843
SB
297
298 XSRETURN(1);
299}
300
66610fdd
RGS
301/*
302 * Local variables:
303 * c-indentation-style: bsd
304 * c-basic-offset: 4
305 * indent-tabs-mode: t
306 * End:
307 *
37442d52
RGS
308 * ex: set ts=8 sts=4 sw=4 noet:
309 */