This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_share_hek needs exporting for change 25070 on Win32
[perl5.git] / ext / XS / APItest / APItest.xs
CommitLineData
3e61d65a
JH
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
9b5c3821
MHM
5/* from exception.c */
6int exception(int);
0314122a 7
2dc92170
NC
8/* A routine to test hv_delayfree_ent
9 (which itself is tested by testing on hv_free_ent */
10
11typedef void (freeent_function)(pTHX_ HV *, register HE *);
12
13void
14test_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
0314122a
NC
60MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
61
028f8eaa
MHM
62#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
63
0314122a
NC
64bool
65exists(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);
028f8eaa 74 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
75 OUTPUT:
76 RETVAL
77
b60cf05a
NC
78SV *
79delete(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. */
028f8eaa 89 RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
b60cf05a
NC
90 OUTPUT:
91 RETVAL
92
93SV *
858117f8
NC
94store_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
117SV *
b60cf05a
NC
118store(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);
028f8eaa 131 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 132 SvSetMagicSV(copy, value);
b60cf05a
NC
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
144SV *
145fetch(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);
028f8eaa 155 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
156 if (!result) {
157 XSRETURN_EMPTY;
158 }
159 /* Force mg_get */
160 RETVAL = newSVsv(*result);
161 OUTPUT:
162 RETVAL
2dc92170
NC
163
164void *
165test_hv_free_ent()
166 PPCODE:
167 test_freeent(&Perl_hv_free_ent);
168 XSRETURN(4);
169
170void *
171test_hv_delayfree_ent()
172 PPCODE:
173 test_freeent(&Perl_hv_delayfree_ent);
174 XSRETURN(4);
175
0314122a
NC
176=pod
177
178sub TIEHASH { bless {}, $_[0] }
179sub STORE { $_[0]->{$_[1]} = $_[2] }
180sub FETCH { $_[0]->{$_[1]} }
181sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
182sub NEXTKEY { each %{$_[0]} }
183sub EXISTS { exists $_[0]->{$_[1]} }
184sub DELETE { delete $_[0]->{$_[1]} }
185sub CLEAR { %{$_[0]} = () }
186
187=cut
188
3e61d65a
JH
189MODULE = XS::APItest PACKAGE = XS::APItest
190
191PROTOTYPES: DISABLE
192
193void
194print_double(val)
195 double val
196 CODE:
197 printf("%5.3f\n",val);
198
199int
200have_long_double()
201 CODE:
202#ifdef HAS_LONG_DOUBLE
203 RETVAL = 1;
204#else
205 RETVAL = 0;
206#endif
cabb36f0
CN
207 OUTPUT:
208 RETVAL
3e61d65a
JH
209
210void
211print_long_double()
212 CODE:
213#ifdef HAS_LONG_DOUBLE
fc0bf671 214# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
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
223void
3e61d65a
JH
224print_int(val)
225 int val
226 CODE:
227 printf("%d\n",val);
228
229void
230print_long(val)
231 long val
232 CODE:
233 printf("%ld\n",val);
234
235void
236print_float(val)
237 float val
238 CODE:
239 printf("%5.3f\n",val);
9d911683
NIS
240
241void
242print_flush()
243 CODE:
244 fflush(stdout);
d4b90eee
SH
245
246void
247mpushp()
248 PPCODE:
249 EXTEND(SP, 3);
250 mPUSHp("one", 3);
251 mPUSHp("two", 3);
252 mPUSHp("three", 5);
253 XSRETURN(3);
254
255void
256mpushn()
257 PPCODE:
258 EXTEND(SP, 3);
259 mPUSHn(0.5);
260 mPUSHn(-0.25);
261 mPUSHn(0.125);
262 XSRETURN(3);
263
264void
265mpushi()
266 PPCODE:
267 EXTEND(SP, 3);
d75b63cf
MHM
268 mPUSHi(-1);
269 mPUSHi(2);
270 mPUSHi(-3);
d4b90eee
SH
271 XSRETURN(3);
272
273void
274mpushu()
275 PPCODE:
276 EXTEND(SP, 3);
d75b63cf
MHM
277 mPUSHu(1);
278 mPUSHu(2);
279 mPUSHu(3);
d4b90eee
SH
280 XSRETURN(3);
281
282void
283mxpushp()
284 PPCODE:
285 mXPUSHp("one", 3);
286 mXPUSHp("two", 3);
287 mXPUSHp("three", 5);
288 XSRETURN(3);
289
290void
291mxpushn()
292 PPCODE:
293 mXPUSHn(0.5);
294 mXPUSHn(-0.25);
295 mXPUSHn(0.125);
296 XSRETURN(3);
297
298void
299mxpushi()
300 PPCODE:
d75b63cf
MHM
301 mXPUSHi(-1);
302 mXPUSHi(2);
303 mXPUSHi(-3);
d4b90eee
SH
304 XSRETURN(3);
305
306void
307mxpushu()
308 PPCODE:
d75b63cf
MHM
309 mXPUSHu(1);
310 mXPUSHu(2);
311 mXPUSHu(3);
d4b90eee 312 XSRETURN(3);
d1f347d7
DM
313
314
315void
316call_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
332void
333call_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
349void
350call_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
366void
367eval_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
b8e65a9b 379void
d1f347d7
DM
380eval_pv(p, croak_on_error)
381 const char* p
382 I32 croak_on_error
d1f347d7
DM
383 PPCODE:
384 PUTBACK;
385 EXTEND(SP, 1);
386 PUSHs(eval_pv(p, croak_on_error));
387
388void
389require_pv(pv)
390 const char* pv
d1f347d7
DM
391 PPCODE:
392 PUTBACK;
393 require_pv(pv);
394
0ca3a874
MHM
395int
396exception(throw_e)
397 int throw_e
398 OUTPUT:
399 RETVAL
d1f347d7 400
ef469b03
DM
401void
402mycroak(pv)
403 const char* pv
404 CODE:
405 Perl_croak(aTHX_ "%s", pv);
5d2b1485
NC
406
407SV*
408strtab()
409 CODE:
410 RETVAL = newRV_inc((SV*)PL_strtab);
411 OUTPUT:
412 RETVAL