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