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