This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/XS/APItest/t/hash.t was failing because the fieldhash code didn't
[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 51/* from exception.c */
7a646707 52int apitest_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
b54b4831
NC
113
114static I32
115rot13_key(pTHX_ IV action, SV *field) {
116 MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
117 SV *keysv;
118 if (mg && (keysv = mg->mg_obj)) {
119 STRLEN len;
120 const char *p = SvPV(keysv, len);
121
122 if (len) {
123 SV *newkey = newSV(len);
124 char *new_p = SvPVX(newkey);
125
126 /* There's a deliberate fencepost error here to loop len + 1 times
127 to copy the trailing \0 */
128 do {
129 char new_c = *p++;
130 /* Try doing this cleanly and clearly in EBCDIC another way: */
131 switch (new_c) {
132 case 'A': new_c = 'N'; break;
133 case 'B': new_c = 'O'; break;
134 case 'C': new_c = 'P'; break;
135 case 'D': new_c = 'Q'; break;
136 case 'E': new_c = 'R'; break;
137 case 'F': new_c = 'S'; break;
138 case 'G': new_c = 'T'; break;
139 case 'H': new_c = 'U'; break;
140 case 'I': new_c = 'V'; break;
141 case 'J': new_c = 'W'; break;
142 case 'K': new_c = 'X'; break;
143 case 'L': new_c = 'Y'; break;
144 case 'M': new_c = 'Z'; break;
145 case 'N': new_c = 'A'; break;
146 case 'O': new_c = 'B'; break;
147 case 'P': new_c = 'C'; break;
148 case 'Q': new_c = 'D'; break;
149 case 'R': new_c = 'E'; break;
150 case 'S': new_c = 'F'; break;
151 case 'T': new_c = 'G'; break;
152 case 'U': new_c = 'H'; break;
153 case 'V': new_c = 'I'; break;
154 case 'W': new_c = 'J'; break;
155 case 'X': new_c = 'K'; break;
156 case 'Y': new_c = 'L'; break;
157 case 'Z': new_c = 'M'; break;
158 case 'a': new_c = 'n'; break;
159 case 'b': new_c = 'o'; break;
160 case 'c': new_c = 'p'; break;
161 case 'd': new_c = 'q'; break;
162 case 'e': new_c = 'r'; break;
163 case 'f': new_c = 's'; break;
164 case 'g': new_c = 't'; break;
165 case 'h': new_c = 'u'; break;
166 case 'i': new_c = 'v'; break;
167 case 'j': new_c = 'w'; break;
168 case 'k': new_c = 'x'; break;
169 case 'l': new_c = 'y'; break;
170 case 'm': new_c = 'z'; break;
171 case 'n': new_c = 'a'; break;
172 case 'o': new_c = 'b'; break;
173 case 'p': new_c = 'c'; break;
174 case 'q': new_c = 'd'; break;
175 case 'r': new_c = 'e'; break;
176 case 's': new_c = 'f'; break;
177 case 't': new_c = 'g'; break;
178 case 'u': new_c = 'h'; break;
179 case 'v': new_c = 'i'; break;
180 case 'w': new_c = 'j'; break;
181 case 'x': new_c = 'k'; break;
182 case 'y': new_c = 'l'; break;
183 case 'z': new_c = 'm'; break;
184 }
185 *new_p++ = new_c;
186 } while (len--);
187 SvCUR_set(newkey, SvCUR(keysv));
188 SvPOK_on(newkey);
189 if (SvUTF8(keysv))
190 SvUTF8_on(newkey);
191
192 mg->mg_obj = newkey;
193 }
194 }
195 return 0;
196}
197
55289a74
NC
198#include "const-c.inc"
199
0314122a
NC
200MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
201
55289a74
NC
202INCLUDE: const-xs.inc
203
b54b4831
NC
204void
205rot13_hash(hash)
206 HV *hash
207 CODE:
208 {
209 struct ufuncs uf;
210 uf.uf_val = rot13_key;
211 uf.uf_set = 0;
212 uf.uf_index = 0;
213
214 sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
215 }
216
028f8eaa
MHM
217#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
218
0314122a
NC
219bool
220exists(hash, key_sv)
221 PREINIT:
222 STRLEN len;
223 const char *key;
224 INPUT:
225 HV *hash
226 SV *key_sv
227 CODE:
228 key = SvPV(key_sv, len);
028f8eaa 229 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
230 OUTPUT:
231 RETVAL
232
bdee33e4
NC
233bool
234exists_ent(hash, key_sv)
235 PREINIT:
236 INPUT:
237 HV *hash
238 SV *key_sv
239 CODE:
240 RETVAL = hv_exists_ent(hash, key_sv, 0);
241 OUTPUT:
242 RETVAL
243
b60cf05a 244SV *
55289a74 245delete(hash, key_sv, flags = 0)
b60cf05a
NC
246 PREINIT:
247 STRLEN len;
248 const char *key;
249 INPUT:
250 HV *hash
251 SV *key_sv
55289a74 252 I32 flags;
b60cf05a
NC
253 CODE:
254 key = SvPV(key_sv, len);
255 /* It's already mortal, so need to increase reference count. */
55289a74
NC
256 RETVAL
257 = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
258 OUTPUT:
259 RETVAL
260
261SV *
262delete_ent(hash, key_sv, flags = 0)
263 INPUT:
264 HV *hash
265 SV *key_sv
266 I32 flags;
267 CODE:
268 /* It's already mortal, so need to increase reference count. */
269 RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
b60cf05a
NC
270 OUTPUT:
271 RETVAL
272
273SV *
858117f8
NC
274store_ent(hash, key, value)
275 PREINIT:
276 SV *copy;
277 HE *result;
278 INPUT:
279 HV *hash
280 SV *key
281 SV *value
282 CODE:
283 copy = newSV(0);
284 result = hv_store_ent(hash, key, copy, 0);
285 SvSetMagicSV(copy, value);
286 if (!result) {
287 SvREFCNT_dec(copy);
288 XSRETURN_EMPTY;
289 }
290 /* It's about to become mortal, so need to increase reference count.
291 */
292 RETVAL = SvREFCNT_inc(HeVAL(result));
293 OUTPUT:
294 RETVAL
295
858117f8 296SV *
b60cf05a
NC
297store(hash, key_sv, value)
298 PREINIT:
299 STRLEN len;
300 const char *key;
301 SV *copy;
302 SV **result;
303 INPUT:
304 HV *hash
305 SV *key_sv
306 SV *value
307 CODE:
308 key = SvPV(key_sv, len);
309 copy = newSV(0);
028f8eaa 310 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 311 SvSetMagicSV(copy, value);
b60cf05a
NC
312 if (!result) {
313 SvREFCNT_dec(copy);
314 XSRETURN_EMPTY;
315 }
316 /* It's about to become mortal, so need to increase reference count.
317 */
318 RETVAL = SvREFCNT_inc(*result);
319 OUTPUT:
320 RETVAL
321
bdee33e4
NC
322SV *
323fetch_ent(hash, key_sv)
324 PREINIT:
325 HE *result;
326 INPUT:
327 HV *hash
328 SV *key_sv
329 CODE:
330 result = hv_fetch_ent(hash, key_sv, 0, 0);
331 if (!result) {
332 XSRETURN_EMPTY;
333 }
334 /* Force mg_get */
335 RETVAL = newSVsv(HeVAL(result));
336 OUTPUT:
337 RETVAL
b60cf05a
NC
338
339SV *
340fetch(hash, key_sv)
341 PREINIT:
342 STRLEN len;
343 const char *key;
344 SV **result;
345 INPUT:
346 HV *hash
347 SV *key_sv
348 CODE:
349 key = SvPV(key_sv, len);
028f8eaa 350 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
351 if (!result) {
352 XSRETURN_EMPTY;
353 }
354 /* Force mg_get */
355 RETVAL = newSVsv(*result);
356 OUTPUT:
357 RETVAL
2dc92170 358
439efdfe 359void
2dc92170
NC
360test_hv_free_ent()
361 PPCODE:
362 test_freeent(&Perl_hv_free_ent);
363 XSRETURN(4);
364
439efdfe 365void
2dc92170
NC
366test_hv_delayfree_ent()
367 PPCODE:
368 test_freeent(&Perl_hv_delayfree_ent);
369 XSRETURN(4);
35ab5632
NC
370
371SV *
372test_share_unshare_pvn(input)
373 PREINIT:
35ab5632
NC
374 STRLEN len;
375 U32 hash;
376 char *pvx;
377 char *p;
378 INPUT:
379 SV *input
380 CODE:
381 pvx = SvPV(input, len);
382 PERL_HASH(hash, pvx, len);
383 p = sharepvn(pvx, len, hash);
384 RETVAL = newSVpvn(p, len);
385 unsharepvn(p, len, hash);
386 OUTPUT:
387 RETVAL
d8c5b3c5
NC
388
389bool
390refcounted_he_exists(key, level=0)
391 SV *key
392 IV level
393 CODE:
394 if (level) {
395 croak("level must be zero, not %"IVdf, level);
396 }
397 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
398 key, NULL, 0, 0, 0)
399 != &PL_sv_placeholder);
400 OUTPUT:
401 RETVAL
402
403
404SV *
405refcounted_he_fetch(key, level=0)
406 SV *key
407 IV level
408 CODE:
409 if (level) {
410 croak("level must be zero, not %"IVdf, level);
411 }
412 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
413 NULL, 0, 0, 0);
414 SvREFCNT_inc(RETVAL);
415 OUTPUT:
416 RETVAL
417
35ab5632 418
0314122a
NC
419=pod
420
421sub TIEHASH { bless {}, $_[0] }
422sub STORE { $_[0]->{$_[1]} = $_[2] }
423sub FETCH { $_[0]->{$_[1]} }
424sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
425sub NEXTKEY { each %{$_[0]} }
426sub EXISTS { exists $_[0]->{$_[1]} }
427sub DELETE { delete $_[0]->{$_[1]} }
428sub CLEAR { %{$_[0]} = () }
429
430=cut
431
3e61d65a
JH
432MODULE = XS::APItest PACKAGE = XS::APItest
433
434PROTOTYPES: DISABLE
435
85ce96a1
DM
436BOOT:
437{
438 MY_CXT_INIT;
439 MY_CXT.i = 99;
440 MY_CXT.sv = newSVpv("initial",0);
441}
442
443void
444CLONE(...)
445 CODE:
446 MY_CXT_CLONE;
447 MY_CXT.sv = newSVpv("initial_clone",0);
448
3e61d65a
JH
449void
450print_double(val)
451 double val
452 CODE:
453 printf("%5.3f\n",val);
454
455int
456have_long_double()
457 CODE:
458#ifdef HAS_LONG_DOUBLE
459 RETVAL = 1;
460#else
461 RETVAL = 0;
462#endif
cabb36f0
CN
463 OUTPUT:
464 RETVAL
3e61d65a
JH
465
466void
467print_long_double()
468 CODE:
469#ifdef HAS_LONG_DOUBLE
fc0bf671 470# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
471 long double val = 7.0;
472 printf("%5.3" PERL_PRIfldbl "\n",val);
473# else
474 double val = 7.0;
475 printf("%5.3f\n",val);
476# endif
477#endif
478
479void
3e61d65a
JH
480print_int(val)
481 int val
482 CODE:
483 printf("%d\n",val);
484
485void
486print_long(val)
487 long val
488 CODE:
489 printf("%ld\n",val);
490
491void
492print_float(val)
493 float val
494 CODE:
495 printf("%5.3f\n",val);
9d911683
NIS
496
497void
498print_flush()
499 CODE:
500 fflush(stdout);
d4b90eee
SH
501
502void
503mpushp()
504 PPCODE:
505 EXTEND(SP, 3);
506 mPUSHp("one", 3);
507 mPUSHp("two", 3);
508 mPUSHp("three", 5);
509 XSRETURN(3);
510
511void
512mpushn()
513 PPCODE:
514 EXTEND(SP, 3);
515 mPUSHn(0.5);
516 mPUSHn(-0.25);
517 mPUSHn(0.125);
518 XSRETURN(3);
519
520void
521mpushi()
522 PPCODE:
523 EXTEND(SP, 3);
d75b63cf
MHM
524 mPUSHi(-1);
525 mPUSHi(2);
526 mPUSHi(-3);
d4b90eee
SH
527 XSRETURN(3);
528
529void
530mpushu()
531 PPCODE:
532 EXTEND(SP, 3);
d75b63cf
MHM
533 mPUSHu(1);
534 mPUSHu(2);
535 mPUSHu(3);
d4b90eee
SH
536 XSRETURN(3);
537
538void
539mxpushp()
540 PPCODE:
541 mXPUSHp("one", 3);
542 mXPUSHp("two", 3);
543 mXPUSHp("three", 5);
544 XSRETURN(3);
545
546void
547mxpushn()
548 PPCODE:
549 mXPUSHn(0.5);
550 mXPUSHn(-0.25);
551 mXPUSHn(0.125);
552 XSRETURN(3);
553
554void
555mxpushi()
556 PPCODE:
d75b63cf
MHM
557 mXPUSHi(-1);
558 mXPUSHi(2);
559 mXPUSHi(-3);
d4b90eee
SH
560 XSRETURN(3);
561
562void
563mxpushu()
564 PPCODE:
d75b63cf
MHM
565 mXPUSHu(1);
566 mXPUSHu(2);
567 mXPUSHu(3);
d4b90eee 568 XSRETURN(3);
d1f347d7
DM
569
570
571void
572call_sv(sv, flags, ...)
573 SV* sv
574 I32 flags
575 PREINIT:
576 I32 i;
577 PPCODE:
578 for (i=0; i<items-2; i++)
579 ST(i) = ST(i+2); /* pop first two args */
580 PUSHMARK(SP);
581 SP += items - 2;
582 PUTBACK;
583 i = call_sv(sv, flags);
584 SPAGAIN;
585 EXTEND(SP, 1);
586 PUSHs(sv_2mortal(newSViv(i)));
587
588void
589call_pv(subname, flags, ...)
590 char* subname
591 I32 flags
592 PREINIT:
593 I32 i;
594 PPCODE:
595 for (i=0; i<items-2; i++)
596 ST(i) = ST(i+2); /* pop first two args */
597 PUSHMARK(SP);
598 SP += items - 2;
599 PUTBACK;
600 i = call_pv(subname, flags);
601 SPAGAIN;
602 EXTEND(SP, 1);
603 PUSHs(sv_2mortal(newSViv(i)));
604
605void
606call_method(methname, flags, ...)
607 char* methname
608 I32 flags
609 PREINIT:
610 I32 i;
611 PPCODE:
612 for (i=0; i<items-2; i++)
613 ST(i) = ST(i+2); /* pop first two args */
614 PUSHMARK(SP);
615 SP += items - 2;
616 PUTBACK;
617 i = call_method(methname, flags);
618 SPAGAIN;
619 EXTEND(SP, 1);
620 PUSHs(sv_2mortal(newSViv(i)));
621
622void
623eval_sv(sv, flags)
624 SV* sv
625 I32 flags
626 PREINIT:
627 I32 i;
628 PPCODE:
629 PUTBACK;
630 i = eval_sv(sv, flags);
631 SPAGAIN;
632 EXTEND(SP, 1);
633 PUSHs(sv_2mortal(newSViv(i)));
634
b8e65a9b 635void
d1f347d7
DM
636eval_pv(p, croak_on_error)
637 const char* p
638 I32 croak_on_error
d1f347d7
DM
639 PPCODE:
640 PUTBACK;
641 EXTEND(SP, 1);
642 PUSHs(eval_pv(p, croak_on_error));
643
644void
645require_pv(pv)
646 const char* pv
d1f347d7
DM
647 PPCODE:
648 PUTBACK;
649 require_pv(pv);
650
0ca3a874 651int
7a646707 652apitest_exception(throw_e)
0ca3a874
MHM
653 int throw_e
654 OUTPUT:
655 RETVAL
d1f347d7 656
ef469b03 657void
7e7a3dfc
GA
658mycroak(sv)
659 SV* sv
ef469b03 660 CODE:
7e7a3dfc
GA
661 if (SvOK(sv)) {
662 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
663 }
664 else {
665 Perl_croak(aTHX_ NULL);
666 }
5d2b1485
NC
667
668SV*
669strtab()
670 CODE:
671 RETVAL = newRV_inc((SV*)PL_strtab);
672 OUTPUT:
673 RETVAL
85ce96a1
DM
674
675int
676my_cxt_getint()
677 CODE:
678 dMY_CXT;
679 RETVAL = my_cxt_getint_p(aMY_CXT);
680 OUTPUT:
681 RETVAL
682
683void
684my_cxt_setint(i)
685 int i;
686 CODE:
687 dMY_CXT;
688 my_cxt_setint_p(aMY_CXT_ i);
689
690void
691my_cxt_getsv()
692 PPCODE:
85ce96a1 693 EXTEND(SP, 1);
f16dd614 694 ST(0) = my_cxt_getsv_interp();
85ce96a1
DM
695 XSRETURN(1);
696
697void
698my_cxt_setsv(sv)
699 SV *sv;
700 CODE:
701 dMY_CXT;
702 SvREFCNT_dec(MY_CXT.sv);
703 my_cxt_setsv_p(sv _aMY_CXT);
704 SvREFCNT_inc(sv);
34482cd6
NC
705
706bool
707sv_setsv_cow_hashkey_core()
708
709bool
710sv_setsv_cow_hashkey_notcore()
84ac5fd7
NC
711
712void
713BEGIN()
714 CODE:
715 sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
716
717void
718CHECK()
719 CODE:
720 sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
721
722void
723UNITCHECK()
724 CODE:
0932863f 725 sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
84ac5fd7
NC
726
727void
728INIT()
729 CODE:
730 sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
731
732void
733END()
734 CODE:
735 sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));