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