This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Initial very basic tests for PL_blockhooks.
[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 STATIC struct block_hooks my_block_hooks = {
280     blockhook_start,
281     blockhook_pre_end,
282     NULL
283 };
284
285 #include "const-c.inc"
286
287 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
288
289 INCLUDE: const-xs.inc
290
291 void
292 rot13_hash(hash)
293         HV *hash
294         CODE:
295         {
296             struct ufuncs uf;
297             uf.uf_val = rot13_key;
298             uf.uf_set = 0;
299             uf.uf_index = 0;
300
301             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
302         }
303
304 void
305 bitflip_hash(hash)
306         HV *hash
307         CODE:
308         {
309             struct ufuncs uf;
310             uf.uf_val = bitflip_key;
311             uf.uf_set = 0;
312             uf.uf_index = 0;
313
314             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
315         }
316
317 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
318
319 bool
320 exists(hash, key_sv)
321         PREINIT:
322         STRLEN len;
323         const char *key;
324         INPUT:
325         HV *hash
326         SV *key_sv
327         CODE:
328         key = SvPV(key_sv, len);
329         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
330         OUTPUT:
331         RETVAL
332
333 bool
334 exists_ent(hash, key_sv)
335         PREINIT:
336         INPUT:
337         HV *hash
338         SV *key_sv
339         CODE:
340         RETVAL = hv_exists_ent(hash, key_sv, 0);
341         OUTPUT:
342         RETVAL
343
344 SV *
345 delete(hash, key_sv, flags = 0)
346         PREINIT:
347         STRLEN len;
348         const char *key;
349         INPUT:
350         HV *hash
351         SV *key_sv
352         I32 flags;
353         CODE:
354         key = SvPV(key_sv, len);
355         /* It's already mortal, so need to increase reference count.  */
356         RETVAL
357             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
358         OUTPUT:
359         RETVAL
360
361 SV *
362 delete_ent(hash, key_sv, flags = 0)
363         INPUT:
364         HV *hash
365         SV *key_sv
366         I32 flags;
367         CODE:
368         /* It's already mortal, so need to increase reference count.  */
369         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
370         OUTPUT:
371         RETVAL
372
373 SV *
374 store_ent(hash, key, value)
375         PREINIT:
376         SV *copy;
377         HE *result;
378         INPUT:
379         HV *hash
380         SV *key
381         SV *value
382         CODE:
383         copy = newSV(0);
384         result = hv_store_ent(hash, key, copy, 0);
385         SvSetMagicSV(copy, value);
386         if (!result) {
387             SvREFCNT_dec(copy);
388             XSRETURN_EMPTY;
389         }
390         /* It's about to become mortal, so need to increase reference count.
391          */
392         RETVAL = SvREFCNT_inc(HeVAL(result));
393         OUTPUT:
394         RETVAL
395
396 SV *
397 store(hash, key_sv, value)
398         PREINIT:
399         STRLEN len;
400         const char *key;
401         SV *copy;
402         SV **result;
403         INPUT:
404         HV *hash
405         SV *key_sv
406         SV *value
407         CODE:
408         key = SvPV(key_sv, len);
409         copy = newSV(0);
410         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
411         SvSetMagicSV(copy, value);
412         if (!result) {
413             SvREFCNT_dec(copy);
414             XSRETURN_EMPTY;
415         }
416         /* It's about to become mortal, so need to increase reference count.
417          */
418         RETVAL = SvREFCNT_inc(*result);
419         OUTPUT:
420         RETVAL
421
422 SV *
423 fetch_ent(hash, key_sv)
424         PREINIT:
425         HE *result;
426         INPUT:
427         HV *hash
428         SV *key_sv
429         CODE:
430         result = hv_fetch_ent(hash, key_sv, 0, 0);
431         if (!result) {
432             XSRETURN_EMPTY;
433         }
434         /* Force mg_get  */
435         RETVAL = newSVsv(HeVAL(result));
436         OUTPUT:
437         RETVAL
438
439 SV *
440 fetch(hash, key_sv)
441         PREINIT:
442         STRLEN len;
443         const char *key;
444         SV **result;
445         INPUT:
446         HV *hash
447         SV *key_sv
448         CODE:
449         key = SvPV(key_sv, len);
450         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
451         if (!result) {
452             XSRETURN_EMPTY;
453         }
454         /* Force mg_get  */
455         RETVAL = newSVsv(*result);
456         OUTPUT:
457         RETVAL
458
459 #if defined (hv_common)
460
461 SV *
462 common(params)
463         INPUT:
464         HV *params
465         PREINIT:
466         HE *result;
467         HV *hv = NULL;
468         SV *keysv = NULL;
469         const char *key = NULL;
470         STRLEN klen = 0;
471         int flags = 0;
472         int action = 0;
473         SV *val = NULL;
474         U32 hash = 0;
475         SV **svp;
476         CODE:
477         if ((svp = hv_fetchs(params, "hv", 0))) {
478             SV *const rv = *svp;
479             if (!SvROK(rv))
480                 croak("common passed a non-reference for parameter hv");
481             hv = (HV *)SvRV(rv);
482         }
483         if ((svp = hv_fetchs(params, "keysv", 0)))
484             keysv = *svp;
485         if ((svp = hv_fetchs(params, "keypv", 0))) {
486             key = SvPV_const(*svp, klen);
487             if (SvUTF8(*svp))
488                 flags = HVhek_UTF8;
489         }
490         if ((svp = hv_fetchs(params, "action", 0)))
491             action = SvIV(*svp);
492         if ((svp = hv_fetchs(params, "val", 0)))
493             val = newSVsv(*svp);
494         if ((svp = hv_fetchs(params, "hash", 0)))
495             hash = SvUV(*svp);
496
497         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
498             PERL_HASH(hash, key, klen);
499         }
500         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
501             STRLEN len;
502             const char *const p = SvPV(keysv, len);
503             PERL_HASH(hash, p, len);
504         }
505
506         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
507         if (!result) {
508             XSRETURN_EMPTY;
509         }
510         /* Force mg_get  */
511         RETVAL = newSVsv(HeVAL(result));
512         OUTPUT:
513         RETVAL
514
515 #endif
516
517 void
518 test_hv_free_ent()
519         PPCODE:
520         test_freeent(&Perl_hv_free_ent);
521         XSRETURN(4);
522
523 void
524 test_hv_delayfree_ent()
525         PPCODE:
526         test_freeent(&Perl_hv_delayfree_ent);
527         XSRETURN(4);
528
529 SV *
530 test_share_unshare_pvn(input)
531         PREINIT:
532         STRLEN len;
533         U32 hash;
534         char *pvx;
535         char *p;
536         INPUT:
537         SV *input
538         CODE:
539         pvx = SvPV(input, len);
540         PERL_HASH(hash, pvx, len);
541         p = sharepvn(pvx, len, hash);
542         RETVAL = newSVpvn(p, len);
543         unsharepvn(p, len, hash);
544         OUTPUT:
545         RETVAL
546
547 #if PERL_VERSION >= 9
548
549 bool
550 refcounted_he_exists(key, level=0)
551         SV *key
552         IV level
553         CODE:
554         if (level) {
555             croak("level must be zero, not %"IVdf, level);
556         }
557         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
558                                            key, NULL, 0, 0, 0)
559                   != &PL_sv_placeholder);
560         OUTPUT:
561         RETVAL
562
563 SV *
564 refcounted_he_fetch(key, level=0)
565         SV *key
566         IV level
567         CODE:
568         if (level) {
569             croak("level must be zero, not %"IVdf, level);
570         }
571         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
572                                           NULL, 0, 0, 0);
573         SvREFCNT_inc(RETVAL);
574         OUTPUT:
575         RETVAL
576         
577 #endif
578         
579 =pod
580
581 sub TIEHASH  { bless {}, $_[0] }
582 sub STORE    { $_[0]->{$_[1]} = $_[2] }
583 sub FETCH    { $_[0]->{$_[1]} }
584 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
585 sub NEXTKEY  { each %{$_[0]} }
586 sub EXISTS   { exists $_[0]->{$_[1]} }
587 sub DELETE   { delete $_[0]->{$_[1]} }
588 sub CLEAR    { %{$_[0]} = () }
589
590 =cut
591
592 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
593
594 void
595 ptr_table_new(classname)
596 const char * classname
597     PPCODE:
598     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
599
600 void
601 DESTROY(table)
602 XS::APItest::PtrTable table
603     CODE:
604     ptr_table_free(table);
605
606 void
607 ptr_table_store(table, from, to)
608 XS::APItest::PtrTable table
609 SVREF from
610 SVREF to
611    CODE:
612    ptr_table_store(table, from, to);
613
614 UV
615 ptr_table_fetch(table, from)
616 XS::APItest::PtrTable table
617 SVREF from
618    CODE:
619    RETVAL = PTR2UV(ptr_table_fetch(table, from));
620    OUTPUT:
621    RETVAL
622
623 void
624 ptr_table_split(table)
625 XS::APItest::PtrTable table
626
627 void
628 ptr_table_clear(table)
629 XS::APItest::PtrTable table
630
631 MODULE = XS::APItest            PACKAGE = XS::APItest
632
633 PROTOTYPES: DISABLE
634
635 BOOT:
636 {
637     MY_CXT_INIT;
638
639     MY_CXT.i  = 99;
640     MY_CXT.sv = newSVpv("initial",0);
641     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER", 
642         GV_ADD, SVt_PVAV);
643     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
644
645     if (!PL_blockhooks)
646         PL_blockhooks = newAV();
647     av_push(PL_blockhooks, newSViv(PTR2IV(&my_block_hooks))); 
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