This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
config_H being the last part of my mkglossary work
[perl5.git] / ext / XS / APItest / APItest.xs
CommitLineData
6a93a7e5 1#define PERL_IN_XS_APITEST
3e61d65a
JH
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
85ce96a1
DM
6
7/* for my_cxt tests */
8
9#define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
10
11typedef struct {
12 int i;
13 SV *sv;
14} my_cxt_t;
15
16START_MY_CXT
17
18/* indirect functions to test the [pa]MY_CXT macros */
f16dd614 19
85ce96a1
DM
20int
21my_cxt_getint_p(pMY_CXT)
22{
23 return MY_CXT.i;
24}
f16dd614 25
85ce96a1
DM
26void
27my_cxt_setint_p(pMY_CXT_ int i)
28{
29 MY_CXT.i = i;
30}
f16dd614
DM
31
32SV*
33my_cxt_getsv_interp()
34{
35#ifdef PERL_IMPLICIT_CONTEXT
36 dTHX;
37 dMY_CXT_INTERP(my_perl);
38#else
39 dMY_CXT;
40#endif
41 return MY_CXT.sv;
42}
43
85ce96a1
DM
44void
45my_cxt_setsv_p(SV* sv _pMY_CXT)
46{
47 MY_CXT.sv = sv;
48}
49
50
9b5c3821
MHM
51/* from exception.c */
52int exception(int);
0314122a 53
2dc92170
NC
54/* A routine to test hv_delayfree_ent
55 (which itself is tested by testing on hv_free_ent */
56
57typedef void (freeent_function)(pTHX_ HV *, register HE *);
58
59void
60test_freeent(freeent_function *f) {
61 dTHX;
62 dSP;
63 HV *test_hash = newHV();
64 HE *victim;
65 SV *test_scalar;
66 U32 results[4];
67 int i;
68
8afd2d2e
NC
69#ifdef PURIFY
70 victim = (HE*)safemalloc(sizeof(HE));
71#else
2dc92170
NC
72 /* Storing then deleting something should ensure that a hash entry is
73 available. */
74 hv_store(test_hash, "", 0, &PL_sv_yes, 0);
75 hv_delete(test_hash, "", 0, 0);
76
77 /* We need to "inline" new_he here as it's static, and the functions we
78 test expect to be able to call del_HE on the HE */
6a93a7e5 79 if (!PL_body_roots[HE_SVSLOT])
2dc92170 80 croak("PL_he_root is 0");
6a93a7e5
NC
81 victim = PL_body_roots[HE_SVSLOT];
82 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
8afd2d2e 83#endif
2dc92170
NC
84
85 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
86
87 test_scalar = newSV(0);
88 SvREFCNT_inc(test_scalar);
de616631 89 HeVAL(victim) = test_scalar;
2dc92170
NC
90
91 /* Need this little game else we free the temps on the return stack. */
92 results[0] = SvREFCNT(test_scalar);
93 SAVETMPS;
94 results[1] = SvREFCNT(test_scalar);
95 f(aTHX_ test_hash, victim);
96 results[2] = SvREFCNT(test_scalar);
97 FREETMPS;
98 results[3] = SvREFCNT(test_scalar);
99
100 i = 0;
101 do {
102 mPUSHu(results[i]);
103 } while (++i < sizeof(results)/sizeof(results[0]));
104
105 /* Goodbye to our extra reference. */
106 SvREFCNT_dec(test_scalar);
107}
108
0314122a
NC
109MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
110
028f8eaa
MHM
111#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
112
0314122a
NC
113bool
114exists(hash, key_sv)
115 PREINIT:
116 STRLEN len;
117 const char *key;
118 INPUT:
119 HV *hash
120 SV *key_sv
121 CODE:
122 key = SvPV(key_sv, len);
028f8eaa 123 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
124 OUTPUT:
125 RETVAL
126
b60cf05a
NC
127SV *
128delete(hash, key_sv)
129 PREINIT:
130 STRLEN len;
131 const char *key;
132 INPUT:
133 HV *hash
134 SV *key_sv
135 CODE:
136 key = SvPV(key_sv, len);
137 /* It's already mortal, so need to increase reference count. */
028f8eaa 138 RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
b60cf05a
NC
139 OUTPUT:
140 RETVAL
141
142SV *
858117f8
NC
143store_ent(hash, key, value)
144 PREINIT:
145 SV *copy;
146 HE *result;
147 INPUT:
148 HV *hash
149 SV *key
150 SV *value
151 CODE:
152 copy = newSV(0);
153 result = hv_store_ent(hash, key, copy, 0);
154 SvSetMagicSV(copy, value);
155 if (!result) {
156 SvREFCNT_dec(copy);
157 XSRETURN_EMPTY;
158 }
159 /* It's about to become mortal, so need to increase reference count.
160 */
161 RETVAL = SvREFCNT_inc(HeVAL(result));
162 OUTPUT:
163 RETVAL
164
165
166SV *
b60cf05a
NC
167store(hash, key_sv, value)
168 PREINIT:
169 STRLEN len;
170 const char *key;
171 SV *copy;
172 SV **result;
173 INPUT:
174 HV *hash
175 SV *key_sv
176 SV *value
177 CODE:
178 key = SvPV(key_sv, len);
179 copy = newSV(0);
028f8eaa 180 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 181 SvSetMagicSV(copy, value);
b60cf05a
NC
182 if (!result) {
183 SvREFCNT_dec(copy);
184 XSRETURN_EMPTY;
185 }
186 /* It's about to become mortal, so need to increase reference count.
187 */
188 RETVAL = SvREFCNT_inc(*result);
189 OUTPUT:
190 RETVAL
191
192
193SV *
194fetch(hash, key_sv)
195 PREINIT:
196 STRLEN len;
197 const char *key;
198 SV **result;
199 INPUT:
200 HV *hash
201 SV *key_sv
202 CODE:
203 key = SvPV(key_sv, len);
028f8eaa 204 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
205 if (!result) {
206 XSRETURN_EMPTY;
207 }
208 /* Force mg_get */
209 RETVAL = newSVsv(*result);
210 OUTPUT:
211 RETVAL
2dc92170 212
439efdfe 213void
2dc92170
NC
214test_hv_free_ent()
215 PPCODE:
216 test_freeent(&Perl_hv_free_ent);
217 XSRETURN(4);
218
439efdfe 219void
2dc92170
NC
220test_hv_delayfree_ent()
221 PPCODE:
222 test_freeent(&Perl_hv_delayfree_ent);
223 XSRETURN(4);
224
0314122a
NC
225=pod
226
227sub TIEHASH { bless {}, $_[0] }
228sub STORE { $_[0]->{$_[1]} = $_[2] }
229sub FETCH { $_[0]->{$_[1]} }
230sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
231sub NEXTKEY { each %{$_[0]} }
232sub EXISTS { exists $_[0]->{$_[1]} }
233sub DELETE { delete $_[0]->{$_[1]} }
234sub CLEAR { %{$_[0]} = () }
235
236=cut
237
3e61d65a
JH
238MODULE = XS::APItest PACKAGE = XS::APItest
239
240PROTOTYPES: DISABLE
241
85ce96a1
DM
242BOOT:
243{
244 MY_CXT_INIT;
245 MY_CXT.i = 99;
246 MY_CXT.sv = newSVpv("initial",0);
247}
248
249void
250CLONE(...)
251 CODE:
252 MY_CXT_CLONE;
253 MY_CXT.sv = newSVpv("initial_clone",0);
254
3e61d65a
JH
255void
256print_double(val)
257 double val
258 CODE:
259 printf("%5.3f\n",val);
260
261int
262have_long_double()
263 CODE:
264#ifdef HAS_LONG_DOUBLE
265 RETVAL = 1;
266#else
267 RETVAL = 0;
268#endif
cabb36f0
CN
269 OUTPUT:
270 RETVAL
3e61d65a
JH
271
272void
273print_long_double()
274 CODE:
275#ifdef HAS_LONG_DOUBLE
fc0bf671 276# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
277 long double val = 7.0;
278 printf("%5.3" PERL_PRIfldbl "\n",val);
279# else
280 double val = 7.0;
281 printf("%5.3f\n",val);
282# endif
283#endif
284
285void
3e61d65a
JH
286print_int(val)
287 int val
288 CODE:
289 printf("%d\n",val);
290
291void
292print_long(val)
293 long val
294 CODE:
295 printf("%ld\n",val);
296
297void
298print_float(val)
299 float val
300 CODE:
301 printf("%5.3f\n",val);
9d911683
NIS
302
303void
304print_flush()
305 CODE:
306 fflush(stdout);
d4b90eee
SH
307
308void
309mpushp()
310 PPCODE:
311 EXTEND(SP, 3);
312 mPUSHp("one", 3);
313 mPUSHp("two", 3);
314 mPUSHp("three", 5);
315 XSRETURN(3);
316
317void
318mpushn()
319 PPCODE:
320 EXTEND(SP, 3);
321 mPUSHn(0.5);
322 mPUSHn(-0.25);
323 mPUSHn(0.125);
324 XSRETURN(3);
325
326void
327mpushi()
328 PPCODE:
329 EXTEND(SP, 3);
d75b63cf
MHM
330 mPUSHi(-1);
331 mPUSHi(2);
332 mPUSHi(-3);
d4b90eee
SH
333 XSRETURN(3);
334
335void
336mpushu()
337 PPCODE:
338 EXTEND(SP, 3);
d75b63cf
MHM
339 mPUSHu(1);
340 mPUSHu(2);
341 mPUSHu(3);
d4b90eee
SH
342 XSRETURN(3);
343
344void
345mxpushp()
346 PPCODE:
347 mXPUSHp("one", 3);
348 mXPUSHp("two", 3);
349 mXPUSHp("three", 5);
350 XSRETURN(3);
351
352void
353mxpushn()
354 PPCODE:
355 mXPUSHn(0.5);
356 mXPUSHn(-0.25);
357 mXPUSHn(0.125);
358 XSRETURN(3);
359
360void
361mxpushi()
362 PPCODE:
d75b63cf
MHM
363 mXPUSHi(-1);
364 mXPUSHi(2);
365 mXPUSHi(-3);
d4b90eee
SH
366 XSRETURN(3);
367
368void
369mxpushu()
370 PPCODE:
d75b63cf
MHM
371 mXPUSHu(1);
372 mXPUSHu(2);
373 mXPUSHu(3);
d4b90eee 374 XSRETURN(3);
d1f347d7
DM
375
376
377void
378call_sv(sv, flags, ...)
379 SV* sv
380 I32 flags
381 PREINIT:
382 I32 i;
383 PPCODE:
384 for (i=0; i<items-2; i++)
385 ST(i) = ST(i+2); /* pop first two args */
386 PUSHMARK(SP);
387 SP += items - 2;
388 PUTBACK;
389 i = call_sv(sv, flags);
390 SPAGAIN;
391 EXTEND(SP, 1);
392 PUSHs(sv_2mortal(newSViv(i)));
393
394void
395call_pv(subname, flags, ...)
396 char* subname
397 I32 flags
398 PREINIT:
399 I32 i;
400 PPCODE:
401 for (i=0; i<items-2; i++)
402 ST(i) = ST(i+2); /* pop first two args */
403 PUSHMARK(SP);
404 SP += items - 2;
405 PUTBACK;
406 i = call_pv(subname, flags);
407 SPAGAIN;
408 EXTEND(SP, 1);
409 PUSHs(sv_2mortal(newSViv(i)));
410
411void
412call_method(methname, flags, ...)
413 char* methname
414 I32 flags
415 PREINIT:
416 I32 i;
417 PPCODE:
418 for (i=0; i<items-2; i++)
419 ST(i) = ST(i+2); /* pop first two args */
420 PUSHMARK(SP);
421 SP += items - 2;
422 PUTBACK;
423 i = call_method(methname, flags);
424 SPAGAIN;
425 EXTEND(SP, 1);
426 PUSHs(sv_2mortal(newSViv(i)));
427
428void
429eval_sv(sv, flags)
430 SV* sv
431 I32 flags
432 PREINIT:
433 I32 i;
434 PPCODE:
435 PUTBACK;
436 i = eval_sv(sv, flags);
437 SPAGAIN;
438 EXTEND(SP, 1);
439 PUSHs(sv_2mortal(newSViv(i)));
440
b8e65a9b 441void
d1f347d7
DM
442eval_pv(p, croak_on_error)
443 const char* p
444 I32 croak_on_error
d1f347d7
DM
445 PPCODE:
446 PUTBACK;
447 EXTEND(SP, 1);
448 PUSHs(eval_pv(p, croak_on_error));
449
450void
451require_pv(pv)
452 const char* pv
d1f347d7
DM
453 PPCODE:
454 PUTBACK;
455 require_pv(pv);
456
0ca3a874
MHM
457int
458exception(throw_e)
459 int throw_e
460 OUTPUT:
461 RETVAL
d1f347d7 462
ef469b03 463void
7e7a3dfc
GA
464mycroak(sv)
465 SV* sv
ef469b03 466 CODE:
7e7a3dfc
GA
467 if (SvOK(sv)) {
468 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
469 }
470 else {
471 Perl_croak(aTHX_ NULL);
472 }
5d2b1485
NC
473
474SV*
475strtab()
476 CODE:
477 RETVAL = newRV_inc((SV*)PL_strtab);
478 OUTPUT:
479 RETVAL
85ce96a1
DM
480
481int
482my_cxt_getint()
483 CODE:
484 dMY_CXT;
485 RETVAL = my_cxt_getint_p(aMY_CXT);
486 OUTPUT:
487 RETVAL
488
489void
490my_cxt_setint(i)
491 int i;
492 CODE:
493 dMY_CXT;
494 my_cxt_setint_p(aMY_CXT_ i);
495
496void
497my_cxt_getsv()
498 PPCODE:
85ce96a1 499 EXTEND(SP, 1);
f16dd614 500 ST(0) = my_cxt_getsv_interp();
85ce96a1
DM
501 XSRETURN(1);
502
503void
504my_cxt_setsv(sv)
505 SV *sv;
506 CODE:
507 dMY_CXT;
508 SvREFCNT_dec(MY_CXT.sv);
509 my_cxt_setsv_p(sv _aMY_CXT);
510 SvREFCNT_inc(sv);