This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert "Make the peep recurse via PL_peepp"
[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
638 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
639
640 void
641 make_temp_mg_lv(sv)
642 SV* sv
643     PREINIT:
644         SV * const lv = newSV_type(SVt_PVLV);
645         STRLEN len;
646     PPCODE:
647         SvPV(sv, len);
648
649         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
650         LvTYPE(lv) = 'x';
651         LvTARG(lv) = SvREFCNT_inc_simple(sv);
652         LvTARGOFF(lv) = len == 0 ? 0 : 1;
653         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
654
655         EXTEND(SP, 1);
656         ST(0) = sv_2mortal(lv);
657         XSRETURN(1);
658
659
660 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
661
662 void
663 ptr_table_new(classname)
664 const char * classname
665     PPCODE:
666     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
667
668 void
669 DESTROY(table)
670 XS::APItest::PtrTable table
671     CODE:
672     ptr_table_free(table);
673
674 void
675 ptr_table_store(table, from, to)
676 XS::APItest::PtrTable table
677 SVREF from
678 SVREF to
679    CODE:
680    ptr_table_store(table, from, to);
681
682 UV
683 ptr_table_fetch(table, from)
684 XS::APItest::PtrTable table
685 SVREF from
686    CODE:
687    RETVAL = PTR2UV(ptr_table_fetch(table, from));
688    OUTPUT:
689    RETVAL
690
691 void
692 ptr_table_split(table)
693 XS::APItest::PtrTable table
694
695 void
696 ptr_table_clear(table)
697 XS::APItest::PtrTable table
698
699 MODULE = XS::APItest            PACKAGE = XS::APItest
700
701 PROTOTYPES: DISABLE
702
703 BOOT:
704 {
705     MY_CXT_INIT;
706
707     MY_CXT.i  = 99;
708     MY_CXT.sv = newSVpv("initial",0);
709
710     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
711     MY_CXT.bhk_record = 0;
712
713     BhkENTRY_set(&bhk_test, start, blockhook_test_start);
714     BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
715     BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
716     BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
717     Perl_blockhook_register(aTHX_ &bhk_test);
718
719     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
720         GV_ADDMULTI, SVt_PVAV);
721     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
722
723     BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
724     BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
725     Perl_blockhook_register(aTHX_ &bhk_csc);
726 }
727
728 void
729 CLONE(...)
730     CODE:
731     MY_CXT_CLONE;
732     MY_CXT.sv = newSVpv("initial_clone",0);
733     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
734         GV_ADDMULTI, SVt_PVAV);
735     MY_CXT.cscav = NULL;
736     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
737     MY_CXT.bhk_record = 0;
738
739 void
740 print_double(val)
741         double val
742         CODE:
743         printf("%5.3f\n",val);
744
745 int
746 have_long_double()
747         CODE:
748 #ifdef HAS_LONG_DOUBLE
749         RETVAL = 1;
750 #else
751         RETVAL = 0;
752 #endif
753         OUTPUT:
754         RETVAL
755
756 void
757 print_long_double()
758         CODE:
759 #ifdef HAS_LONG_DOUBLE
760 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
761         long double val = 7.0;
762         printf("%5.3" PERL_PRIfldbl "\n",val);
763 #   else
764         double val = 7.0;
765         printf("%5.3f\n",val);
766 #   endif
767 #endif
768
769 void
770 print_int(val)
771         int val
772         CODE:
773         printf("%d\n",val);
774
775 void
776 print_long(val)
777         long val
778         CODE:
779         printf("%ld\n",val);
780
781 void
782 print_float(val)
783         float val
784         CODE:
785         printf("%5.3f\n",val);
786         
787 void
788 print_flush()
789         CODE:
790         fflush(stdout);
791
792 void
793 mpushp()
794         PPCODE:
795         EXTEND(SP, 3);
796         mPUSHp("one", 3);
797         mPUSHp("two", 3);
798         mPUSHp("three", 5);
799         XSRETURN(3);
800
801 void
802 mpushn()
803         PPCODE:
804         EXTEND(SP, 3);
805         mPUSHn(0.5);
806         mPUSHn(-0.25);
807         mPUSHn(0.125);
808         XSRETURN(3);
809
810 void
811 mpushi()
812         PPCODE:
813         EXTEND(SP, 3);
814         mPUSHi(-1);
815         mPUSHi(2);
816         mPUSHi(-3);
817         XSRETURN(3);
818
819 void
820 mpushu()
821         PPCODE:
822         EXTEND(SP, 3);
823         mPUSHu(1);
824         mPUSHu(2);
825         mPUSHu(3);
826         XSRETURN(3);
827
828 void
829 mxpushp()
830         PPCODE:
831         mXPUSHp("one", 3);
832         mXPUSHp("two", 3);
833         mXPUSHp("three", 5);
834         XSRETURN(3);
835
836 void
837 mxpushn()
838         PPCODE:
839         mXPUSHn(0.5);
840         mXPUSHn(-0.25);
841         mXPUSHn(0.125);
842         XSRETURN(3);
843
844 void
845 mxpushi()
846         PPCODE:
847         mXPUSHi(-1);
848         mXPUSHi(2);
849         mXPUSHi(-3);
850         XSRETURN(3);
851
852 void
853 mxpushu()
854         PPCODE:
855         mXPUSHu(1);
856         mXPUSHu(2);
857         mXPUSHu(3);
858         XSRETURN(3);
859
860
861 void
862 call_sv(sv, flags, ...)
863     SV* sv
864     I32 flags
865     PREINIT:
866         I32 i;
867     PPCODE:
868         for (i=0; i<items-2; i++)
869             ST(i) = ST(i+2); /* pop first two args */
870         PUSHMARK(SP);
871         SP += items - 2;
872         PUTBACK;
873         i = call_sv(sv, flags);
874         SPAGAIN;
875         EXTEND(SP, 1);
876         PUSHs(sv_2mortal(newSViv(i)));
877
878 void
879 call_pv(subname, flags, ...)
880     char* subname
881     I32 flags
882     PREINIT:
883         I32 i;
884     PPCODE:
885         for (i=0; i<items-2; i++)
886             ST(i) = ST(i+2); /* pop first two args */
887         PUSHMARK(SP);
888         SP += items - 2;
889         PUTBACK;
890         i = call_pv(subname, flags);
891         SPAGAIN;
892         EXTEND(SP, 1);
893         PUSHs(sv_2mortal(newSViv(i)));
894
895 void
896 call_method(methname, flags, ...)
897     char* methname
898     I32 flags
899     PREINIT:
900         I32 i;
901     PPCODE:
902         for (i=0; i<items-2; i++)
903             ST(i) = ST(i+2); /* pop first two args */
904         PUSHMARK(SP);
905         SP += items - 2;
906         PUTBACK;
907         i = call_method(methname, flags);
908         SPAGAIN;
909         EXTEND(SP, 1);
910         PUSHs(sv_2mortal(newSViv(i)));
911
912 void
913 eval_sv(sv, flags)
914     SV* sv
915     I32 flags
916     PREINIT:
917         I32 i;
918     PPCODE:
919         PUTBACK;
920         i = eval_sv(sv, flags);
921         SPAGAIN;
922         EXTEND(SP, 1);
923         PUSHs(sv_2mortal(newSViv(i)));
924
925 void
926 eval_pv(p, croak_on_error)
927     const char* p
928     I32 croak_on_error
929     PPCODE:
930         PUTBACK;
931         EXTEND(SP, 1);
932         PUSHs(eval_pv(p, croak_on_error));
933
934 void
935 require_pv(pv)
936     const char* pv
937     PPCODE:
938         PUTBACK;
939         require_pv(pv);
940
941 int
942 apitest_exception(throw_e)
943     int throw_e
944     OUTPUT:
945         RETVAL
946
947 void
948 mycroak(sv)
949     SV* sv
950     CODE:
951     if (SvOK(sv)) {
952         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
953     }
954     else {
955         Perl_croak(aTHX_ NULL);
956     }
957
958 SV*
959 strtab()
960    CODE:
961    RETVAL = newRV_inc((SV*)PL_strtab);
962    OUTPUT:
963    RETVAL
964
965 int
966 my_cxt_getint()
967     CODE:
968         dMY_CXT;
969         RETVAL = my_cxt_getint_p(aMY_CXT);
970     OUTPUT:
971         RETVAL
972
973 void
974 my_cxt_setint(i)
975     int i;
976     CODE:
977         dMY_CXT;
978         my_cxt_setint_p(aMY_CXT_ i);
979
980 void
981 my_cxt_getsv(how)
982     bool how;
983     PPCODE:
984         EXTEND(SP, 1);
985         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
986         XSRETURN(1);
987
988 void
989 my_cxt_setsv(sv)
990     SV *sv;
991     CODE:
992         dMY_CXT;
993         SvREFCNT_dec(MY_CXT.sv);
994         my_cxt_setsv_p(sv _aMY_CXT);
995         SvREFCNT_inc(sv);
996
997 bool
998 sv_setsv_cow_hashkey_core()
999
1000 bool
1001 sv_setsv_cow_hashkey_notcore()
1002
1003 void
1004 rmagical_cast(sv, type)
1005     SV *sv;
1006     SV *type;
1007     PREINIT:
1008         struct ufuncs uf;
1009     PPCODE:
1010         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1011         sv = SvRV(sv);
1012         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1013         uf.uf_val = rmagical_a_dummy;
1014         uf.uf_set = NULL;
1015         uf.uf_index = 0;
1016         if (SvTRUE(type)) { /* b */
1017             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1018         } else { /* a */
1019             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1020         }
1021         XSRETURN_YES;
1022
1023 void
1024 rmagical_flags(sv)
1025     SV *sv;
1026     PPCODE:
1027         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1028         sv = SvRV(sv);
1029         EXTEND(SP, 3); 
1030         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1031         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1032         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1033         XSRETURN(3);
1034
1035 void
1036 DPeek (sv)
1037     SV   *sv
1038
1039   PPCODE:
1040     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1041     XSRETURN (1);
1042
1043 void
1044 BEGIN()
1045     CODE:
1046         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1047
1048 void
1049 CHECK()
1050     CODE:
1051         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1052
1053 void
1054 UNITCHECK()
1055     CODE:
1056         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1057
1058 void
1059 INIT()
1060     CODE:
1061         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1062
1063 void
1064 END()
1065     CODE:
1066         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1067
1068 void
1069 utf16_to_utf8 (sv, ...)
1070     SV* sv
1071         ALIAS:
1072             utf16_to_utf8_reversed = 1
1073     PREINIT:
1074         STRLEN len;
1075         U8 *source;
1076         SV *dest;
1077         I32 got; /* Gah, badly thought out APIs */
1078     CODE:
1079         source = (U8 *)SvPVbyte(sv, len);
1080         /* Optionally only convert part of the buffer.  */      
1081         if (items > 1) {
1082             len = SvUV(ST(1));
1083         }
1084         /* Mortalise this right now, as we'll be testing croak()s  */
1085         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1086         if (ix) {
1087             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1088         } else {
1089             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1090         }
1091         SvCUR_set(dest, got);
1092         SvPVX(dest)[got] = '\0';
1093         SvPOK_on(dest);
1094         ST(0) = dest;
1095         XSRETURN(1);
1096
1097 void
1098 my_exit(int exitcode)
1099         PPCODE:
1100         my_exit(exitcode);
1101
1102 I32
1103 sv_count()
1104         CODE:
1105             RETVAL = PL_sv_count;
1106         OUTPUT:
1107             RETVAL
1108
1109 void
1110 bhk_record(bool on)
1111     CODE:
1112         dMY_CXT;
1113         MY_CXT.bhk_record = on;
1114         if (on)
1115             av_clear(MY_CXT.bhkav);
1116
1117 BOOT:
1118         {
1119         HV* stash;
1120         SV** meth = NULL;
1121         CV* cv;
1122         stash = gv_stashpv("XS::APItest::TempLv", 0);
1123         if (stash)
1124             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
1125         if (!meth)
1126             croak("lost method 'make_temp_mg_lv'");
1127         cv = GvCV(*meth);
1128         CvLVALUE_on(cv);
1129         }