Re: [perl #41574] cond_wait hang ups under MSWin32
[perl.git] / xsutils.c
1 /*    xsutils.c
2  *
3  *    Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4  *    by Larry Wall and others
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
11 /*
12  * "Perilous to us all are the devices of an art deeper than we possess
13  * ourselves." --Gandalf
14  */
15
16
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
25 /* package attributes; */
26 PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
27 PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
28 PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
29 PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
30 PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
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
41  * bundled *.pm files is in a version-specific directory,
42  * version checks in these bootstrap calls are optional.
43  */
44
45 static const char file[] = __FILE__;
46
47 void
48 Perl_boot_core_xsutils(pTHX)
49 {
50     newXS("attributes::bootstrap",      XS_attributes_bootstrap,        file);
51 }
52
53 #include "XSUB.h"
54
55 static int
56 modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
57 {
58     dVAR;
59     SV *attr;
60     int nret;
61
62     for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
63         STRLEN len;
64         const char *name = SvPV_const(attr, len);
65         const bool negated = (*name == '-');
66
67         if (negated) {
68             name++;
69             len--;
70         }
71         switch (SvTYPE(sv)) {
72         case SVt_PVCV:
73             switch ((int)len) {
74 #ifdef CVf_ASSERTION
75             case 9:
76                 if (memEQ(name, "assertion", 9)) {
77                     if (negated)
78                         CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
79                     else
80                         CvFLAGS((CV*)sv) |= CVf_ASSERTION;
81                     continue;
82                 }
83                 break;
84 #endif
85             case 6:
86                 switch (name[3]) {
87 #ifdef CVf_LVALUE
88                 case 'l':
89                     if (memEQ(name, "lvalue", 6)) {
90                         if (negated)
91                             CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
92                         else
93                             CvFLAGS((CV*)sv) |= CVf_LVALUE;
94                         continue;
95                     }
96                     break;
97 #endif
98                 case 'k':
99                     if (memEQ(name, "locked", 6)) {
100                         if (negated)
101                             CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
102                         else
103                             CvFLAGS((CV*)sv) |= CVf_LOCKED;
104                         continue;
105                     }
106                     break;
107                 case 'h':
108                     if (memEQ(name, "method", 6)) {
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:
121             switch ((int)len) {
122             case 6:
123                 switch (name[5]) {
124                 case 'd':
125                     if (memEQ(name, "share", 5)) {
126                         if (negated)
127                             Perl_croak(aTHX_ "A variable may not be unshared");
128                         SvSHARE(sv);
129                         continue;
130                     }
131                     break;
132                 case 'e':
133                     if (memEQ(name, "uniqu", 5)) {
134                         if (SvTYPE(sv) == SVt_PVGV) {
135                             if (negated) {
136                                 GvUNIQUE_off(sv);
137                             } else {
138                                 GvUNIQUE_on(sv);
139                             }
140                         }
141                         /* Hope this came from toke.c if not a GV. */
142                         continue;
143                     }
144                 }
145             }
146             break;
147         }
148         /* anything recognized had a 'continue' above */
149         *retlist++ = attr;
150         nret++;
151     }
152
153     return nret;
154 }
155
156
157
158 /* package attributes; */
159
160 XS(XS_attributes_bootstrap)
161 {
162     dVAR;
163     dXSARGS;
164     PERL_UNUSED_ARG(cv);
165
166     if( items > 1 )
167         Perl_croak(aTHX_ "Usage: attributes::bootstrap $module");
168
169     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
170     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
171     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
172     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
173
174     XSRETURN(0);
175 }
176
177 XS(XS_attributes__modify_attrs)
178 {
179     dVAR;
180     dXSARGS;
181     SV *rv, *sv;
182     PERL_UNUSED_ARG(cv);
183
184     if (items < 1) {
185 usage:
186         Perl_croak(aTHX_
187                    "Usage: attributes::_modify_attrs $reference, @attributes");
188     }
189
190     rv = ST(0);
191     if (!(SvOK(rv) && SvROK(rv)))
192         goto usage;
193     sv = SvRV(rv);
194     if (items > 1)
195         XSRETURN(modify_SV_attributes(aTHX_ sv, &ST(0), &ST(1), items-1));
196
197     XSRETURN(0);
198 }
199
200 XS(XS_attributes__fetch_attrs)
201 {
202     dVAR;
203     dXSARGS;
204     SV *rv, *sv;
205     cv_flags_t cvflags;
206     PERL_UNUSED_ARG(cv);
207
208     if (items != 1) {
209 usage:
210         Perl_croak(aTHX_
211                    "Usage: attributes::_fetch_attrs $reference");
212     }
213
214     rv = ST(0);
215     SP -= items;
216     if (!(SvOK(rv) && SvROK(rv)))
217         goto usage;
218     sv = SvRV(rv);
219
220     switch (SvTYPE(sv)) {
221     case SVt_PVCV:
222         cvflags = CvFLAGS((CV*)sv);
223         if (cvflags & CVf_LOCKED)
224             XPUSHs(sv_2mortal(newSVpvs("locked")));
225 #ifdef CVf_LVALUE
226         if (cvflags & CVf_LVALUE)
227             XPUSHs(sv_2mortal(newSVpvs("lvalue")));
228 #endif
229         if (cvflags & CVf_METHOD)
230             XPUSHs(sv_2mortal(newSVpvs("method")));
231         if (GvUNIQUE(CvGV((CV*)sv)))
232             XPUSHs(sv_2mortal(newSVpvs("unique")));
233         if (cvflags & CVf_ASSERTION)
234             XPUSHs(sv_2mortal(newSVpvs("assertion")));
235         break;
236     case SVt_PVGV:
237         if (GvUNIQUE(sv))
238             XPUSHs(sv_2mortal(newSVpvs("unique")));
239         break;
240     default:
241         break;
242     }
243
244     PUTBACK;
245 }
246
247 XS(XS_attributes__guess_stash)
248 {
249     dVAR;
250     dXSARGS;
251     SV *rv, *sv;
252     dXSTARG;
253     PERL_UNUSED_ARG(cv);
254
255     if (items != 1) {
256 usage:
257         Perl_croak(aTHX_
258                    "Usage: attributes::_guess_stash $reference");
259     }
260
261     rv = ST(0);
262     ST(0) = TARG;
263     if (!(SvOK(rv) && SvROK(rv)))
264         goto usage;
265     sv = SvRV(rv);
266
267     if (SvOBJECT(sv))
268         sv_setpvn(TARG, HvNAME_get(SvSTASH(sv)), HvNAMELEN_get(SvSTASH(sv)));
269 #if 0   /* this was probably a bad idea */
270     else if (SvPADMY(sv))
271         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
272 #endif
273     else {
274         const HV *stash = NULL;
275         switch (SvTYPE(sv)) {
276         case SVt_PVCV:
277             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
278                 stash = GvSTASH(CvGV(sv));
279             else if (/* !CvANON(sv) && */ CvSTASH(sv))
280                 stash = CvSTASH(sv);
281             break;
282         case SVt_PVGV:
283             if (GvGP(sv) && GvESTASH((GV*)sv))
284                 stash = GvESTASH((GV*)sv);
285             break;
286         default:
287             break;
288         }
289         if (stash)
290             sv_setpvn(TARG, HvNAME_get(stash), HvNAMELEN_get(stash));
291     }
292
293     SvSETMAGIC(TARG);
294     XSRETURN(1);
295 }
296
297 XS(XS_attributes_reftype)
298 {
299     dVAR;
300     dXSARGS;
301     SV *rv, *sv;
302     dXSTARG;
303     PERL_UNUSED_ARG(cv);
304
305     if (items != 1) {
306 usage:
307         Perl_croak(aTHX_
308                    "Usage: attributes::reftype $reference");
309     }
310
311     rv = ST(0);
312     ST(0) = TARG;
313     SvGETMAGIC(rv);
314     if (!(SvOK(rv) && SvROK(rv)))
315         goto usage;
316     sv = SvRV(rv);
317     sv_setpv(TARG, sv_reftype(sv, 0));
318     SvSETMAGIC(TARG);
319
320     XSRETURN(1);
321 }
322
323 /*
324  * Local variables:
325  * c-indentation-style: bsd
326  * c-basic-offset: 4
327  * indent-tabs-mode: t
328  * End:
329  *
330  * ex: set ts=8 sts=4 sw=4 noet:
331  */