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