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