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