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