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