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