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