This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7905a93574651dbf7f0697e2a72acf70dba03f46
[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 /* A routine to test hv_delayfree_ent
9    (which itself is tested by testing on hv_free_ent  */
10
11 typedef void (freeent_function)(pTHX_ HV *, register HE *);
12
13 void
14 test_freeent(freeent_function *f) {
15     dTHX;
16     dSP;
17     HV *test_hash = newHV();
18     HE *victim;
19     SV *test_scalar;
20     U32 results[4];
21     int i;
22
23 #ifdef PURIFY
24     victim = (HE*)safemalloc(sizeof(HE));
25 #else
26     /* Storing then deleting something should ensure that a hash entry is
27        available.  */
28     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
29     hv_delete(test_hash, "", 0, 0);
30
31     /* We need to "inline" new_he here as it's static, and the functions we
32        test expect to be able to call del_HE on the HE  */
33     if (!PL_he_root)
34         croak("PL_he_root is 0");
35     victim = PL_he_root;
36     PL_he_root = HeNEXT(victim);
37 #endif
38
39     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
40
41     test_scalar = newSV(0);
42     SvREFCNT_inc(test_scalar);
43     victim->hent_val = test_scalar;
44
45     /* Need this little game else we free the temps on the return stack.  */
46     results[0] = SvREFCNT(test_scalar);
47     SAVETMPS;
48     results[1] = SvREFCNT(test_scalar);
49     f(aTHX_ test_hash, victim);
50     results[2] = SvREFCNT(test_scalar);
51     FREETMPS;
52     results[3] = SvREFCNT(test_scalar);
53
54     i = 0;
55     do {
56         mPUSHu(results[i]);
57     } while (++i < sizeof(results)/sizeof(results[0]));
58
59     /* Goodbye to our extra reference.  */
60     SvREFCNT_dec(test_scalar);
61 }
62
63 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
64
65 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
66
67 bool
68 exists(hash, key_sv)
69         PREINIT:
70         STRLEN len;
71         const char *key;
72         INPUT:
73         HV *hash
74         SV *key_sv
75         CODE:
76         key = SvPV(key_sv, len);
77         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
78         OUTPUT:
79         RETVAL
80
81 SV *
82 delete(hash, key_sv)
83         PREINIT:
84         STRLEN len;
85         const char *key;
86         INPUT:
87         HV *hash
88         SV *key_sv
89         CODE:
90         key = SvPV(key_sv, len);
91         /* It's already mortal, so need to increase reference count.  */
92         RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
93         OUTPUT:
94         RETVAL
95
96 SV *
97 store_ent(hash, key, value)
98         PREINIT:
99         SV *copy;
100         HE *result;
101         INPUT:
102         HV *hash
103         SV *key
104         SV *value
105         CODE:
106         copy = newSV(0);
107         result = hv_store_ent(hash, key, copy, 0);
108         SvSetMagicSV(copy, value);
109         if (!result) {
110             SvREFCNT_dec(copy);
111             XSRETURN_EMPTY;
112         }
113         /* It's about to become mortal, so need to increase reference count.
114          */
115         RETVAL = SvREFCNT_inc(HeVAL(result));
116         OUTPUT:
117         RETVAL
118
119
120 SV *
121 store(hash, key_sv, value)
122         PREINIT:
123         STRLEN len;
124         const char *key;
125         SV *copy;
126         SV **result;
127         INPUT:
128         HV *hash
129         SV *key_sv
130         SV *value
131         CODE:
132         key = SvPV(key_sv, len);
133         copy = newSV(0);
134         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
135         SvSetMagicSV(copy, value);
136         if (!result) {
137             SvREFCNT_dec(copy);
138             XSRETURN_EMPTY;
139         }
140         /* It's about to become mortal, so need to increase reference count.
141          */
142         RETVAL = SvREFCNT_inc(*result);
143         OUTPUT:
144         RETVAL
145
146
147 SV *
148 fetch(hash, key_sv)
149         PREINIT:
150         STRLEN len;
151         const char *key;
152         SV **result;
153         INPUT:
154         HV *hash
155         SV *key_sv
156         CODE:
157         key = SvPV(key_sv, len);
158         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
159         if (!result) {
160             XSRETURN_EMPTY;
161         }
162         /* Force mg_get  */
163         RETVAL = newSVsv(*result);
164         OUTPUT:
165         RETVAL
166
167 void
168 test_hv_free_ent()
169         PPCODE:
170         test_freeent(&Perl_hv_free_ent);
171         XSRETURN(4);
172
173 void
174 test_hv_delayfree_ent()
175         PPCODE:
176         test_freeent(&Perl_hv_delayfree_ent);
177         XSRETURN(4);
178             
179 =pod
180
181 sub TIEHASH  { bless {}, $_[0] }
182 sub STORE    { $_[0]->{$_[1]} = $_[2] }
183 sub FETCH    { $_[0]->{$_[1]} }
184 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
185 sub NEXTKEY  { each %{$_[0]} }
186 sub EXISTS   { exists $_[0]->{$_[1]} }
187 sub DELETE   { delete $_[0]->{$_[1]} }
188 sub CLEAR    { %{$_[0]} = () }
189
190 =cut
191
192 MODULE = XS::APItest            PACKAGE = XS::APItest
193
194 PROTOTYPES: DISABLE
195
196 void
197 print_double(val)
198         double val
199         CODE:
200         printf("%5.3f\n",val);
201
202 int
203 have_long_double()
204         CODE:
205 #ifdef HAS_LONG_DOUBLE
206         RETVAL = 1;
207 #else
208         RETVAL = 0;
209 #endif
210         OUTPUT:
211         RETVAL
212
213 void
214 print_long_double()
215         CODE:
216 #ifdef HAS_LONG_DOUBLE
217 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
218         long double val = 7.0;
219         printf("%5.3" PERL_PRIfldbl "\n",val);
220 #   else
221         double val = 7.0;
222         printf("%5.3f\n",val);
223 #   endif
224 #endif
225
226 void
227 print_int(val)
228         int val
229         CODE:
230         printf("%d\n",val);
231
232 void
233 print_long(val)
234         long val
235         CODE:
236         printf("%ld\n",val);
237
238 void
239 print_float(val)
240         float val
241         CODE:
242         printf("%5.3f\n",val);
243         
244 void
245 print_flush()
246         CODE:
247         fflush(stdout);
248
249 void
250 mpushp()
251         PPCODE:
252         EXTEND(SP, 3);
253         mPUSHp("one", 3);
254         mPUSHp("two", 3);
255         mPUSHp("three", 5);
256         XSRETURN(3);
257
258 void
259 mpushn()
260         PPCODE:
261         EXTEND(SP, 3);
262         mPUSHn(0.5);
263         mPUSHn(-0.25);
264         mPUSHn(0.125);
265         XSRETURN(3);
266
267 void
268 mpushi()
269         PPCODE:
270         EXTEND(SP, 3);
271         mPUSHi(-1);
272         mPUSHi(2);
273         mPUSHi(-3);
274         XSRETURN(3);
275
276 void
277 mpushu()
278         PPCODE:
279         EXTEND(SP, 3);
280         mPUSHu(1);
281         mPUSHu(2);
282         mPUSHu(3);
283         XSRETURN(3);
284
285 void
286 mxpushp()
287         PPCODE:
288         mXPUSHp("one", 3);
289         mXPUSHp("two", 3);
290         mXPUSHp("three", 5);
291         XSRETURN(3);
292
293 void
294 mxpushn()
295         PPCODE:
296         mXPUSHn(0.5);
297         mXPUSHn(-0.25);
298         mXPUSHn(0.125);
299         XSRETURN(3);
300
301 void
302 mxpushi()
303         PPCODE:
304         mXPUSHi(-1);
305         mXPUSHi(2);
306         mXPUSHi(-3);
307         XSRETURN(3);
308
309 void
310 mxpushu()
311         PPCODE:
312         mXPUSHu(1);
313         mXPUSHu(2);
314         mXPUSHu(3);
315         XSRETURN(3);
316
317
318 void
319 call_sv(sv, flags, ...)
320     SV* sv
321     I32 flags
322     PREINIT:
323         I32 i;
324     PPCODE:
325         for (i=0; i<items-2; i++)
326             ST(i) = ST(i+2); /* pop first two args */
327         PUSHMARK(SP);
328         SP += items - 2;
329         PUTBACK;
330         i = call_sv(sv, flags);
331         SPAGAIN;
332         EXTEND(SP, 1);
333         PUSHs(sv_2mortal(newSViv(i)));
334
335 void
336 call_pv(subname, flags, ...)
337     char* subname
338     I32 flags
339     PREINIT:
340         I32 i;
341     PPCODE:
342         for (i=0; i<items-2; i++)
343             ST(i) = ST(i+2); /* pop first two args */
344         PUSHMARK(SP);
345         SP += items - 2;
346         PUTBACK;
347         i = call_pv(subname, flags);
348         SPAGAIN;
349         EXTEND(SP, 1);
350         PUSHs(sv_2mortal(newSViv(i)));
351
352 void
353 call_method(methname, flags, ...)
354     char* methname
355     I32 flags
356     PREINIT:
357         I32 i;
358     PPCODE:
359         for (i=0; i<items-2; i++)
360             ST(i) = ST(i+2); /* pop first two args */
361         PUSHMARK(SP);
362         SP += items - 2;
363         PUTBACK;
364         i = call_method(methname, flags);
365         SPAGAIN;
366         EXTEND(SP, 1);
367         PUSHs(sv_2mortal(newSViv(i)));
368
369 void
370 eval_sv(sv, flags)
371     SV* sv
372     I32 flags
373     PREINIT:
374         I32 i;
375     PPCODE:
376         PUTBACK;
377         i = eval_sv(sv, flags);
378         SPAGAIN;
379         EXTEND(SP, 1);
380         PUSHs(sv_2mortal(newSViv(i)));
381
382 void
383 eval_pv(p, croak_on_error)
384     const char* p
385     I32 croak_on_error
386     PPCODE:
387         PUTBACK;
388         EXTEND(SP, 1);
389         PUSHs(eval_pv(p, croak_on_error));
390
391 void
392 require_pv(pv)
393     const char* pv
394     PPCODE:
395         PUTBACK;
396         require_pv(pv);
397
398 int
399 exception(throw_e)
400     int throw_e
401     OUTPUT:
402         RETVAL
403
404 void
405 mycroak(pv)
406     const char* pv
407     CODE:
408     Perl_croak(aTHX_ "%s", pv);
409
410 SV*
411 strtab()
412    CODE:
413    RETVAL = newRV_inc((SV*)PL_strtab);
414    OUTPUT:
415    RETVAL