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