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