This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
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     peep_t orig_peep;
21     AV *peep_record;
22 } my_cxt_t;
23
24 START_MY_CXT
25
26 /* indirect functions to test the [pa]MY_CXT macros */
27
28 int
29 my_cxt_getint_p(pMY_CXT)
30 {
31     return MY_CXT.i;
32 }
33
34 void
35 my_cxt_setint_p(pMY_CXT_ int i)
36 {
37     MY_CXT.i = i;
38 }
39
40 SV*
41 my_cxt_getsv_interp_context(void)
42 {
43     dTHX;
44     dMY_CXT_INTERP(my_perl);
45     return MY_CXT.sv;
46 }
47
48 SV*
49 my_cxt_getsv_interp(void)
50 {
51     dMY_CXT;
52     return MY_CXT.sv;
53 }
54
55 void
56 my_cxt_setsv_p(SV* sv _pMY_CXT)
57 {
58     MY_CXT.sv = sv;
59 }
60
61
62 /* from exception.c */
63 int apitest_exception(int);
64
65 /* from core_or_not.inc */
66 bool sv_setsv_cow_hashkey_core(void);
67 bool sv_setsv_cow_hashkey_notcore(void);
68
69 /* A routine to test hv_delayfree_ent
70    (which itself is tested by testing on hv_free_ent  */
71
72 typedef void (freeent_function)(pTHX_ HV *, register HE *);
73
74 void
75 test_freeent(freeent_function *f) {
76     dTHX;
77     dSP;
78     HV *test_hash = newHV();
79     HE *victim;
80     SV *test_scalar;
81     U32 results[4];
82     int i;
83
84 #ifdef PURIFY
85     victim = (HE*)safemalloc(sizeof(HE));
86 #else
87     /* Storing then deleting something should ensure that a hash entry is
88        available.  */
89     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
90     hv_delete(test_hash, "", 0, 0);
91
92     /* We need to "inline" new_he here as it's static, and the functions we
93        test expect to be able to call del_HE on the HE  */
94     if (!PL_body_roots[HE_SVSLOT])
95         croak("PL_he_root is 0");
96     victim = (HE*) PL_body_roots[HE_SVSLOT];
97     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
98 #endif
99
100     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
101
102     test_scalar = newSV(0);
103     SvREFCNT_inc(test_scalar);
104     HeVAL(victim) = test_scalar;
105
106     /* Need this little game else we free the temps on the return stack.  */
107     results[0] = SvREFCNT(test_scalar);
108     SAVETMPS;
109     results[1] = SvREFCNT(test_scalar);
110     f(aTHX_ test_hash, victim);
111     results[2] = SvREFCNT(test_scalar);
112     FREETMPS;
113     results[3] = SvREFCNT(test_scalar);
114
115     i = 0;
116     do {
117         mPUSHu(results[i]);
118     } while (++i < sizeof(results)/sizeof(results[0]));
119
120     /* Goodbye to our extra reference.  */
121     SvREFCNT_dec(test_scalar);
122 }
123
124
125 static I32
126 bitflip_key(pTHX_ IV action, SV *field) {
127     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
128     SV *keysv;
129     if (mg && (keysv = mg->mg_obj)) {
130         STRLEN len;
131         const char *p = SvPV(keysv, len);
132
133         if (len) {
134             SV *newkey = newSV(len);
135             char *new_p = SvPVX(newkey);
136
137             if (SvUTF8(keysv)) {
138                 const char *const end = p + len;
139                 while (p < end) {
140                     STRLEN len;
141                     UV chr = utf8_to_uvuni((U8 *)p, &len);
142                     new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
143                     p += len;
144                 }
145                 SvUTF8_on(newkey);
146             } else {
147                 while (len--)
148                     *new_p++ = *p++ ^ 32;
149             }
150             *new_p = '\0';
151             SvCUR_set(newkey, SvCUR(keysv));
152             SvPOK_on(newkey);
153
154             mg->mg_obj = newkey;
155         }
156     }
157     return 0;
158 }
159
160 static I32
161 rot13_key(pTHX_ IV action, SV *field) {
162     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
163     SV *keysv;
164     if (mg && (keysv = mg->mg_obj)) {
165         STRLEN len;
166         const char *p = SvPV(keysv, len);
167
168         if (len) {
169             SV *newkey = newSV(len);
170             char *new_p = SvPVX(newkey);
171
172             /* There's a deliberate fencepost error here to loop len + 1 times
173                to copy the trailing \0  */
174             do {
175                 char new_c = *p++;
176                 /* Try doing this cleanly and clearly in EBCDIC another way: */
177                 switch (new_c) {
178                 case 'A': new_c = 'N'; break;
179                 case 'B': new_c = 'O'; break;
180                 case 'C': new_c = 'P'; break;
181                 case 'D': new_c = 'Q'; break;
182                 case 'E': new_c = 'R'; break;
183                 case 'F': new_c = 'S'; break;
184                 case 'G': new_c = 'T'; break;
185                 case 'H': new_c = 'U'; break;
186                 case 'I': new_c = 'V'; break;
187                 case 'J': new_c = 'W'; break;
188                 case 'K': new_c = 'X'; break;
189                 case 'L': new_c = 'Y'; break;
190                 case 'M': new_c = 'Z'; break;
191                 case 'N': new_c = 'A'; break;
192                 case 'O': new_c = 'B'; break;
193                 case 'P': new_c = 'C'; break;
194                 case 'Q': new_c = 'D'; break;
195                 case 'R': new_c = 'E'; break;
196                 case 'S': new_c = 'F'; break;
197                 case 'T': new_c = 'G'; break;
198                 case 'U': new_c = 'H'; break;
199                 case 'V': new_c = 'I'; break;
200                 case 'W': new_c = 'J'; break;
201                 case 'X': new_c = 'K'; break;
202                 case 'Y': new_c = 'L'; break;
203                 case 'Z': new_c = 'M'; break;
204                 case 'a': new_c = 'n'; break;
205                 case 'b': new_c = 'o'; break;
206                 case 'c': new_c = 'p'; break;
207                 case 'd': new_c = 'q'; break;
208                 case 'e': new_c = 'r'; break;
209                 case 'f': new_c = 's'; break;
210                 case 'g': new_c = 't'; break;
211                 case 'h': new_c = 'u'; break;
212                 case 'i': new_c = 'v'; break;
213                 case 'j': new_c = 'w'; break;
214                 case 'k': new_c = 'x'; break;
215                 case 'l': new_c = 'y'; break;
216                 case 'm': new_c = 'z'; break;
217                 case 'n': new_c = 'a'; break;
218                 case 'o': new_c = 'b'; break;
219                 case 'p': new_c = 'c'; break;
220                 case 'q': new_c = 'd'; break;
221                 case 'r': new_c = 'e'; break;
222                 case 's': new_c = 'f'; break;
223                 case 't': new_c = 'g'; break;
224                 case 'u': new_c = 'h'; break;
225                 case 'v': new_c = 'i'; break;
226                 case 'w': new_c = 'j'; break;
227                 case 'x': new_c = 'k'; break;
228                 case 'y': new_c = 'l'; break;
229                 case 'z': new_c = 'm'; break;
230                 }
231                 *new_p++ = new_c;
232             } while (len--);
233             SvCUR_set(newkey, SvCUR(keysv));
234             SvPOK_on(newkey);
235             if (SvUTF8(keysv))
236                 SvUTF8_on(newkey);
237
238             mg->mg_obj = newkey;
239         }
240     }
241     return 0;
242 }
243
244 STATIC I32
245 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
246     return 0;
247 }
248
249 STATIC MGVTBL rmagical_b = { 0 };
250
251 STATIC void
252 blockhook_csc_start(pTHX_ int full)
253 {
254     dMY_CXT;
255     AV *const cur = GvAV(MY_CXT.cscgv);
256
257     SAVEGENERICSV(GvAV(MY_CXT.cscgv));
258
259     if (cur) {
260         I32 i;
261         AV *const new_av = newAV();
262
263         for (i = 0; i <= av_len(cur); i++) {
264             av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
265         }
266
267         GvAV(MY_CXT.cscgv) = new_av;
268     }
269 }
270
271 STATIC void
272 blockhook_csc_pre_end(pTHX_ OP **o)
273 {
274     dMY_CXT;
275
276     /* if we hit the end of a scope we missed the start of, we need to
277      * unconditionally clear @CSC */
278     if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
279         av_clear(MY_CXT.cscav);
280     }
281
282 }
283
284 STATIC void
285 blockhook_test_start(pTHX_ int full)
286 {
287     dMY_CXT;
288     AV *av;
289     
290     if (MY_CXT.bhk_record) {
291         av = newAV();
292         av_push(av, newSVpvs("start"));
293         av_push(av, newSViv(full));
294         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
295     }
296 }
297
298 STATIC void
299 blockhook_test_pre_end(pTHX_ OP **o)
300 {
301     dMY_CXT;
302
303     if (MY_CXT.bhk_record)
304         av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
305 }
306
307 STATIC void
308 blockhook_test_post_end(pTHX_ OP **o)
309 {
310     dMY_CXT;
311
312     if (MY_CXT.bhk_record)
313         av_push(MY_CXT.bhkav, newSVpvs("post_end"));
314 }
315
316 STATIC void
317 blockhook_test_eval(pTHX_ OP *const o)
318 {
319     dMY_CXT;
320     AV *av;
321
322     if (MY_CXT.bhk_record) {
323         av = newAV();
324         av_push(av, newSVpvs("eval"));
325         av_push(av, newSVpv(OP_NAME(o), 0));
326         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
327     }
328 }
329
330 STATIC BHK bhk_csc, bhk_test;
331
332 STATIC void
333 my_peep (pTHX_ OP *o, peep_next_t *next_peep)
334 {
335     dMY_CXT;
336
337     if (!o)
338         return;
339
340     CALL_FPTR(MY_CXT.orig_peep)(aTHX_ o, next_peep);
341
342     for (; o; o = o->op_next) {
343         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
344             av_push(MY_CXT.peep_record, newSVsv(cSVOPx_sv(o)));
345         }
346     }
347 }
348
349 #include "const-c.inc"
350
351 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
352
353 INCLUDE: const-xs.inc
354
355 void
356 rot13_hash(hash)
357         HV *hash
358         CODE:
359         {
360             struct ufuncs uf;
361             uf.uf_val = rot13_key;
362             uf.uf_set = 0;
363             uf.uf_index = 0;
364
365             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
366         }
367
368 void
369 bitflip_hash(hash)
370         HV *hash
371         CODE:
372         {
373             struct ufuncs uf;
374             uf.uf_val = bitflip_key;
375             uf.uf_set = 0;
376             uf.uf_index = 0;
377
378             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
379         }
380
381 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
382
383 bool
384 exists(hash, key_sv)
385         PREINIT:
386         STRLEN len;
387         const char *key;
388         INPUT:
389         HV *hash
390         SV *key_sv
391         CODE:
392         key = SvPV(key_sv, len);
393         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
394         OUTPUT:
395         RETVAL
396
397 bool
398 exists_ent(hash, key_sv)
399         PREINIT:
400         INPUT:
401         HV *hash
402         SV *key_sv
403         CODE:
404         RETVAL = hv_exists_ent(hash, key_sv, 0);
405         OUTPUT:
406         RETVAL
407
408 SV *
409 delete(hash, key_sv, flags = 0)
410         PREINIT:
411         STRLEN len;
412         const char *key;
413         INPUT:
414         HV *hash
415         SV *key_sv
416         I32 flags;
417         CODE:
418         key = SvPV(key_sv, len);
419         /* It's already mortal, so need to increase reference count.  */
420         RETVAL
421             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
422         OUTPUT:
423         RETVAL
424
425 SV *
426 delete_ent(hash, key_sv, flags = 0)
427         INPUT:
428         HV *hash
429         SV *key_sv
430         I32 flags;
431         CODE:
432         /* It's already mortal, so need to increase reference count.  */
433         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
434         OUTPUT:
435         RETVAL
436
437 SV *
438 store_ent(hash, key, value)
439         PREINIT:
440         SV *copy;
441         HE *result;
442         INPUT:
443         HV *hash
444         SV *key
445         SV *value
446         CODE:
447         copy = newSV(0);
448         result = hv_store_ent(hash, key, copy, 0);
449         SvSetMagicSV(copy, value);
450         if (!result) {
451             SvREFCNT_dec(copy);
452             XSRETURN_EMPTY;
453         }
454         /* It's about to become mortal, so need to increase reference count.
455          */
456         RETVAL = SvREFCNT_inc(HeVAL(result));
457         OUTPUT:
458         RETVAL
459
460 SV *
461 store(hash, key_sv, value)
462         PREINIT:
463         STRLEN len;
464         const char *key;
465         SV *copy;
466         SV **result;
467         INPUT:
468         HV *hash
469         SV *key_sv
470         SV *value
471         CODE:
472         key = SvPV(key_sv, len);
473         copy = newSV(0);
474         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
475         SvSetMagicSV(copy, value);
476         if (!result) {
477             SvREFCNT_dec(copy);
478             XSRETURN_EMPTY;
479         }
480         /* It's about to become mortal, so need to increase reference count.
481          */
482         RETVAL = SvREFCNT_inc(*result);
483         OUTPUT:
484         RETVAL
485
486 SV *
487 fetch_ent(hash, key_sv)
488         PREINIT:
489         HE *result;
490         INPUT:
491         HV *hash
492         SV *key_sv
493         CODE:
494         result = hv_fetch_ent(hash, key_sv, 0, 0);
495         if (!result) {
496             XSRETURN_EMPTY;
497         }
498         /* Force mg_get  */
499         RETVAL = newSVsv(HeVAL(result));
500         OUTPUT:
501         RETVAL
502
503 SV *
504 fetch(hash, key_sv)
505         PREINIT:
506         STRLEN len;
507         const char *key;
508         SV **result;
509         INPUT:
510         HV *hash
511         SV *key_sv
512         CODE:
513         key = SvPV(key_sv, len);
514         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
515         if (!result) {
516             XSRETURN_EMPTY;
517         }
518         /* Force mg_get  */
519         RETVAL = newSVsv(*result);
520         OUTPUT:
521         RETVAL
522
523 #if defined (hv_common)
524
525 SV *
526 common(params)
527         INPUT:
528         HV *params
529         PREINIT:
530         HE *result;
531         HV *hv = NULL;
532         SV *keysv = NULL;
533         const char *key = NULL;
534         STRLEN klen = 0;
535         int flags = 0;
536         int action = 0;
537         SV *val = NULL;
538         U32 hash = 0;
539         SV **svp;
540         CODE:
541         if ((svp = hv_fetchs(params, "hv", 0))) {
542             SV *const rv = *svp;
543             if (!SvROK(rv))
544                 croak("common passed a non-reference for parameter hv");
545             hv = (HV *)SvRV(rv);
546         }
547         if ((svp = hv_fetchs(params, "keysv", 0)))
548             keysv = *svp;
549         if ((svp = hv_fetchs(params, "keypv", 0))) {
550             key = SvPV_const(*svp, klen);
551             if (SvUTF8(*svp))
552                 flags = HVhek_UTF8;
553         }
554         if ((svp = hv_fetchs(params, "action", 0)))
555             action = SvIV(*svp);
556         if ((svp = hv_fetchs(params, "val", 0)))
557             val = newSVsv(*svp);
558         if ((svp = hv_fetchs(params, "hash", 0)))
559             hash = SvUV(*svp);
560
561         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
562             PERL_HASH(hash, key, klen);
563         }
564         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
565             STRLEN len;
566             const char *const p = SvPV(keysv, len);
567             PERL_HASH(hash, p, len);
568         }
569
570         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
571         if (!result) {
572             XSRETURN_EMPTY;
573         }
574         /* Force mg_get  */
575         RETVAL = newSVsv(HeVAL(result));
576         OUTPUT:
577         RETVAL
578
579 #endif
580
581 void
582 test_hv_free_ent()
583         PPCODE:
584         test_freeent(&Perl_hv_free_ent);
585         XSRETURN(4);
586
587 void
588 test_hv_delayfree_ent()
589         PPCODE:
590         test_freeent(&Perl_hv_delayfree_ent);
591         XSRETURN(4);
592
593 SV *
594 test_share_unshare_pvn(input)
595         PREINIT:
596         STRLEN len;
597         U32 hash;
598         char *pvx;
599         char *p;
600         INPUT:
601         SV *input
602         CODE:
603         pvx = SvPV(input, len);
604         PERL_HASH(hash, pvx, len);
605         p = sharepvn(pvx, len, hash);
606         RETVAL = newSVpvn(p, len);
607         unsharepvn(p, len, hash);
608         OUTPUT:
609         RETVAL
610
611 #if PERL_VERSION >= 9
612
613 bool
614 refcounted_he_exists(key, level=0)
615         SV *key
616         IV level
617         CODE:
618         if (level) {
619             croak("level must be zero, not %"IVdf, level);
620         }
621         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
622                                            key, NULL, 0, 0, 0)
623                   != &PL_sv_placeholder);
624         OUTPUT:
625         RETVAL
626
627 SV *
628 refcounted_he_fetch(key, level=0)
629         SV *key
630         IV level
631         CODE:
632         if (level) {
633             croak("level must be zero, not %"IVdf, level);
634         }
635         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
636                                           NULL, 0, 0, 0);
637         SvREFCNT_inc(RETVAL);
638         OUTPUT:
639         RETVAL
640
641 #endif
642
643 =pod
644
645 sub TIEHASH  { bless {}, $_[0] }
646 sub STORE    { $_[0]->{$_[1]} = $_[2] }
647 sub FETCH    { $_[0]->{$_[1]} }
648 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
649 sub NEXTKEY  { each %{$_[0]} }
650 sub EXISTS   { exists $_[0]->{$_[1]} }
651 sub DELETE   { delete $_[0]->{$_[1]} }
652 sub CLEAR    { %{$_[0]} = () }
653
654 =cut
655
656 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
657
658 void
659 ptr_table_new(classname)
660 const char * classname
661     PPCODE:
662     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
663
664 void
665 DESTROY(table)
666 XS::APItest::PtrTable table
667     CODE:
668     ptr_table_free(table);
669
670 void
671 ptr_table_store(table, from, to)
672 XS::APItest::PtrTable table
673 SVREF from
674 SVREF to
675    CODE:
676    ptr_table_store(table, from, to);
677
678 UV
679 ptr_table_fetch(table, from)
680 XS::APItest::PtrTable table
681 SVREF from
682    CODE:
683    RETVAL = PTR2UV(ptr_table_fetch(table, from));
684    OUTPUT:
685    RETVAL
686
687 void
688 ptr_table_split(table)
689 XS::APItest::PtrTable table
690
691 void
692 ptr_table_clear(table)
693 XS::APItest::PtrTable table
694
695 MODULE = XS::APItest            PACKAGE = XS::APItest
696
697 PROTOTYPES: DISABLE
698
699 BOOT:
700 {
701     MY_CXT_INIT;
702
703     MY_CXT.i  = 99;
704     MY_CXT.sv = newSVpv("initial",0);
705
706     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
707     MY_CXT.bhk_record = 0;
708
709     BhkENTRY_set(&bhk_test, start, blockhook_test_start);
710     BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
711     BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
712     BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
713     Perl_blockhook_register(aTHX_ &bhk_test);
714
715     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
716         GV_ADDMULTI, SVt_PVAV);
717     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
718
719     BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
720     BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
721     Perl_blockhook_register(aTHX_ &bhk_csc);
722
723     MY_CXT.peep_record = newAV();
724 }
725
726 void
727 CLONE(...)
728     CODE:
729     MY_CXT_CLONE;
730     MY_CXT.sv = newSVpv("initial_clone",0);
731     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
732         GV_ADDMULTI, SVt_PVAV);
733     MY_CXT.cscav = NULL;
734     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
735     MY_CXT.bhk_record = 0;
736     MY_CXT.peep_record = newAV();
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 DPeek (sv)
1036     SV   *sv
1037
1038   PPCODE:
1039     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1040     XSRETURN (1);
1041
1042 void
1043 BEGIN()
1044     CODE:
1045         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1046
1047 void
1048 CHECK()
1049     CODE:
1050         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1051
1052 void
1053 UNITCHECK()
1054     CODE:
1055         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1056
1057 void
1058 INIT()
1059     CODE:
1060         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1061
1062 void
1063 END()
1064     CODE:
1065         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1066
1067 void
1068 utf16_to_utf8 (sv, ...)
1069     SV* sv
1070         ALIAS:
1071             utf16_to_utf8_reversed = 1
1072     PREINIT:
1073         STRLEN len;
1074         U8 *source;
1075         SV *dest;
1076         I32 got; /* Gah, badly thought out APIs */
1077     CODE:
1078         source = (U8 *)SvPVbyte(sv, len);
1079         /* Optionally only convert part of the buffer.  */      
1080         if (items > 1) {
1081             len = SvUV(ST(1));
1082         }
1083         /* Mortalise this right now, as we'll be testing croak()s  */
1084         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1085         if (ix) {
1086             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1087         } else {
1088             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1089         }
1090         SvCUR_set(dest, got);
1091         SvPVX(dest)[got] = '\0';
1092         SvPOK_on(dest);
1093         ST(0) = dest;
1094         XSRETURN(1);
1095
1096 void
1097 my_exit(int exitcode)
1098         PPCODE:
1099         my_exit(exitcode);
1100
1101 I32
1102 sv_count()
1103         CODE:
1104             RETVAL = PL_sv_count;
1105         OUTPUT:
1106             RETVAL
1107
1108 void
1109 bhk_record(bool on)
1110     CODE:
1111         dMY_CXT;
1112         MY_CXT.bhk_record = on;
1113         if (on)
1114             av_clear(MY_CXT.bhkav);
1115
1116 void
1117 peep_enable ()
1118     PREINIT:
1119         dMY_CXT;
1120     CODE:
1121         av_clear(MY_CXT.peep_record);
1122         MY_CXT.orig_peep = PL_peepp;
1123         PL_peepp = my_peep;
1124
1125 AV *
1126 peep_record ()
1127     PREINIT:
1128         dMY_CXT;
1129     CODE:
1130         RETVAL = MY_CXT.peep_record;
1131     OUTPUT:
1132         RETVAL
1133
1134 void
1135 peep_record_clear ()
1136     PREINIT:
1137         dMY_CXT;
1138     CODE:
1139         av_clear(MY_CXT.peep_record);