Retract the mergesort code, way too incompatible licensing
[perl.git] / xsutils.c
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
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
26  * bundled *.pm files is in a version-specific directory,
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
38 #include "XSUB.h"
39
40 static int
41 modify_SV_attributes(pTHXo_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
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);
51         if ((negated = (*name == '-'))) {
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             }
90             break;
91         default:
92             /* nothing, yet */
93             break;
94         }
95         /* anything recognized had a 'continue' above */
96         *retlist++ = attr;
97         nret++;
98     }
99
100     return nret;
101 }
102
103
104
105 /* package attributes; */
106
107 XS(XS_attributes_bootstrap)
108 {
109     dXSARGS;
110     char *file = __FILE__;
111
112     newXSproto("attributes::_warn_reserved", XS_attributes__warn_reserved, file, "");
113     newXS("attributes::_modify_attrs",  XS_attributes__modify_attrs,    file);
114     newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$");
115     newXSproto("attributes::_fetch_attrs", XS_attributes__fetch_attrs, file, "$");
116     newXSproto("attributes::reftype",   XS_attributes_reftype,  file, "$");
117
118     XSRETURN(0);
119 }
120
121 XS(XS_attributes__modify_attrs)
122 {
123     dXSARGS;
124     SV *rv, *sv;
125
126     if (items < 1) {
127 usage:
128         Perl_croak(aTHX_
129                    "Usage: attributes::_modify_attrs $reference, @attributes");
130     }
131
132     rv = ST(0);
133     if (!(SvOK(rv) && SvROK(rv)))
134         goto usage;
135     sv = SvRV(rv);
136     if (items > 1)
137         XSRETURN(modify_SV_attributes(aTHXo_ sv, &ST(0), &ST(1), items-1));
138
139     XSRETURN(0);
140 }
141
142 XS(XS_attributes__fetch_attrs)
143 {
144     dXSARGS;
145     SV *rv, *sv;
146     cv_flags_t cvflags;
147
148     if (items != 1) {
149 usage:
150         Perl_croak(aTHX_
151                    "Usage: attributes::_fetch_attrs $reference");
152     }
153
154     rv = ST(0);
155     SP -= items;
156     if (!(SvOK(rv) && SvROK(rv)))
157         goto usage;
158     sv = SvRV(rv);
159
160     switch (SvTYPE(sv)) {
161     case SVt_PVCV:
162         cvflags = CvFLAGS((CV*)sv);
163         if (cvflags & CVf_LOCKED)
164             XPUSHs(sv_2mortal(newSVpvn("locked", 6)));
165 #ifdef CVf_LVALUE
166         if (cvflags & CVf_LVALUE)
167             XPUSHs(sv_2mortal(newSVpvn("lvalue", 6)));
168 #endif
169         if (cvflags & CVf_METHOD)
170             XPUSHs(sv_2mortal(newSVpvn("method", 6)));
171         break;
172     default:
173         break;
174     }
175
176     PUTBACK;
177 }
178
179 XS(XS_attributes__guess_stash)
180 {
181     dXSARGS;
182     SV *rv, *sv;
183 #ifdef dXSTARGET
184     dXSTARGET;
185 #else
186     SV * TARG = sv_newmortal();
187 #endif
188
189     if (items != 1) {
190 usage:
191         Perl_croak(aTHX_
192                    "Usage: attributes::_guess_stash $reference");
193     }
194
195     rv = ST(0);
196     ST(0) = TARG;
197     if (!(SvOK(rv) && SvROK(rv)))
198         goto usage;
199     sv = SvRV(rv);
200
201     if (SvOBJECT(sv))
202         sv_setpv(TARG, HvNAME(SvSTASH(sv)));
203 #if 0   /* this was probably a bad idea */
204     else if (SvPADMY(sv))
205         sv_setsv(TARG, &PL_sv_no);      /* unblessed lexical */
206 #endif
207     else {
208         HV *stash = Nullhv;
209         switch (SvTYPE(sv)) {
210         case SVt_PVCV:
211             if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)) &&
212                             HvNAME(GvSTASH(CvGV(sv))))
213                 stash = GvSTASH(CvGV(sv));
214             else if (/* !CvANON(sv) && */ CvSTASH(sv) && HvNAME(CvSTASH(sv)))
215                 stash = CvSTASH(sv);
216             break;
217         case SVt_PVMG:
218             if (!(SvFAKE(sv) && SvTIED_mg(sv, '*')))
219                 break;
220             /*FALLTHROUGH*/
221         case SVt_PVGV:
222             if (GvGP(sv) && GvESTASH((GV*)sv) && HvNAME(GvESTASH((GV*)sv)))
223                 stash = GvESTASH((GV*)sv);
224             break;
225         default:
226             break;
227         }
228         if (stash)
229             sv_setpv(TARG, HvNAME(stash));
230     }
231
232 #ifdef dXSTARGET
233     SvSETMAGIC(TARG);
234 #endif
235     XSRETURN(1);
236 }
237
238 XS(XS_attributes_reftype)
239 {
240     dXSARGS;
241     SV *rv, *sv;
242 #ifdef dXSTARGET
243     dXSTARGET;
244 #else
245     SV * TARG = sv_newmortal();
246 #endif
247
248     if (items != 1) {
249 usage:
250         Perl_croak(aTHX_
251                    "Usage: attributes::reftype $reference");
252     }
253
254     rv = ST(0);
255     ST(0) = TARG;
256     if (SvGMAGICAL(rv))
257         mg_get(rv);
258     if (!(SvOK(rv) && SvROK(rv)))
259         goto usage;
260     sv = SvRV(rv);
261     sv_setpv(TARG, sv_reftype(sv, 0));
262 #ifdef dXSTARGET
263     SvSETMAGIC(TARG);
264 #endif
265
266     XSRETURN(1);
267 }
268
269 XS(XS_attributes__warn_reserved)
270 {
271     dXSARGS;
272 #ifdef dXSTARGET
273     dXSTARGET;
274 #else
275     SV * TARG = sv_newmortal();
276 #endif
277
278     if (items != 0) {
279         Perl_croak(aTHX_
280                    "Usage: attributes::_warn_reserved ()");
281     }
282
283     EXTEND(SP,1);
284     ST(0) = TARG;
285     sv_setiv(TARG, ckWARN(WARN_RESERVED) != 0);
286 #ifdef dXSTARGET
287     SvSETMAGIC(TARG);
288 #endif
289
290     XSRETURN(1);
291 }
292