This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add hv_copy_hints_hv and save_hints to the API
[perl5.git] / ext / XS-APItest / APItest.xs
1 #define PERL_IN_XS_APITEST
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 typedef SV *SVREF;
7 typedef PTR_TBL_t *XS__APItest__PtrTable;
8
9 /* for my_cxt tests */
10
11 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
12
13 typedef struct {
14     int i;
15     SV *sv;
16     GV *cscgv;
17     AV *cscav;
18     AV *bhkav;
19     bool bhk_record;
20 } my_cxt_t;
21
22 START_MY_CXT
23
24 /* indirect functions to test the [pa]MY_CXT macros */
25
26 int
27 my_cxt_getint_p(pMY_CXT)
28 {
29     return MY_CXT.i;
30 }
31
32 void
33 my_cxt_setint_p(pMY_CXT_ int i)
34 {
35     MY_CXT.i = i;
36 }
37
38 SV*
39 my_cxt_getsv_interp_context(void)
40 {
41     dTHX;
42     dMY_CXT_INTERP(my_perl);
43     return MY_CXT.sv;
44 }
45
46 SV*
47 my_cxt_getsv_interp(void)
48 {
49     dMY_CXT;
50     return MY_CXT.sv;
51 }
52
53 void
54 my_cxt_setsv_p(SV* sv _pMY_CXT)
55 {
56     MY_CXT.sv = sv;
57 }
58
59
60 /* from exception.c */
61 int apitest_exception(int);
62
63 /* from core_or_not.inc */
64 bool sv_setsv_cow_hashkey_core(void);
65 bool sv_setsv_cow_hashkey_notcore(void);
66
67 /* A routine to test hv_delayfree_ent
68    (which itself is tested by testing on hv_free_ent  */
69
70 typedef void (freeent_function)(pTHX_ HV *, register HE *);
71
72 void
73 test_freeent(freeent_function *f) {
74     dTHX;
75     dSP;
76     HV *test_hash = newHV();
77     HE *victim;
78     SV *test_scalar;
79     U32 results[4];
80     int i;
81
82 #ifdef PURIFY
83     victim = (HE*)safemalloc(sizeof(HE));
84 #else
85     /* Storing then deleting something should ensure that a hash entry is
86        available.  */
87     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
88     hv_delete(test_hash, "", 0, 0);
89
90     /* We need to "inline" new_he here as it's static, and the functions we
91        test expect to be able to call del_HE on the HE  */
92     if (!PL_body_roots[HE_SVSLOT])
93         croak("PL_he_root is 0");
94     victim = (HE*) PL_body_roots[HE_SVSLOT];
95     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
96 #endif
97
98     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
99
100     test_scalar = newSV(0);
101     SvREFCNT_inc(test_scalar);
102     HeVAL(victim) = test_scalar;
103
104     /* Need this little game else we free the temps on the return stack.  */
105     results[0] = SvREFCNT(test_scalar);
106     SAVETMPS;
107     results[1] = SvREFCNT(test_scalar);
108     f(aTHX_ test_hash, victim);
109     results[2] = SvREFCNT(test_scalar);
110     FREETMPS;
111     results[3] = SvREFCNT(test_scalar);
112
113     i = 0;
114     do {
115         mPUSHu(results[i]);
116     } while (++i < sizeof(results)/sizeof(results[0]));
117
118     /* Goodbye to our extra reference.  */
119     SvREFCNT_dec(test_scalar);
120 }
121
122
123 static I32
124 bitflip_key(pTHX_ IV action, SV *field) {
125     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
126     SV *keysv;
127     if (mg && (keysv = mg->mg_obj)) {
128         STRLEN len;
129         const char *p = SvPV(keysv, len);
130
131         if (len) {
132             SV *newkey = newSV(len);
133             char *new_p = SvPVX(newkey);
134
135             if (SvUTF8(keysv)) {
136                 const char *const end = p + len;
137                 while (p < end) {
138                     STRLEN len;
139                     UV chr = utf8_to_uvuni((U8 *)p, &len);
140                     new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
141                     p += len;
142                 }
143                 SvUTF8_on(newkey);
144             } else {
145                 while (len--)
146                     *new_p++ = *p++ ^ 32;
147             }
148             *new_p = '\0';
149             SvCUR_set(newkey, SvCUR(keysv));
150             SvPOK_on(newkey);
151
152             mg->mg_obj = newkey;
153         }
154     }
155     return 0;
156 }
157
158 static I32
159 rot13_key(pTHX_ IV action, SV *field) {
160     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
161     SV *keysv;
162     if (mg && (keysv = mg->mg_obj)) {
163         STRLEN len;
164         const char *p = SvPV(keysv, len);
165
166         if (len) {
167             SV *newkey = newSV(len);
168             char *new_p = SvPVX(newkey);
169
170             /* There's a deliberate fencepost error here to loop len + 1 times
171                to copy the trailing \0  */
172             do {
173                 char new_c = *p++;
174                 /* Try doing this cleanly and clearly in EBCDIC another way: */
175                 switch (new_c) {
176                 case 'A': new_c = 'N'; break;
177                 case 'B': new_c = 'O'; break;
178                 case 'C': new_c = 'P'; break;
179                 case 'D': new_c = 'Q'; break;
180                 case 'E': new_c = 'R'; break;
181                 case 'F': new_c = 'S'; break;
182                 case 'G': new_c = 'T'; break;
183                 case 'H': new_c = 'U'; break;
184                 case 'I': new_c = 'V'; break;
185                 case 'J': new_c = 'W'; break;
186                 case 'K': new_c = 'X'; break;
187                 case 'L': new_c = 'Y'; break;
188                 case 'M': new_c = 'Z'; break;
189                 case 'N': new_c = 'A'; break;
190                 case 'O': new_c = 'B'; break;
191                 case 'P': new_c = 'C'; break;
192                 case 'Q': new_c = 'D'; break;
193                 case 'R': new_c = 'E'; break;
194                 case 'S': new_c = 'F'; break;
195                 case 'T': new_c = 'G'; break;
196                 case 'U': new_c = 'H'; break;
197                 case 'V': new_c = 'I'; break;
198                 case 'W': new_c = 'J'; break;
199                 case 'X': new_c = 'K'; break;
200                 case 'Y': new_c = 'L'; break;
201                 case 'Z': new_c = 'M'; break;
202                 case 'a': new_c = 'n'; break;
203                 case 'b': new_c = 'o'; break;
204                 case 'c': new_c = 'p'; break;
205                 case 'd': new_c = 'q'; break;
206                 case 'e': new_c = 'r'; break;
207                 case 'f': new_c = 's'; break;
208                 case 'g': new_c = 't'; break;
209                 case 'h': new_c = 'u'; break;
210                 case 'i': new_c = 'v'; break;
211                 case 'j': new_c = 'w'; break;
212                 case 'k': new_c = 'x'; break;
213                 case 'l': new_c = 'y'; break;
214                 case 'm': new_c = 'z'; break;
215                 case 'n': new_c = 'a'; break;
216                 case 'o': new_c = 'b'; break;
217                 case 'p': new_c = 'c'; break;
218                 case 'q': new_c = 'd'; break;
219                 case 'r': new_c = 'e'; break;
220                 case 's': new_c = 'f'; break;
221                 case 't': new_c = 'g'; break;
222                 case 'u': new_c = 'h'; break;
223                 case 'v': new_c = 'i'; break;
224                 case 'w': new_c = 'j'; break;
225                 case 'x': new_c = 'k'; break;
226                 case 'y': new_c = 'l'; break;
227                 case 'z': new_c = 'm'; break;
228                 }
229                 *new_p++ = new_c;
230             } while (len--);
231             SvCUR_set(newkey, SvCUR(keysv));
232             SvPOK_on(newkey);
233             if (SvUTF8(keysv))
234                 SvUTF8_on(newkey);
235
236             mg->mg_obj = newkey;
237         }
238     }
239     return 0;
240 }
241
242 STATIC I32
243 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
244     return 0;
245 }
246
247 STATIC MGVTBL rmagical_b = { 0 };
248
249 STATIC void
250 blockhook_csc_start(pTHX_ int full)
251 {
252     dMY_CXT;
253     AV *const cur = GvAV(MY_CXT.cscgv);
254
255     SAVEGENERICSV(GvAV(MY_CXT.cscgv));
256
257     if (cur) {
258         I32 i;
259         AV *const new_av = newAV();
260
261         for (i = 0; i <= av_len(cur); i++) {
262             av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
263         }
264
265         GvAV(MY_CXT.cscgv) = new_av;
266     }
267 }
268
269 STATIC void
270 blockhook_csc_pre_end(pTHX_ OP **o)
271 {
272     dMY_CXT;
273
274     /* if we hit the end of a scope we missed the start of, we need to
275      * unconditionally clear @CSC */
276     if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
277         av_clear(MY_CXT.cscav);
278     }
279
280 }
281
282 STATIC void
283 blockhook_test_start(pTHX_ int full)
284 {
285     dMY_CXT;
286     AV *av;
287     
288     if (MY_CXT.bhk_record) {
289         av = newAV();
290         av_push(av, newSVpvs("start"));
291         av_push(av, newSViv(full));
292         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
293     }
294 }
295
296 STATIC void
297 blockhook_test_pre_end(pTHX_ OP **o)
298 {
299     dMY_CXT;
300
301     if (MY_CXT.bhk_record)
302         av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
303 }
304
305 STATIC void
306 blockhook_test_post_end(pTHX_ OP **o)
307 {
308     dMY_CXT;
309
310     if (MY_CXT.bhk_record)
311         av_push(MY_CXT.bhkav, newSVpvs("post_end"));
312 }
313
314 STATIC void
315 blockhook_test_eval(pTHX_ OP *const o)
316 {
317     dMY_CXT;
318     AV *av;
319
320     if (MY_CXT.bhk_record) {
321         av = newAV();
322         av_push(av, newSVpvs("eval"));
323         av_push(av, newSVpv(OP_NAME(o), 0));
324         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
325     }
326 }
327
328 STATIC BHK bhk_csc, bhk_test;
329
330 #include "const-c.inc"
331
332 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
333
334 INCLUDE: const-xs.inc
335
336 void
337 rot13_hash(hash)
338         HV *hash
339         CODE:
340         {
341             struct ufuncs uf;
342             uf.uf_val = rot13_key;
343             uf.uf_set = 0;
344             uf.uf_index = 0;
345
346             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
347         }
348
349 void
350 bitflip_hash(hash)
351         HV *hash
352         CODE:
353         {
354             struct ufuncs uf;
355             uf.uf_val = bitflip_key;
356             uf.uf_set = 0;
357             uf.uf_index = 0;
358
359             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
360         }
361
362 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
363
364 bool
365 exists(hash, key_sv)
366         PREINIT:
367         STRLEN len;
368         const char *key;
369         INPUT:
370         HV *hash
371         SV *key_sv
372         CODE:
373         key = SvPV(key_sv, len);
374         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
375         OUTPUT:
376         RETVAL
377
378 bool
379 exists_ent(hash, key_sv)
380         PREINIT:
381         INPUT:
382         HV *hash
383         SV *key_sv
384         CODE:
385         RETVAL = hv_exists_ent(hash, key_sv, 0);
386         OUTPUT:
387         RETVAL
388
389 SV *
390 delete(hash, key_sv, flags = 0)
391         PREINIT:
392         STRLEN len;
393         const char *key;
394         INPUT:
395         HV *hash
396         SV *key_sv
397         I32 flags;
398         CODE:
399         key = SvPV(key_sv, len);
400         /* It's already mortal, so need to increase reference count.  */
401         RETVAL
402             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
403         OUTPUT:
404         RETVAL
405
406 SV *
407 delete_ent(hash, key_sv, flags = 0)
408         INPUT:
409         HV *hash
410         SV *key_sv
411         I32 flags;
412         CODE:
413         /* It's already mortal, so need to increase reference count.  */
414         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
415         OUTPUT:
416         RETVAL
417
418 SV *
419 store_ent(hash, key, value)
420         PREINIT:
421         SV *copy;
422         HE *result;
423         INPUT:
424         HV *hash
425         SV *key
426         SV *value
427         CODE:
428         copy = newSV(0);
429         result = hv_store_ent(hash, key, copy, 0);
430         SvSetMagicSV(copy, value);
431         if (!result) {
432             SvREFCNT_dec(copy);
433             XSRETURN_EMPTY;
434         }
435         /* It's about to become mortal, so need to increase reference count.
436          */
437         RETVAL = SvREFCNT_inc(HeVAL(result));
438         OUTPUT:
439         RETVAL
440
441 SV *
442 store(hash, key_sv, value)
443         PREINIT:
444         STRLEN len;
445         const char *key;
446         SV *copy;
447         SV **result;
448         INPUT:
449         HV *hash
450         SV *key_sv
451         SV *value
452         CODE:
453         key = SvPV(key_sv, len);
454         copy = newSV(0);
455         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
456         SvSetMagicSV(copy, value);
457         if (!result) {
458             SvREFCNT_dec(copy);
459             XSRETURN_EMPTY;
460         }
461         /* It's about to become mortal, so need to increase reference count.
462          */
463         RETVAL = SvREFCNT_inc(*result);
464         OUTPUT:
465         RETVAL
466
467 SV *
468 fetch_ent(hash, key_sv)
469         PREINIT:
470         HE *result;
471         INPUT:
472         HV *hash
473         SV *key_sv
474         CODE:
475         result = hv_fetch_ent(hash, key_sv, 0, 0);
476         if (!result) {
477             XSRETURN_EMPTY;
478         }
479         /* Force mg_get  */
480         RETVAL = newSVsv(HeVAL(result));
481         OUTPUT:
482         RETVAL
483
484 SV *
485 fetch(hash, key_sv)
486         PREINIT:
487         STRLEN len;
488         const char *key;
489         SV **result;
490         INPUT:
491         HV *hash
492         SV *key_sv
493         CODE:
494         key = SvPV(key_sv, len);
495         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
496         if (!result) {
497             XSRETURN_EMPTY;
498         }
499         /* Force mg_get  */
500         RETVAL = newSVsv(*result);
501         OUTPUT:
502         RETVAL
503
504 #if defined (hv_common)
505
506 SV *
507 common(params)
508         INPUT:
509         HV *params
510         PREINIT:
511         HE *result;
512         HV *hv = NULL;
513         SV *keysv = NULL;
514         const char *key = NULL;
515         STRLEN klen = 0;
516         int flags = 0;
517         int action = 0;
518         SV *val = NULL;
519         U32 hash = 0;
520         SV **svp;
521         CODE:
522         if ((svp = hv_fetchs(params, "hv", 0))) {
523             SV *const rv = *svp;
524             if (!SvROK(rv))
525                 croak("common passed a non-reference for parameter hv");
526             hv = (HV *)SvRV(rv);
527         }
528         if ((svp = hv_fetchs(params, "keysv", 0)))
529             keysv = *svp;
530         if ((svp = hv_fetchs(params, "keypv", 0))) {
531             key = SvPV_const(*svp, klen);
532             if (SvUTF8(*svp))
533                 flags = HVhek_UTF8;
534         }
535         if ((svp = hv_fetchs(params, "action", 0)))
536             action = SvIV(*svp);
537         if ((svp = hv_fetchs(params, "val", 0)))
538             val = newSVsv(*svp);
539         if ((svp = hv_fetchs(params, "hash", 0)))
540             hash = SvUV(*svp);
541
542         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
543             PERL_HASH(hash, key, klen);
544         }
545         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
546             STRLEN len;
547             const char *const p = SvPV(keysv, len);
548             PERL_HASH(hash, p, len);
549         }
550
551         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
552         if (!result) {
553             XSRETURN_EMPTY;
554         }
555         /* Force mg_get  */
556         RETVAL = newSVsv(HeVAL(result));
557         OUTPUT:
558         RETVAL
559
560 #endif
561
562 void
563 test_hv_free_ent()
564         PPCODE:
565         test_freeent(&Perl_hv_free_ent);
566         XSRETURN(4);
567
568 void
569 test_hv_delayfree_ent()
570         PPCODE:
571         test_freeent(&Perl_hv_delayfree_ent);
572         XSRETURN(4);
573
574 SV *
575 test_share_unshare_pvn(input)
576         PREINIT:
577         STRLEN len;
578         U32 hash;
579         char *pvx;
580         char *p;
581         INPUT:
582         SV *input
583         CODE:
584         pvx = SvPV(input, len);
585         PERL_HASH(hash, pvx, len);
586         p = sharepvn(pvx, len, hash);
587         RETVAL = newSVpvn(p, len);
588         unsharepvn(p, len, hash);
589         OUTPUT:
590         RETVAL
591
592 #if PERL_VERSION >= 9
593
594 bool
595 refcounted_he_exists(key, level=0)
596         SV *key
597         IV level
598         CODE:
599         if (level) {
600             croak("level must be zero, not %"IVdf, level);
601         }
602         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
603                                            key, NULL, 0, 0, 0)
604                   != &PL_sv_placeholder);
605         OUTPUT:
606         RETVAL
607
608 SV *
609 refcounted_he_fetch(key, level=0)
610         SV *key
611         IV level
612         CODE:
613         if (level) {
614             croak("level must be zero, not %"IVdf, level);
615         }
616         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
617                                           NULL, 0, 0, 0);
618         SvREFCNT_inc(RETVAL);
619         OUTPUT:
620         RETVAL
621
622 #endif
623
624 =pod
625
626 sub TIEHASH  { bless {}, $_[0] }
627 sub STORE    { $_[0]->{$_[1]} = $_[2] }
628 sub FETCH    { $_[0]->{$_[1]} }
629 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
630 sub NEXTKEY  { each %{$_[0]} }
631 sub EXISTS   { exists $_[0]->{$_[1]} }
632 sub DELETE   { delete $_[0]->{$_[1]} }
633 sub CLEAR    { %{$_[0]} = () }
634
635 =cut
636
637 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
638
639 void
640 make_temp_mg_lv(sv)
641 SV* sv
642     PREINIT:
643         SV * const lv = newSV_type(SVt_PVLV);
644         STRLEN len;
645     PPCODE:
646         SvPV(sv, len);
647
648         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
649         LvTYPE(lv) = 'x';
650         LvTARG(lv) = SvREFCNT_inc_simple(sv);
651         LvTARGOFF(lv) = len == 0 ? 0 : 1;
652         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
653
654         EXTEND(SP, 1);
655         ST(0) = sv_2mortal(lv);
656         XSRETURN(1);
657
658
659 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
660
661 void
662 ptr_table_new(classname)
663 const char * classname
664     PPCODE:
665     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
666
667 void
668 DESTROY(table)
669 XS::APItest::PtrTable table
670     CODE:
671     ptr_table_free(table);
672
673 void
674 ptr_table_store(table, from, to)
675 XS::APItest::PtrTable table
676 SVREF from
677 SVREF to
678    CODE:
679    ptr_table_store(table, from, to);
680
681 UV
682 ptr_table_fetch(table, from)
683 XS::APItest::PtrTable table
684 SVREF from
685    CODE:
686    RETVAL = PTR2UV(ptr_table_fetch(table, from));
687    OUTPUT:
688    RETVAL
689
690 void
691 ptr_table_split(table)
692 XS::APItest::PtrTable table
693
694 void
695 ptr_table_clear(table)
696 XS::APItest::PtrTable table
697
698 MODULE = XS::APItest            PACKAGE = XS::APItest
699
700 PROTOTYPES: DISABLE
701
702 BOOT:
703 {
704     MY_CXT_INIT;
705
706     MY_CXT.i  = 99;
707     MY_CXT.sv = newSVpv("initial",0);
708
709     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
710     MY_CXT.bhk_record = 0;
711
712     BhkENTRY_set(&bhk_test, start, blockhook_test_start);
713     BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
714     BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
715     BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
716     Perl_blockhook_register(aTHX_ &bhk_test);
717
718     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
719         GV_ADDMULTI, SVt_PVAV);
720     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
721
722     BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
723     BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
724     Perl_blockhook_register(aTHX_ &bhk_csc);
725 }
726
727 void
728 CLONE(...)
729     CODE:
730     MY_CXT_CLONE;
731     MY_CXT.sv = newSVpv("initial_clone",0);
732     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
733         GV_ADDMULTI, SVt_PVAV);
734     MY_CXT.cscav = NULL;
735     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
736     MY_CXT.bhk_record = 0;
737
738 void
739 print_double(val)
740         double val
741         CODE:
742         printf("%5.3f\n",val);
743
744 int
745 have_long_double()
746         CODE:
747 #ifdef HAS_LONG_DOUBLE
748         RETVAL = 1;
749 #else
750         RETVAL = 0;
751 #endif
752         OUTPUT:
753         RETVAL
754
755 void
756 print_long_double()
757         CODE:
758 #ifdef HAS_LONG_DOUBLE
759 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
760         long double val = 7.0;
761         printf("%5.3" PERL_PRIfldbl "\n",val);
762 #   else
763         double val = 7.0;
764         printf("%5.3f\n",val);
765 #   endif
766 #endif
767
768 void
769 print_int(val)
770         int val
771         CODE:
772         printf("%d\n",val);
773
774 void
775 print_long(val)
776         long val
777         CODE:
778         printf("%ld\n",val);
779
780 void
781 print_float(val)
782         float val
783         CODE:
784         printf("%5.3f\n",val);
785         
786 void
787 print_flush()
788         CODE:
789         fflush(stdout);
790
791 void
792 mpushp()
793         PPCODE:
794         EXTEND(SP, 3);
795         mPUSHp("one", 3);
796         mPUSHp("two", 3);
797         mPUSHp("three", 5);
798         XSRETURN(3);
799
800 void
801 mpushn()
802         PPCODE:
803         EXTEND(SP, 3);
804         mPUSHn(0.5);
805         mPUSHn(-0.25);
806         mPUSHn(0.125);
807         XSRETURN(3);
808
809 void
810 mpushi()
811         PPCODE:
812         EXTEND(SP, 3);
813         mPUSHi(-1);
814         mPUSHi(2);
815         mPUSHi(-3);
816         XSRETURN(3);
817
818 void
819 mpushu()
820         PPCODE:
821         EXTEND(SP, 3);
822         mPUSHu(1);
823         mPUSHu(2);
824         mPUSHu(3);
825         XSRETURN(3);
826
827 void
828 mxpushp()
829         PPCODE:
830         mXPUSHp("one", 3);
831         mXPUSHp("two", 3);
832         mXPUSHp("three", 5);
833         XSRETURN(3);
834
835 void
836 mxpushn()
837         PPCODE:
838         mXPUSHn(0.5);
839         mXPUSHn(-0.25);
840         mXPUSHn(0.125);
841         XSRETURN(3);
842
843 void
844 mxpushi()
845         PPCODE:
846         mXPUSHi(-1);
847         mXPUSHi(2);
848         mXPUSHi(-3);
849         XSRETURN(3);
850
851 void
852 mxpushu()
853         PPCODE:
854         mXPUSHu(1);
855         mXPUSHu(2);
856         mXPUSHu(3);
857         XSRETURN(3);
858
859
860 void
861 call_sv(sv, flags, ...)
862     SV* sv
863     I32 flags
864     PREINIT:
865         I32 i;
866     PPCODE:
867         for (i=0; i<items-2; i++)
868             ST(i) = ST(i+2); /* pop first two args */
869         PUSHMARK(SP);
870         SP += items - 2;
871         PUTBACK;
872         i = call_sv(sv, flags);
873         SPAGAIN;
874         EXTEND(SP, 1);
875         PUSHs(sv_2mortal(newSViv(i)));
876
877 void
878 call_pv(subname, flags, ...)
879     char* subname
880     I32 flags
881     PREINIT:
882         I32 i;
883     PPCODE:
884         for (i=0; i<items-2; i++)
885             ST(i) = ST(i+2); /* pop first two args */
886         PUSHMARK(SP);
887         SP += items - 2;
888         PUTBACK;
889         i = call_pv(subname, flags);
890         SPAGAIN;
891         EXTEND(SP, 1);
892         PUSHs(sv_2mortal(newSViv(i)));
893
894 void
895 call_method(methname, flags, ...)
896     char* methname
897     I32 flags
898     PREINIT:
899         I32 i;
900     PPCODE:
901         for (i=0; i<items-2; i++)
902             ST(i) = ST(i+2); /* pop first two args */
903         PUSHMARK(SP);
904         SP += items - 2;
905         PUTBACK;
906         i = call_method(methname, flags);
907         SPAGAIN;
908         EXTEND(SP, 1);
909         PUSHs(sv_2mortal(newSViv(i)));
910
911 void
912 eval_sv(sv, flags)
913     SV* sv
914     I32 flags
915     PREINIT:
916         I32 i;
917     PPCODE:
918         PUTBACK;
919         i = eval_sv(sv, flags);
920         SPAGAIN;
921         EXTEND(SP, 1);
922         PUSHs(sv_2mortal(newSViv(i)));
923
924 void
925 eval_pv(p, croak_on_error)
926     const char* p
927     I32 croak_on_error
928     PPCODE:
929         PUTBACK;
930         EXTEND(SP, 1);
931         PUSHs(eval_pv(p, croak_on_error));
932
933 void
934 require_pv(pv)
935     const char* pv
936     PPCODE:
937         PUTBACK;
938         require_pv(pv);
939
940 int
941 apitest_exception(throw_e)
942     int throw_e
943     OUTPUT:
944         RETVAL
945
946 void
947 mycroak(sv)
948     SV* sv
949     CODE:
950     if (SvOK(sv)) {
951         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
952     }
953     else {
954         Perl_croak(aTHX_ NULL);
955     }
956
957 SV*
958 strtab()
959    CODE:
960    RETVAL = newRV_inc((SV*)PL_strtab);
961    OUTPUT:
962    RETVAL
963
964 int
965 my_cxt_getint()
966     CODE:
967         dMY_CXT;
968         RETVAL = my_cxt_getint_p(aMY_CXT);
969     OUTPUT:
970         RETVAL
971
972 void
973 my_cxt_setint(i)
974     int i;
975     CODE:
976         dMY_CXT;
977         my_cxt_setint_p(aMY_CXT_ i);
978
979 void
980 my_cxt_getsv(how)
981     bool how;
982     PPCODE:
983         EXTEND(SP, 1);
984         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
985         XSRETURN(1);
986
987 void
988 my_cxt_setsv(sv)
989     SV *sv;
990     CODE:
991         dMY_CXT;
992         SvREFCNT_dec(MY_CXT.sv);
993         my_cxt_setsv_p(sv _aMY_CXT);
994         SvREFCNT_inc(sv);
995
996 bool
997 sv_setsv_cow_hashkey_core()
998
999 bool
1000 sv_setsv_cow_hashkey_notcore()
1001
1002 void
1003 rmagical_cast(sv, type)
1004     SV *sv;
1005     SV *type;
1006     PREINIT:
1007         struct ufuncs uf;
1008     PPCODE:
1009         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1010         sv = SvRV(sv);
1011         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1012         uf.uf_val = rmagical_a_dummy;
1013         uf.uf_set = NULL;
1014         uf.uf_index = 0;
1015         if (SvTRUE(type)) { /* b */
1016             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1017         } else { /* a */
1018             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1019         }
1020         XSRETURN_YES;
1021
1022 void
1023 rmagical_flags(sv)
1024     SV *sv;
1025     PPCODE:
1026         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1027         sv = SvRV(sv);
1028         EXTEND(SP, 3); 
1029         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1030         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1031         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1032         XSRETURN(3);
1033
1034 void
1035 my_caller(level)
1036         I32 level
1037     PREINIT:
1038         const PERL_CONTEXT *cx, *dbcx;
1039         const char *pv;
1040         const GV *gv;
1041         HV *hv;
1042     PPCODE:
1043         cx = caller_cx(level, &dbcx);
1044         EXTEND(SP, 8);
1045
1046         pv = CopSTASHPV(cx->blk_oldcop);
1047         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1048         gv = CvGV(cx->blk_sub.cv);
1049         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1050
1051         pv = CopSTASHPV(dbcx->blk_oldcop);
1052         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1053         gv = CvGV(dbcx->blk_sub.cv);
1054         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1055
1056         ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1057         ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1058         ST(6) = cop_hints_fetchsv(cx->blk_oldcop, 
1059                 sv_2mortal(newSVpvn("foo", 3)), 0);
1060
1061         hv = cop_hints_2hv(cx->blk_oldcop);
1062         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1063
1064         XSRETURN(8);
1065
1066 void
1067 DPeek (sv)
1068     SV   *sv
1069
1070   PPCODE:
1071     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1072     XSRETURN (1);
1073
1074 void
1075 BEGIN()
1076     CODE:
1077         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1078
1079 void
1080 CHECK()
1081     CODE:
1082         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1083
1084 void
1085 UNITCHECK()
1086     CODE:
1087         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1088
1089 void
1090 INIT()
1091     CODE:
1092         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1093
1094 void
1095 END()
1096     CODE:
1097         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1098
1099 void
1100 utf16_to_utf8 (sv, ...)
1101     SV* sv
1102         ALIAS:
1103             utf16_to_utf8_reversed = 1
1104     PREINIT:
1105         STRLEN len;
1106         U8 *source;
1107         SV *dest;
1108         I32 got; /* Gah, badly thought out APIs */
1109     CODE:
1110         source = (U8 *)SvPVbyte(sv, len);
1111         /* Optionally only convert part of the buffer.  */      
1112         if (items > 1) {
1113             len = SvUV(ST(1));
1114         }
1115         /* Mortalise this right now, as we'll be testing croak()s  */
1116         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1117         if (ix) {
1118             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1119         } else {
1120             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1121         }
1122         SvCUR_set(dest, got);
1123         SvPVX(dest)[got] = '\0';
1124         SvPOK_on(dest);
1125         ST(0) = dest;
1126         XSRETURN(1);
1127
1128 void
1129 my_exit(int exitcode)
1130         PPCODE:
1131         my_exit(exitcode);
1132
1133 I32
1134 sv_count()
1135         CODE:
1136             RETVAL = PL_sv_count;
1137         OUTPUT:
1138             RETVAL
1139
1140 void
1141 bhk_record(bool on)
1142     CODE:
1143         dMY_CXT;
1144         MY_CXT.bhk_record = on;
1145         if (on)
1146             av_clear(MY_CXT.bhkav);
1147
1148 void
1149 test_savehints()
1150     PREINIT:
1151         SV **svp, *sv;
1152     CODE:
1153 #define store_hint(KEY, VALUE) \
1154                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1155 #define hint_ok(KEY, EXPECT) \
1156                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1157                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
1158                     (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1159                     SvIV(sv) == (EXPECT))
1160 #define check_hint(KEY, EXPECT) \
1161                 do { if (!hint_ok(KEY, EXPECT)) croak("fail"); } while(0)
1162         PL_hints |= HINT_LOCALIZE_HH;
1163         ENTER;
1164         SAVEHINTS();
1165         PL_hints &= HINT_INTEGER;
1166         store_hint("t0", 123);
1167         store_hint("t1", 456);
1168         if (PL_hints & HINT_INTEGER) croak("fail");
1169         check_hint("t0", 123); check_hint("t1", 456);
1170         ENTER;
1171         SAVEHINTS();
1172         if (PL_hints & HINT_INTEGER) croak("fail");
1173         check_hint("t0", 123); check_hint("t1", 456);
1174         PL_hints |= HINT_INTEGER;
1175         store_hint("t0", 321);
1176         if (!(PL_hints & HINT_INTEGER)) croak("fail");
1177         check_hint("t0", 321); check_hint("t1", 456);
1178         LEAVE;
1179         if (PL_hints & HINT_INTEGER) croak("fail");
1180         check_hint("t0", 123); check_hint("t1", 456);
1181         ENTER;
1182         SAVEHINTS();
1183         if (PL_hints & HINT_INTEGER) croak("fail");
1184         check_hint("t0", 123); check_hint("t1", 456);
1185         store_hint("t1", 654);
1186         if (PL_hints & HINT_INTEGER) croak("fail");
1187         check_hint("t0", 123); check_hint("t1", 654);
1188         LEAVE;
1189         if (PL_hints & HINT_INTEGER) croak("fail");
1190         check_hint("t0", 123); check_hint("t1", 456);
1191         LEAVE;
1192 #undef store_hint
1193 #undef hint_ok
1194 #undef check_hint
1195
1196 void
1197 test_copyhints()
1198     PREINIT:
1199         HV *a, *b;
1200     CODE:
1201         PL_hints |= HINT_LOCALIZE_HH;
1202         ENTER;
1203         SAVEHINTS();
1204         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
1205         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1206         a = newHVhv(GvHV(PL_hintgv));
1207         sv_2mortal((SV*)a);
1208         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
1209         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1210         b = hv_copy_hints_hv(a);
1211         sv_2mortal((SV*)b);
1212         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
1213         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak("fail");
1214         LEAVE;
1215
1216 BOOT:
1217         {
1218         HV* stash;
1219         SV** meth = NULL;
1220         CV* cv;
1221         stash = gv_stashpv("XS::APItest::TempLv", 0);
1222         if (stash)
1223             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
1224         if (!meth)
1225             croak("lost method 'make_temp_mg_lv'");
1226         cv = GvCV(*meth);
1227         CvLVALUE_on(cv);
1228         }