This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a5a2bf00faafd01a0a0ef0c3fc0a37c6ed773d45
[perl5.git] / ext / XS / APItest / APItest.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 /* from exception.c */
6 int exception(int);
7
8 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
9
10 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
11
12 bool
13 exists(hash, key_sv)
14         PREINIT:
15         STRLEN len;
16         const char *key;
17         INPUT:
18         HV *hash
19         SV *key_sv
20         CODE:
21         key = SvPV(key_sv, len);
22         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
23         OUTPUT:
24         RETVAL
25
26 SV *
27 delete(hash, key_sv)
28         PREINIT:
29         STRLEN len;
30         const char *key;
31         INPUT:
32         HV *hash
33         SV *key_sv
34         CODE:
35         key = SvPV(key_sv, len);
36         /* It's already mortal, so need to increase reference count.  */
37         RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
38         OUTPUT:
39         RETVAL
40
41 SV *
42 store_ent(hash, key, value)
43         PREINIT:
44         SV *copy;
45         HE *result;
46         INPUT:
47         HV *hash
48         SV *key
49         SV *value
50         CODE:
51         copy = newSV(0);
52         result = hv_store_ent(hash, key, copy, 0);
53         SvSetMagicSV(copy, value);
54         if (!result) {
55             SvREFCNT_dec(copy);
56             XSRETURN_EMPTY;
57         }
58         /* It's about to become mortal, so need to increase reference count.
59          */
60         RETVAL = SvREFCNT_inc(HeVAL(result));
61         OUTPUT:
62         RETVAL
63
64
65 SV *
66 store(hash, key_sv, value)
67         PREINIT:
68         STRLEN len;
69         const char *key;
70         SV *copy;
71         SV **result;
72         INPUT:
73         HV *hash
74         SV *key_sv
75         SV *value
76         CODE:
77         key = SvPV(key_sv, len);
78         copy = newSV(0);
79         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
80         SvSetMagicSV(copy, value);
81         if (!result) {
82             SvREFCNT_dec(copy);
83             XSRETURN_EMPTY;
84         }
85         /* It's about to become mortal, so need to increase reference count.
86          */
87         RETVAL = SvREFCNT_inc(*result);
88         OUTPUT:
89         RETVAL
90
91
92 SV *
93 fetch(hash, key_sv)
94         PREINIT:
95         STRLEN len;
96         const char *key;
97         SV **result;
98         INPUT:
99         HV *hash
100         SV *key_sv
101         CODE:
102         key = SvPV(key_sv, len);
103         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
104         if (!result) {
105             XSRETURN_EMPTY;
106         }
107         /* Force mg_get  */
108         RETVAL = newSVsv(*result);
109         OUTPUT:
110         RETVAL
111 =pod
112
113 sub TIEHASH  { bless {}, $_[0] }
114 sub STORE    { $_[0]->{$_[1]} = $_[2] }
115 sub FETCH    { $_[0]->{$_[1]} }
116 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
117 sub NEXTKEY  { each %{$_[0]} }
118 sub EXISTS   { exists $_[0]->{$_[1]} }
119 sub DELETE   { delete $_[0]->{$_[1]} }
120 sub CLEAR    { %{$_[0]} = () }
121
122 =cut
123
124 MODULE = XS::APItest            PACKAGE = XS::APItest
125
126 PROTOTYPES: DISABLE
127
128 void
129 print_double(val)
130         double val
131         CODE:
132         printf("%5.3f\n",val);
133
134 int
135 have_long_double()
136         CODE:
137 #ifdef HAS_LONG_DOUBLE
138         RETVAL = 1;
139 #else
140         RETVAL = 0;
141 #endif
142         OUTPUT:
143         RETVAL
144
145 void
146 print_long_double()
147         CODE:
148 #ifdef HAS_LONG_DOUBLE
149 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
150         long double val = 7.0;
151         printf("%5.3" PERL_PRIfldbl "\n",val);
152 #   else
153         double val = 7.0;
154         printf("%5.3f\n",val);
155 #   endif
156 #endif
157
158 void
159 print_int(val)
160         int val
161         CODE:
162         printf("%d\n",val);
163
164 void
165 print_long(val)
166         long val
167         CODE:
168         printf("%ld\n",val);
169
170 void
171 print_float(val)
172         float val
173         CODE:
174         printf("%5.3f\n",val);
175         
176 void
177 print_flush()
178         CODE:
179         fflush(stdout);
180
181 void
182 mpushp()
183         PPCODE:
184         EXTEND(SP, 3);
185         mPUSHp("one", 3);
186         mPUSHp("two", 3);
187         mPUSHp("three", 5);
188         XSRETURN(3);
189
190 void
191 mpushn()
192         PPCODE:
193         EXTEND(SP, 3);
194         mPUSHn(0.5);
195         mPUSHn(-0.25);
196         mPUSHn(0.125);
197         XSRETURN(3);
198
199 void
200 mpushi()
201         PPCODE:
202         EXTEND(SP, 3);
203         mPUSHi(-1);
204         mPUSHi(2);
205         mPUSHi(-3);
206         XSRETURN(3);
207
208 void
209 mpushu()
210         PPCODE:
211         EXTEND(SP, 3);
212         mPUSHu(1);
213         mPUSHu(2);
214         mPUSHu(3);
215         XSRETURN(3);
216
217 void
218 mxpushp()
219         PPCODE:
220         mXPUSHp("one", 3);
221         mXPUSHp("two", 3);
222         mXPUSHp("three", 5);
223         XSRETURN(3);
224
225 void
226 mxpushn()
227         PPCODE:
228         mXPUSHn(0.5);
229         mXPUSHn(-0.25);
230         mXPUSHn(0.125);
231         XSRETURN(3);
232
233 void
234 mxpushi()
235         PPCODE:
236         mXPUSHi(-1);
237         mXPUSHi(2);
238         mXPUSHi(-3);
239         XSRETURN(3);
240
241 void
242 mxpushu()
243         PPCODE:
244         mXPUSHu(1);
245         mXPUSHu(2);
246         mXPUSHu(3);
247         XSRETURN(3);
248
249
250 void
251 call_sv(sv, flags, ...)
252     SV* sv
253     I32 flags
254     PREINIT:
255         I32 i;
256     PPCODE:
257         for (i=0; i<items-2; i++)
258             ST(i) = ST(i+2); /* pop first two args */
259         PUSHMARK(SP);
260         SP += items - 2;
261         PUTBACK;
262         i = call_sv(sv, flags);
263         SPAGAIN;
264         EXTEND(SP, 1);
265         PUSHs(sv_2mortal(newSViv(i)));
266
267 void
268 call_pv(subname, flags, ...)
269     char* subname
270     I32 flags
271     PREINIT:
272         I32 i;
273     PPCODE:
274         for (i=0; i<items-2; i++)
275             ST(i) = ST(i+2); /* pop first two args */
276         PUSHMARK(SP);
277         SP += items - 2;
278         PUTBACK;
279         i = call_pv(subname, flags);
280         SPAGAIN;
281         EXTEND(SP, 1);
282         PUSHs(sv_2mortal(newSViv(i)));
283
284 void
285 call_method(methname, flags, ...)
286     char* methname
287     I32 flags
288     PREINIT:
289         I32 i;
290     PPCODE:
291         for (i=0; i<items-2; i++)
292             ST(i) = ST(i+2); /* pop first two args */
293         PUSHMARK(SP);
294         SP += items - 2;
295         PUTBACK;
296         i = call_method(methname, flags);
297         SPAGAIN;
298         EXTEND(SP, 1);
299         PUSHs(sv_2mortal(newSViv(i)));
300
301 void
302 eval_sv(sv, flags)
303     SV* sv
304     I32 flags
305     PREINIT:
306         I32 i;
307     PPCODE:
308         PUTBACK;
309         i = eval_sv(sv, flags);
310         SPAGAIN;
311         EXTEND(SP, 1);
312         PUSHs(sv_2mortal(newSViv(i)));
313
314 void
315 eval_pv(p, croak_on_error)
316     const char* p
317     I32 croak_on_error
318     PPCODE:
319         PUTBACK;
320         EXTEND(SP, 1);
321         PUSHs(eval_pv(p, croak_on_error));
322
323 void
324 require_pv(pv)
325     const char* pv
326     PPCODE:
327         PUTBACK;
328         require_pv(pv);
329
330 int
331 exception(throw_e)
332     int throw_e
333     OUTPUT:
334         RETVAL
335
336 void
337 mycroak(pv)
338     const char* pv
339     CODE:
340     Perl_croak(aTHX_ "%s", pv);
341
342 SV*
343 strtab()
344    CODE:
345    RETVAL = newRV_inc((SV*)PL_strtab);
346    OUTPUT:
347    RETVAL