This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
XS::APItest tests for XS_APIVERSION_BOOTCHECK.
[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 /** RPN keyword parser **/
376
377 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
378 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
379 #define sv_is_string(sv) \
380     (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
381      (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
382
383 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
384 static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
385 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
386
387 /* low-level parser helpers */
388
389 #define PL_bufptr (PL_parser->bufptr)
390 #define PL_bufend (PL_parser->bufend)
391
392 /* RPN parser */
393
394 #define parse_var() THX_parse_var(aTHX)
395 static OP *THX_parse_var(pTHX)
396 {
397     char *s = PL_bufptr;
398     char *start = s;
399     PADOFFSET varpos;
400     OP *padop;
401     if(*s != '$') croak("RPN syntax error");
402     while(1) {
403         char c = *++s;
404         if(!isALNUM(c)) break;
405     }
406     if(s-start < 2) croak("RPN syntax error");
407     lex_read_to(s);
408     {
409         /* because pad_findmy() doesn't really use length yet */
410         SV *namesv = sv_2mortal(newSVpvn(start, s-start));
411         varpos = pad_findmy(SvPVX(namesv), s-start, 0);
412     }
413     if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
414         croak("RPN only supports \"my\" variables");
415     padop = newOP(OP_PADSV, 0);
416     padop->op_targ = varpos;
417     return padop;
418 }
419
420 #define push_rpn_item(o) \
421     (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
422 #define pop_rpn_item() \
423     (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
424      (tmpop = stack, stack = stack->op_sibling, \
425       tmpop->op_sibling = NULL, tmpop))
426
427 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
428 static OP *THX_parse_rpn_expr(pTHX)
429 {
430     OP *stack = NULL, *tmpop;
431     while(1) {
432         I32 c;
433         lex_read_space(0);
434         c = lex_peek_unichar(0);
435         switch(c) {
436             case /*(*/')': case /*{*/'}': {
437                 OP *result = pop_rpn_item();
438                 if(stack) croak("RPN expression must return a single value");
439                 return result;
440             } break;
441             case '0': case '1': case '2': case '3': case '4':
442             case '5': case '6': case '7': case '8': case '9': {
443                 UV val = 0;
444                 do {
445                     lex_read_unichar(0);
446                     val = 10*val + (c - '0');
447                     c = lex_peek_unichar(0);
448                 } while(c >= '0' && c <= '9');
449                 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
450             } break;
451             case '$': {
452                 push_rpn_item(parse_var());
453             } break;
454             case '+': {
455                 OP *b = pop_rpn_item();
456                 OP *a = pop_rpn_item();
457                 lex_read_unichar(0);
458                 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
459             } break;
460             case '-': {
461                 OP *b = pop_rpn_item();
462                 OP *a = pop_rpn_item();
463                 lex_read_unichar(0);
464                 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
465             } break;
466             case '*': {
467                 OP *b = pop_rpn_item();
468                 OP *a = pop_rpn_item();
469                 lex_read_unichar(0);
470                 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
471             } break;
472             case '/': {
473                 OP *b = pop_rpn_item();
474                 OP *a = pop_rpn_item();
475                 lex_read_unichar(0);
476                 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
477             } break;
478             case '%': {
479                 OP *b = pop_rpn_item();
480                 OP *a = pop_rpn_item();
481                 lex_read_unichar(0);
482                 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
483             } break;
484             default: {
485                 croak("RPN syntax error");
486             } break;
487         }
488     }
489 }
490
491 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
492 static OP *THX_parse_keyword_rpn(pTHX)
493 {
494     OP *op;
495     lex_read_space(0);
496     if(lex_peek_unichar(0) != '('/*)*/)
497         croak("RPN expression must be parenthesised");
498     lex_read_unichar(0);
499     op = parse_rpn_expr();
500     if(lex_peek_unichar(0) != /*(*/')')
501         croak("RPN expression must be parenthesised");
502     lex_read_unichar(0);
503     return op;
504 }
505
506 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
507 static OP *THX_parse_keyword_calcrpn(pTHX)
508 {
509     OP *varop, *exprop;
510     lex_read_space(0);
511     varop = parse_var();
512     lex_read_space(0);
513     if(lex_peek_unichar(0) != '{'/*}*/)
514         croak("RPN expression must be braced");
515     lex_read_unichar(0);
516     exprop = parse_rpn_expr();
517     if(lex_peek_unichar(0) != /*{*/'}')
518         croak("RPN expression must be braced");
519     lex_read_unichar(0);
520     return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
521 }
522
523 #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
524 static OP *THX_parse_keyword_stufftest(pTHX)
525 {
526     I32 c;
527     bool do_stuff;
528     lex_read_space(0);
529     do_stuff = lex_peek_unichar(0) == '+';
530     if(do_stuff) {
531         lex_read_unichar(0);
532         lex_read_space(0);
533     }
534     c = lex_peek_unichar(0);
535     if(c == ';') {
536         lex_read_unichar(0);
537     } else if(c != /*{*/'}') {
538         croak("syntax error");
539     }
540     if(do_stuff) lex_stuff_pvs(" ", 0);
541     return newOP(OP_NULL, 0);
542 }
543
544 #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
545 static OP *THX_parse_keyword_swaptwostmts(pTHX)
546 {
547     OP *a, *b;
548     a = parse_fullstmt(0);
549     b = parse_fullstmt(0);
550     if(a && b)
551         PL_hints |= HINT_BLOCK_SCOPE;
552     /* should use append_list(), but that's not part of the public API */
553     return !a ? b : !b ? a : newLISTOP(OP_LINESEQ, 0, b, a);
554 }
555
556 #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
557 static OP *THX_parse_keyword_looprest(pTHX)
558 {
559     I32 condline;
560     OP *body;
561     condline = CopLINE(PL_curcop);
562     body = parse_stmtseq(0);
563     return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
564                         body, NULL, 1);
565 }
566
567 /* plugin glue */
568
569 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
570 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
571 {
572     HE *he;
573     if(!GvHV(PL_hintgv)) return 0;
574     he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
575                 SvSHARED_HASH(hintkey_sv));
576     return he && SvTRUE(HeVAL(he));
577 }
578
579 static int my_keyword_plugin(pTHX_
580     char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
581 {
582     if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
583                     keyword_active(hintkey_rpn_sv)) {
584         *op_ptr = parse_keyword_rpn();
585         return KEYWORD_PLUGIN_EXPR;
586     } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
587                     keyword_active(hintkey_calcrpn_sv)) {
588         *op_ptr = parse_keyword_calcrpn();
589         return KEYWORD_PLUGIN_STMT;
590     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
591                     keyword_active(hintkey_stufftest_sv)) {
592         *op_ptr = parse_keyword_stufftest();
593         return KEYWORD_PLUGIN_STMT;
594     } else if(keyword_len == 12 &&
595                     strnEQ(keyword_ptr, "swaptwostmts", 12) &&
596                     keyword_active(hintkey_swaptwostmts_sv)) {
597         *op_ptr = parse_keyword_swaptwostmts();
598         return KEYWORD_PLUGIN_STMT;
599     } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
600                     keyword_active(hintkey_looprest_sv)) {
601         *op_ptr = parse_keyword_looprest();
602         return KEYWORD_PLUGIN_STMT;
603     } else {
604         return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
605     }
606 }
607
608 XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
609 XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
610 XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
611
612 #include "const-c.inc"
613
614 MODULE = XS::APItest            PACKAGE = XS::APItest
615
616 INCLUDE: const-xs.inc
617
618 INCLUDE: numeric.xs
619
620 MODULE = XS::APItest            PACKAGE = XS::APItest::XSUB
621
622 BOOT:
623     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
624     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
625     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
626
627 void
628 XS_VERSION_defined(...)
629     PPCODE:
630         XS_VERSION_BOOTCHECK;
631         XSRETURN_EMPTY;
632
633 void
634 XS_APIVERSION_valid(...)
635     PPCODE:
636         XS_APIVERSION_BOOTCHECK;
637         XSRETURN_EMPTY;
638
639 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
640
641 void
642 rot13_hash(hash)
643         HV *hash
644         CODE:
645         {
646             struct ufuncs uf;
647             uf.uf_val = rot13_key;
648             uf.uf_set = 0;
649             uf.uf_index = 0;
650
651             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
652         }
653
654 void
655 bitflip_hash(hash)
656         HV *hash
657         CODE:
658         {
659             struct ufuncs uf;
660             uf.uf_val = bitflip_key;
661             uf.uf_set = 0;
662             uf.uf_index = 0;
663
664             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
665         }
666
667 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
668
669 bool
670 exists(hash, key_sv)
671         PREINIT:
672         STRLEN len;
673         const char *key;
674         INPUT:
675         HV *hash
676         SV *key_sv
677         CODE:
678         key = SvPV(key_sv, len);
679         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
680         OUTPUT:
681         RETVAL
682
683 bool
684 exists_ent(hash, key_sv)
685         PREINIT:
686         INPUT:
687         HV *hash
688         SV *key_sv
689         CODE:
690         RETVAL = hv_exists_ent(hash, key_sv, 0);
691         OUTPUT:
692         RETVAL
693
694 SV *
695 delete(hash, key_sv, flags = 0)
696         PREINIT:
697         STRLEN len;
698         const char *key;
699         INPUT:
700         HV *hash
701         SV *key_sv
702         I32 flags;
703         CODE:
704         key = SvPV(key_sv, len);
705         /* It's already mortal, so need to increase reference count.  */
706         RETVAL
707             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
708         OUTPUT:
709         RETVAL
710
711 SV *
712 delete_ent(hash, key_sv, flags = 0)
713         INPUT:
714         HV *hash
715         SV *key_sv
716         I32 flags;
717         CODE:
718         /* It's already mortal, so need to increase reference count.  */
719         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
720         OUTPUT:
721         RETVAL
722
723 SV *
724 store_ent(hash, key, value)
725         PREINIT:
726         SV *copy;
727         HE *result;
728         INPUT:
729         HV *hash
730         SV *key
731         SV *value
732         CODE:
733         copy = newSV(0);
734         result = hv_store_ent(hash, key, copy, 0);
735         SvSetMagicSV(copy, value);
736         if (!result) {
737             SvREFCNT_dec(copy);
738             XSRETURN_EMPTY;
739         }
740         /* It's about to become mortal, so need to increase reference count.
741          */
742         RETVAL = SvREFCNT_inc(HeVAL(result));
743         OUTPUT:
744         RETVAL
745
746 SV *
747 store(hash, key_sv, value)
748         PREINIT:
749         STRLEN len;
750         const char *key;
751         SV *copy;
752         SV **result;
753         INPUT:
754         HV *hash
755         SV *key_sv
756         SV *value
757         CODE:
758         key = SvPV(key_sv, len);
759         copy = newSV(0);
760         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
761         SvSetMagicSV(copy, value);
762         if (!result) {
763             SvREFCNT_dec(copy);
764             XSRETURN_EMPTY;
765         }
766         /* It's about to become mortal, so need to increase reference count.
767          */
768         RETVAL = SvREFCNT_inc(*result);
769         OUTPUT:
770         RETVAL
771
772 SV *
773 fetch_ent(hash, key_sv)
774         PREINIT:
775         HE *result;
776         INPUT:
777         HV *hash
778         SV *key_sv
779         CODE:
780         result = hv_fetch_ent(hash, key_sv, 0, 0);
781         if (!result) {
782             XSRETURN_EMPTY;
783         }
784         /* Force mg_get  */
785         RETVAL = newSVsv(HeVAL(result));
786         OUTPUT:
787         RETVAL
788
789 SV *
790 fetch(hash, key_sv)
791         PREINIT:
792         STRLEN len;
793         const char *key;
794         SV **result;
795         INPUT:
796         HV *hash
797         SV *key_sv
798         CODE:
799         key = SvPV(key_sv, len);
800         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
801         if (!result) {
802             XSRETURN_EMPTY;
803         }
804         /* Force mg_get  */
805         RETVAL = newSVsv(*result);
806         OUTPUT:
807         RETVAL
808
809 #if defined (hv_common)
810
811 SV *
812 common(params)
813         INPUT:
814         HV *params
815         PREINIT:
816         HE *result;
817         HV *hv = NULL;
818         SV *keysv = NULL;
819         const char *key = NULL;
820         STRLEN klen = 0;
821         int flags = 0;
822         int action = 0;
823         SV *val = NULL;
824         U32 hash = 0;
825         SV **svp;
826         CODE:
827         if ((svp = hv_fetchs(params, "hv", 0))) {
828             SV *const rv = *svp;
829             if (!SvROK(rv))
830                 croak("common passed a non-reference for parameter hv");
831             hv = (HV *)SvRV(rv);
832         }
833         if ((svp = hv_fetchs(params, "keysv", 0)))
834             keysv = *svp;
835         if ((svp = hv_fetchs(params, "keypv", 0))) {
836             key = SvPV_const(*svp, klen);
837             if (SvUTF8(*svp))
838                 flags = HVhek_UTF8;
839         }
840         if ((svp = hv_fetchs(params, "action", 0)))
841             action = SvIV(*svp);
842         if ((svp = hv_fetchs(params, "val", 0)))
843             val = newSVsv(*svp);
844         if ((svp = hv_fetchs(params, "hash", 0)))
845             hash = SvUV(*svp);
846
847         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
848             PERL_HASH(hash, key, klen);
849         }
850         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
851             STRLEN len;
852             const char *const p = SvPV(keysv, len);
853             PERL_HASH(hash, p, len);
854         }
855
856         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
857         if (!result) {
858             XSRETURN_EMPTY;
859         }
860         /* Force mg_get  */
861         RETVAL = newSVsv(HeVAL(result));
862         OUTPUT:
863         RETVAL
864
865 #endif
866
867 void
868 test_hv_free_ent()
869         PPCODE:
870         test_freeent(&Perl_hv_free_ent);
871         XSRETURN(4);
872
873 void
874 test_hv_delayfree_ent()
875         PPCODE:
876         test_freeent(&Perl_hv_delayfree_ent);
877         XSRETURN(4);
878
879 SV *
880 test_share_unshare_pvn(input)
881         PREINIT:
882         STRLEN len;
883         U32 hash;
884         char *pvx;
885         char *p;
886         INPUT:
887         SV *input
888         CODE:
889         pvx = SvPV(input, len);
890         PERL_HASH(hash, pvx, len);
891         p = sharepvn(pvx, len, hash);
892         RETVAL = newSVpvn(p, len);
893         unsharepvn(p, len, hash);
894         OUTPUT:
895         RETVAL
896
897 #if PERL_VERSION >= 9
898
899 bool
900 refcounted_he_exists(key, level=0)
901         SV *key
902         IV level
903         CODE:
904         if (level) {
905             croak("level must be zero, not %"IVdf, level);
906         }
907         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
908                                            key, NULL, 0, 0, 0)
909                   != &PL_sv_placeholder);
910         OUTPUT:
911         RETVAL
912
913 SV *
914 refcounted_he_fetch(key, level=0)
915         SV *key
916         IV level
917         CODE:
918         if (level) {
919             croak("level must be zero, not %"IVdf, level);
920         }
921         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
922                                           NULL, 0, 0, 0);
923         SvREFCNT_inc(RETVAL);
924         OUTPUT:
925         RETVAL
926
927 #endif
928
929 =pod
930
931 sub TIEHASH  { bless {}, $_[0] }
932 sub STORE    { $_[0]->{$_[1]} = $_[2] }
933 sub FETCH    { $_[0]->{$_[1]} }
934 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
935 sub NEXTKEY  { each %{$_[0]} }
936 sub EXISTS   { exists $_[0]->{$_[1]} }
937 sub DELETE   { delete $_[0]->{$_[1]} }
938 sub CLEAR    { %{$_[0]} = () }
939
940 =cut
941
942 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
943
944 void
945 make_temp_mg_lv(sv)
946 SV* sv
947     PREINIT:
948         SV * const lv = newSV_type(SVt_PVLV);
949         STRLEN len;
950     PPCODE:
951         SvPV(sv, len);
952
953         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
954         LvTYPE(lv) = 'x';
955         LvTARG(lv) = SvREFCNT_inc_simple(sv);
956         LvTARGOFF(lv) = len == 0 ? 0 : 1;
957         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
958
959         EXTEND(SP, 1);
960         ST(0) = sv_2mortal(lv);
961         XSRETURN(1);
962
963
964 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
965
966 void
967 ptr_table_new(classname)
968 const char * classname
969     PPCODE:
970     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
971
972 void
973 DESTROY(table)
974 XS::APItest::PtrTable table
975     CODE:
976     ptr_table_free(table);
977
978 void
979 ptr_table_store(table, from, to)
980 XS::APItest::PtrTable table
981 SVREF from
982 SVREF to
983    CODE:
984    ptr_table_store(table, from, to);
985
986 UV
987 ptr_table_fetch(table, from)
988 XS::APItest::PtrTable table
989 SVREF from
990    CODE:
991    RETVAL = PTR2UV(ptr_table_fetch(table, from));
992    OUTPUT:
993    RETVAL
994
995 void
996 ptr_table_split(table)
997 XS::APItest::PtrTable table
998
999 void
1000 ptr_table_clear(table)
1001 XS::APItest::PtrTable table
1002
1003 MODULE = XS::APItest            PACKAGE = XS::APItest
1004
1005 PROTOTYPES: DISABLE
1006
1007 BOOT:
1008 {
1009     MY_CXT_INIT;
1010
1011     MY_CXT.i  = 99;
1012     MY_CXT.sv = newSVpv("initial",0);
1013
1014     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1015     MY_CXT.bhk_record = 0;
1016
1017     BhkENTRY_set(&bhk_test, start, blockhook_test_start);
1018     BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
1019     BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
1020     BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
1021     Perl_blockhook_register(aTHX_ &bhk_test);
1022
1023     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1024         GV_ADDMULTI, SVt_PVAV);
1025     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1026
1027     BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
1028     BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
1029     Perl_blockhook_register(aTHX_ &bhk_csc);
1030
1031     MY_CXT.peep_recorder = newAV();
1032     MY_CXT.rpeep_recorder = newAV();
1033
1034     MY_CXT.orig_peep = PL_peepp;
1035     MY_CXT.orig_rpeep = PL_rpeepp;
1036     PL_peepp = my_peep;
1037     PL_rpeepp = my_rpeep;
1038 }
1039
1040 void
1041 CLONE(...)
1042     CODE:
1043     MY_CXT_CLONE;
1044     MY_CXT.sv = newSVpv("initial_clone",0);
1045     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1046         GV_ADDMULTI, SVt_PVAV);
1047     MY_CXT.cscav = NULL;
1048     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1049     MY_CXT.bhk_record = 0;
1050     MY_CXT.peep_recorder = newAV();
1051     MY_CXT.rpeep_recorder = newAV();
1052
1053 void
1054 print_double(val)
1055         double val
1056         CODE:
1057         printf("%5.3f\n",val);
1058
1059 int
1060 have_long_double()
1061         CODE:
1062 #ifdef HAS_LONG_DOUBLE
1063         RETVAL = 1;
1064 #else
1065         RETVAL = 0;
1066 #endif
1067         OUTPUT:
1068         RETVAL
1069
1070 void
1071 print_long_double()
1072         CODE:
1073 #ifdef HAS_LONG_DOUBLE
1074 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
1075         long double val = 7.0;
1076         printf("%5.3" PERL_PRIfldbl "\n",val);
1077 #   else
1078         double val = 7.0;
1079         printf("%5.3f\n",val);
1080 #   endif
1081 #endif
1082
1083 void
1084 print_int(val)
1085         int val
1086         CODE:
1087         printf("%d\n",val);
1088
1089 void
1090 print_long(val)
1091         long val
1092         CODE:
1093         printf("%ld\n",val);
1094
1095 void
1096 print_float(val)
1097         float val
1098         CODE:
1099         printf("%5.3f\n",val);
1100         
1101 void
1102 print_flush()
1103         CODE:
1104         fflush(stdout);
1105
1106 void
1107 mpushp()
1108         PPCODE:
1109         EXTEND(SP, 3);
1110         mPUSHp("one", 3);
1111         mPUSHp("two", 3);
1112         mPUSHp("three", 5);
1113         XSRETURN(3);
1114
1115 void
1116 mpushn()
1117         PPCODE:
1118         EXTEND(SP, 3);
1119         mPUSHn(0.5);
1120         mPUSHn(-0.25);
1121         mPUSHn(0.125);
1122         XSRETURN(3);
1123
1124 void
1125 mpushi()
1126         PPCODE:
1127         EXTEND(SP, 3);
1128         mPUSHi(-1);
1129         mPUSHi(2);
1130         mPUSHi(-3);
1131         XSRETURN(3);
1132
1133 void
1134 mpushu()
1135         PPCODE:
1136         EXTEND(SP, 3);
1137         mPUSHu(1);
1138         mPUSHu(2);
1139         mPUSHu(3);
1140         XSRETURN(3);
1141
1142 void
1143 mxpushp()
1144         PPCODE:
1145         mXPUSHp("one", 3);
1146         mXPUSHp("two", 3);
1147         mXPUSHp("three", 5);
1148         XSRETURN(3);
1149
1150 void
1151 mxpushn()
1152         PPCODE:
1153         mXPUSHn(0.5);
1154         mXPUSHn(-0.25);
1155         mXPUSHn(0.125);
1156         XSRETURN(3);
1157
1158 void
1159 mxpushi()
1160         PPCODE:
1161         mXPUSHi(-1);
1162         mXPUSHi(2);
1163         mXPUSHi(-3);
1164         XSRETURN(3);
1165
1166 void
1167 mxpushu()
1168         PPCODE:
1169         mXPUSHu(1);
1170         mXPUSHu(2);
1171         mXPUSHu(3);
1172         XSRETURN(3);
1173
1174
1175 void
1176 call_sv(sv, flags, ...)
1177     SV* sv
1178     I32 flags
1179     PREINIT:
1180         I32 i;
1181     PPCODE:
1182         for (i=0; i<items-2; i++)
1183             ST(i) = ST(i+2); /* pop first two args */
1184         PUSHMARK(SP);
1185         SP += items - 2;
1186         PUTBACK;
1187         i = call_sv(sv, flags);
1188         SPAGAIN;
1189         EXTEND(SP, 1);
1190         PUSHs(sv_2mortal(newSViv(i)));
1191
1192 void
1193 call_pv(subname, flags, ...)
1194     char* subname
1195     I32 flags
1196     PREINIT:
1197         I32 i;
1198     PPCODE:
1199         for (i=0; i<items-2; i++)
1200             ST(i) = ST(i+2); /* pop first two args */
1201         PUSHMARK(SP);
1202         SP += items - 2;
1203         PUTBACK;
1204         i = call_pv(subname, flags);
1205         SPAGAIN;
1206         EXTEND(SP, 1);
1207         PUSHs(sv_2mortal(newSViv(i)));
1208
1209 void
1210 call_method(methname, flags, ...)
1211     char* methname
1212     I32 flags
1213     PREINIT:
1214         I32 i;
1215     PPCODE:
1216         for (i=0; i<items-2; i++)
1217             ST(i) = ST(i+2); /* pop first two args */
1218         PUSHMARK(SP);
1219         SP += items - 2;
1220         PUTBACK;
1221         i = call_method(methname, flags);
1222         SPAGAIN;
1223         EXTEND(SP, 1);
1224         PUSHs(sv_2mortal(newSViv(i)));
1225
1226 void
1227 eval_sv(sv, flags)
1228     SV* sv
1229     I32 flags
1230     PREINIT:
1231         I32 i;
1232     PPCODE:
1233         PUTBACK;
1234         i = eval_sv(sv, flags);
1235         SPAGAIN;
1236         EXTEND(SP, 1);
1237         PUSHs(sv_2mortal(newSViv(i)));
1238
1239 void
1240 eval_pv(p, croak_on_error)
1241     const char* p
1242     I32 croak_on_error
1243     PPCODE:
1244         PUTBACK;
1245         EXTEND(SP, 1);
1246         PUSHs(eval_pv(p, croak_on_error));
1247
1248 void
1249 require_pv(pv)
1250     const char* pv
1251     PPCODE:
1252         PUTBACK;
1253         require_pv(pv);
1254
1255 int
1256 apitest_exception(throw_e)
1257     int throw_e
1258     OUTPUT:
1259         RETVAL
1260
1261 void
1262 mycroak(sv)
1263     SV* sv
1264     CODE:
1265     if (SvOK(sv)) {
1266         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
1267     }
1268     else {
1269         Perl_croak(aTHX_ NULL);
1270     }
1271
1272 SV*
1273 strtab()
1274    CODE:
1275    RETVAL = newRV_inc((SV*)PL_strtab);
1276    OUTPUT:
1277    RETVAL
1278
1279 int
1280 my_cxt_getint()
1281     CODE:
1282         dMY_CXT;
1283         RETVAL = my_cxt_getint_p(aMY_CXT);
1284     OUTPUT:
1285         RETVAL
1286
1287 void
1288 my_cxt_setint(i)
1289     int i;
1290     CODE:
1291         dMY_CXT;
1292         my_cxt_setint_p(aMY_CXT_ i);
1293
1294 void
1295 my_cxt_getsv(how)
1296     bool how;
1297     PPCODE:
1298         EXTEND(SP, 1);
1299         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
1300         XSRETURN(1);
1301
1302 void
1303 my_cxt_setsv(sv)
1304     SV *sv;
1305     CODE:
1306         dMY_CXT;
1307         SvREFCNT_dec(MY_CXT.sv);
1308         my_cxt_setsv_p(sv _aMY_CXT);
1309         SvREFCNT_inc(sv);
1310
1311 bool
1312 sv_setsv_cow_hashkey_core()
1313
1314 bool
1315 sv_setsv_cow_hashkey_notcore()
1316
1317 void
1318 rmagical_cast(sv, type)
1319     SV *sv;
1320     SV *type;
1321     PREINIT:
1322         struct ufuncs uf;
1323     PPCODE:
1324         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1325         sv = SvRV(sv);
1326         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1327         uf.uf_val = rmagical_a_dummy;
1328         uf.uf_set = NULL;
1329         uf.uf_index = 0;
1330         if (SvTRUE(type)) { /* b */
1331             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1332         } else { /* a */
1333             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1334         }
1335         XSRETURN_YES;
1336
1337 void
1338 rmagical_flags(sv)
1339     SV *sv;
1340     PPCODE:
1341         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1342         sv = SvRV(sv);
1343         EXTEND(SP, 3); 
1344         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1345         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1346         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1347         XSRETURN(3);
1348
1349 void
1350 my_caller(level)
1351         I32 level
1352     PREINIT:
1353         const PERL_CONTEXT *cx, *dbcx;
1354         const char *pv;
1355         const GV *gv;
1356         HV *hv;
1357     PPCODE:
1358         cx = caller_cx(level, &dbcx);
1359         EXTEND(SP, 8);
1360
1361         pv = CopSTASHPV(cx->blk_oldcop);
1362         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1363         gv = CvGV(cx->blk_sub.cv);
1364         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1365
1366         pv = CopSTASHPV(dbcx->blk_oldcop);
1367         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1368         gv = CvGV(dbcx->blk_sub.cv);
1369         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1370
1371         ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1372         ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1373         ST(6) = cop_hints_fetchsv(cx->blk_oldcop, 
1374                 sv_2mortal(newSVpvn("foo", 3)), 0);
1375
1376         hv = cop_hints_2hv(cx->blk_oldcop);
1377         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1378
1379         XSRETURN(8);
1380
1381 void
1382 DPeek (sv)
1383     SV   *sv
1384
1385   PPCODE:
1386     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1387     XSRETURN (1);
1388
1389 void
1390 BEGIN()
1391     CODE:
1392         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1393
1394 void
1395 CHECK()
1396     CODE:
1397         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1398
1399 void
1400 UNITCHECK()
1401     CODE:
1402         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1403
1404 void
1405 INIT()
1406     CODE:
1407         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1408
1409 void
1410 END()
1411     CODE:
1412         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1413
1414 void
1415 utf16_to_utf8 (sv, ...)
1416     SV* sv
1417         ALIAS:
1418             utf16_to_utf8_reversed = 1
1419     PREINIT:
1420         STRLEN len;
1421         U8 *source;
1422         SV *dest;
1423         I32 got; /* Gah, badly thought out APIs */
1424     CODE:
1425         source = (U8 *)SvPVbyte(sv, len);
1426         /* Optionally only convert part of the buffer.  */      
1427         if (items > 1) {
1428             len = SvUV(ST(1));
1429         }
1430         /* Mortalise this right now, as we'll be testing croak()s  */
1431         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1432         if (ix) {
1433             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1434         } else {
1435             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1436         }
1437         SvCUR_set(dest, got);
1438         SvPVX(dest)[got] = '\0';
1439         SvPOK_on(dest);
1440         ST(0) = dest;
1441         XSRETURN(1);
1442
1443 void
1444 my_exit(int exitcode)
1445         PPCODE:
1446         my_exit(exitcode);
1447
1448 I32
1449 sv_count()
1450         CODE:
1451             RETVAL = PL_sv_count;
1452         OUTPUT:
1453             RETVAL
1454
1455 void
1456 bhk_record(bool on)
1457     CODE:
1458         dMY_CXT;
1459         MY_CXT.bhk_record = on;
1460         if (on)
1461             av_clear(MY_CXT.bhkav);
1462
1463 void
1464 test_savehints()
1465     PREINIT:
1466         SV **svp, *sv;
1467     CODE:
1468 #define store_hint(KEY, VALUE) \
1469                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1470 #define hint_ok(KEY, EXPECT) \
1471                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1472                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
1473                     (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1474                     SvIV(sv) == (EXPECT))
1475 #define check_hint(KEY, EXPECT) \
1476                 do { if (!hint_ok(KEY, EXPECT)) croak("fail"); } while(0)
1477         PL_hints |= HINT_LOCALIZE_HH;
1478         ENTER;
1479         SAVEHINTS();
1480         PL_hints &= HINT_INTEGER;
1481         store_hint("t0", 123);
1482         store_hint("t1", 456);
1483         if (PL_hints & HINT_INTEGER) croak("fail");
1484         check_hint("t0", 123); check_hint("t1", 456);
1485         ENTER;
1486         SAVEHINTS();
1487         if (PL_hints & HINT_INTEGER) croak("fail");
1488         check_hint("t0", 123); check_hint("t1", 456);
1489         PL_hints |= HINT_INTEGER;
1490         store_hint("t0", 321);
1491         if (!(PL_hints & HINT_INTEGER)) croak("fail");
1492         check_hint("t0", 321); check_hint("t1", 456);
1493         LEAVE;
1494         if (PL_hints & HINT_INTEGER) croak("fail");
1495         check_hint("t0", 123); check_hint("t1", 456);
1496         ENTER;
1497         SAVEHINTS();
1498         if (PL_hints & HINT_INTEGER) croak("fail");
1499         check_hint("t0", 123); check_hint("t1", 456);
1500         store_hint("t1", 654);
1501         if (PL_hints & HINT_INTEGER) croak("fail");
1502         check_hint("t0", 123); check_hint("t1", 654);
1503         LEAVE;
1504         if (PL_hints & HINT_INTEGER) croak("fail");
1505         check_hint("t0", 123); check_hint("t1", 456);
1506         LEAVE;
1507 #undef store_hint
1508 #undef hint_ok
1509 #undef check_hint
1510
1511 void
1512 test_copyhints()
1513     PREINIT:
1514         HV *a, *b;
1515     CODE:
1516         PL_hints |= HINT_LOCALIZE_HH;
1517         ENTER;
1518         SAVEHINTS();
1519         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
1520         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1521         a = newHVhv(GvHV(PL_hintgv));
1522         sv_2mortal((SV*)a);
1523         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
1524         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1525         b = hv_copy_hints_hv(a);
1526         sv_2mortal((SV*)b);
1527         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
1528         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak("fail");
1529         LEAVE;
1530
1531 void
1532 peep_enable ()
1533     PREINIT:
1534         dMY_CXT;
1535     CODE:
1536         av_clear(MY_CXT.peep_recorder);
1537         av_clear(MY_CXT.rpeep_recorder);
1538         MY_CXT.peep_recording = 1;
1539
1540 void
1541 peep_disable ()
1542     PREINIT:
1543         dMY_CXT;
1544     CODE:
1545         MY_CXT.peep_recording = 0;
1546
1547 SV *
1548 peep_record ()
1549     PREINIT:
1550         dMY_CXT;
1551     CODE:
1552         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
1553     OUTPUT:
1554         RETVAL
1555
1556 SV *
1557 rpeep_record ()
1558     PREINIT:
1559         dMY_CXT;
1560     CODE:
1561         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
1562     OUTPUT:
1563         RETVAL
1564
1565 BOOT:
1566         {
1567         HV* stash;
1568         SV** meth = NULL;
1569         CV* cv;
1570         stash = gv_stashpv("XS::APItest::TempLv", 0);
1571         if (stash)
1572             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
1573         if (!meth)
1574             croak("lost method 'make_temp_mg_lv'");
1575         cv = GvCV(*meth);
1576         CvLVALUE_on(cv);
1577         }
1578
1579 BOOT:
1580 {
1581     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
1582     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
1583     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
1584     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
1585     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
1586     next_keyword_plugin = PL_keyword_plugin;
1587     PL_keyword_plugin = my_keyword_plugin;
1588 }