This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix and test PL_expect in recdescent parsing
[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 STATIC void test_op_list_describe_part(SV *res, OP *o);
422 STATIC void
423 test_op_list_describe_part(SV *res, OP *o)
424 {
425     sv_catpv(res, PL_op_name[o->op_type]);
426     switch (o->op_type) {
427         case OP_CONST: {
428             sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
429         } break;
430     }
431     if (o->op_flags & OPf_KIDS) {
432         OP *k;
433         sv_catpvs(res, "[");
434         for (k = cUNOPx(o)->op_first; k; k = k->op_sibling)
435             test_op_list_describe_part(res, k);
436         sv_catpvs(res, "]");
437     } else {
438         sv_catpvs(res, ".");
439     }
440 }
441
442 STATIC char *
443 test_op_list_describe(OP *o)
444 {
445     SV *res = sv_2mortal(newSVpvs(""));
446     if (o)
447         test_op_list_describe_part(res, o);
448     return SvPVX(res);
449 }
450
451 /* the real new*OP functions have a tendancy to call fold_constants, and
452  * other such unhelpful things, so we need our own versions for testing */
453
454 #define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
455 static OP *
456 THX_mkUNOP(pTHX_ U32 type, OP *first)
457 {
458     UNOP *unop;
459     NewOp(1103, unop, 1, UNOP);
460     unop->op_type   = (OPCODE)type;
461     unop->op_first  = first;
462     unop->op_flags  = OPf_KIDS;
463     return (OP *)unop;
464 }
465
466 #define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
467 static OP *
468 THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
469 {
470     BINOP *binop;
471     NewOp(1103, binop, 1, BINOP);
472     binop->op_type      = (OPCODE)type;
473     binop->op_first     = first;
474     binop->op_flags     = OPf_KIDS;
475     binop->op_last      = last;
476     first->op_sibling   = last;
477     return (OP *)binop;
478 }
479
480 #define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
481 static OP *
482 THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
483 {
484     LISTOP *listop;
485     NewOp(1103, listop, 1, LISTOP);
486     listop->op_type     = (OPCODE)type;
487     listop->op_flags    = OPf_KIDS;
488     listop->op_first    = first;
489     first->op_sibling   = sib;
490     sib->op_sibling     = last;
491     listop->op_last     = last;
492     return (OP *)listop;
493 }
494
495 static char *
496 test_op_linklist_describe(OP *start)
497 {
498     SV *rv = sv_2mortal(newSVpvs(""));
499     OP *o;
500     o = start = LINKLIST(start);
501     do {
502         sv_catpvs(rv, ".");
503         sv_catpv(rv, OP_NAME(o));
504         if (o->op_type == OP_CONST)
505             sv_catsv(rv, cSVOPo->op_sv);
506         o = o->op_next;
507     } while (o && o != start);
508     return SvPVX(rv);
509 }
510
511 /** RPN keyword parser **/
512
513 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
514 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
515 #define sv_is_string(sv) \
516     (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
517      (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
518
519 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
520 static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
521 static SV *hintkey_scopelessblock_sv;
522 static SV *hintkey_stmtasexpr_sv,  *hintkey_stmtsasexpr_sv;
523 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
524
525 /* low-level parser helpers */
526
527 #define PL_bufptr (PL_parser->bufptr)
528 #define PL_bufend (PL_parser->bufend)
529
530 /* RPN parser */
531
532 #define parse_var() THX_parse_var(aTHX)
533 static OP *THX_parse_var(pTHX)
534 {
535     char *s = PL_bufptr;
536     char *start = s;
537     PADOFFSET varpos;
538     OP *padop;
539     if(*s != '$') croak("RPN syntax error");
540     while(1) {
541         char c = *++s;
542         if(!isALNUM(c)) break;
543     }
544     if(s-start < 2) croak("RPN syntax error");
545     lex_read_to(s);
546     {
547         /* because pad_findmy() doesn't really use length yet */
548         SV *namesv = sv_2mortal(newSVpvn(start, s-start));
549         varpos = pad_findmy(SvPVX(namesv), s-start, 0);
550     }
551     if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
552         croak("RPN only supports \"my\" variables");
553     padop = newOP(OP_PADSV, 0);
554     padop->op_targ = varpos;
555     return padop;
556 }
557
558 #define push_rpn_item(o) \
559     (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
560 #define pop_rpn_item() \
561     (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
562      (tmpop = stack, stack = stack->op_sibling, \
563       tmpop->op_sibling = NULL, tmpop))
564
565 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
566 static OP *THX_parse_rpn_expr(pTHX)
567 {
568     OP *stack = NULL, *tmpop;
569     while(1) {
570         I32 c;
571         lex_read_space(0);
572         c = lex_peek_unichar(0);
573         switch(c) {
574             case /*(*/')': case /*{*/'}': {
575                 OP *result = pop_rpn_item();
576                 if(stack) croak("RPN expression must return a single value");
577                 return result;
578             } break;
579             case '0': case '1': case '2': case '3': case '4':
580             case '5': case '6': case '7': case '8': case '9': {
581                 UV val = 0;
582                 do {
583                     lex_read_unichar(0);
584                     val = 10*val + (c - '0');
585                     c = lex_peek_unichar(0);
586                 } while(c >= '0' && c <= '9');
587                 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
588             } break;
589             case '$': {
590                 push_rpn_item(parse_var());
591             } break;
592             case '+': {
593                 OP *b = pop_rpn_item();
594                 OP *a = pop_rpn_item();
595                 lex_read_unichar(0);
596                 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
597             } break;
598             case '-': {
599                 OP *b = pop_rpn_item();
600                 OP *a = pop_rpn_item();
601                 lex_read_unichar(0);
602                 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
603             } break;
604             case '*': {
605                 OP *b = pop_rpn_item();
606                 OP *a = pop_rpn_item();
607                 lex_read_unichar(0);
608                 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
609             } break;
610             case '/': {
611                 OP *b = pop_rpn_item();
612                 OP *a = pop_rpn_item();
613                 lex_read_unichar(0);
614                 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
615             } break;
616             case '%': {
617                 OP *b = pop_rpn_item();
618                 OP *a = pop_rpn_item();
619                 lex_read_unichar(0);
620                 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
621             } break;
622             default: {
623                 croak("RPN syntax error");
624             } break;
625         }
626     }
627 }
628
629 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
630 static OP *THX_parse_keyword_rpn(pTHX)
631 {
632     OP *op;
633     lex_read_space(0);
634     if(lex_peek_unichar(0) != '('/*)*/)
635         croak("RPN expression must be parenthesised");
636     lex_read_unichar(0);
637     op = parse_rpn_expr();
638     if(lex_peek_unichar(0) != /*(*/')')
639         croak("RPN expression must be parenthesised");
640     lex_read_unichar(0);
641     return op;
642 }
643
644 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
645 static OP *THX_parse_keyword_calcrpn(pTHX)
646 {
647     OP *varop, *exprop;
648     lex_read_space(0);
649     varop = parse_var();
650     lex_read_space(0);
651     if(lex_peek_unichar(0) != '{'/*}*/)
652         croak("RPN expression must be braced");
653     lex_read_unichar(0);
654     exprop = parse_rpn_expr();
655     if(lex_peek_unichar(0) != /*{*/'}')
656         croak("RPN expression must be braced");
657     lex_read_unichar(0);
658     return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
659 }
660
661 #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
662 static OP *THX_parse_keyword_stufftest(pTHX)
663 {
664     I32 c;
665     bool do_stuff;
666     lex_read_space(0);
667     do_stuff = lex_peek_unichar(0) == '+';
668     if(do_stuff) {
669         lex_read_unichar(0);
670         lex_read_space(0);
671     }
672     c = lex_peek_unichar(0);
673     if(c == ';') {
674         lex_read_unichar(0);
675     } else if(c != /*{*/'}') {
676         croak("syntax error");
677     }
678     if(do_stuff) lex_stuff_pvs(" ", 0);
679     return newOP(OP_NULL, 0);
680 }
681
682 #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
683 static OP *THX_parse_keyword_swaptwostmts(pTHX)
684 {
685     OP *a, *b;
686     a = parse_fullstmt(0);
687     b = parse_fullstmt(0);
688     if(a && b)
689         PL_hints |= HINT_BLOCK_SCOPE;
690     return op_append_list(OP_LINESEQ, b, a);
691 }
692
693 #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
694 static OP *THX_parse_keyword_looprest(pTHX)
695 {
696     I32 condline;
697     OP *body;
698     condline = CopLINE(PL_curcop);
699     body = parse_stmtseq(0);
700     return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
701                         body, NULL, 1);
702 }
703
704 #define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
705 static OP *THX_parse_keyword_scopelessblock(pTHX)
706 {
707     I32 c;
708     OP *body;
709     lex_read_space(0);
710     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
711     lex_read_unichar(0);
712     body = parse_stmtseq(0);
713     c = lex_peek_unichar(0);
714     if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error");
715     lex_read_unichar(0);
716     return body;
717 }
718
719 #define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
720 static OP *THX_parse_keyword_stmtasexpr(pTHX)
721 {
722     OP *o = parse_fullstmt(0);
723     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
724     o->op_type = OP_LEAVE;
725     o->op_ppaddr = PL_ppaddr[OP_LEAVE];
726     return o;
727 }
728
729 #define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
730 static OP *THX_parse_keyword_stmtsasexpr(pTHX)
731 {
732     OP *o;
733     lex_read_space(0);
734     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
735     lex_read_unichar(0);
736     o = parse_stmtseq(0);
737     lex_read_space(0);
738     if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
739     lex_read_unichar(0);
740     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
741     o->op_type = OP_LEAVE;
742     o->op_ppaddr = PL_ppaddr[OP_LEAVE];
743     return o;
744 }
745
746 /* plugin glue */
747
748 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
749 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
750 {
751     HE *he;
752     if(!GvHV(PL_hintgv)) return 0;
753     he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
754                 SvSHARED_HASH(hintkey_sv));
755     return he && SvTRUE(HeVAL(he));
756 }
757
758 static int my_keyword_plugin(pTHX_
759     char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
760 {
761     if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
762                     keyword_active(hintkey_rpn_sv)) {
763         *op_ptr = parse_keyword_rpn();
764         return KEYWORD_PLUGIN_EXPR;
765     } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
766                     keyword_active(hintkey_calcrpn_sv)) {
767         *op_ptr = parse_keyword_calcrpn();
768         return KEYWORD_PLUGIN_STMT;
769     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
770                     keyword_active(hintkey_stufftest_sv)) {
771         *op_ptr = parse_keyword_stufftest();
772         return KEYWORD_PLUGIN_STMT;
773     } else if(keyword_len == 12 &&
774                     strnEQ(keyword_ptr, "swaptwostmts", 12) &&
775                     keyword_active(hintkey_swaptwostmts_sv)) {
776         *op_ptr = parse_keyword_swaptwostmts();
777         return KEYWORD_PLUGIN_STMT;
778     } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
779                     keyword_active(hintkey_looprest_sv)) {
780         *op_ptr = parse_keyword_looprest();
781         return KEYWORD_PLUGIN_STMT;
782     } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) &&
783                     keyword_active(hintkey_scopelessblock_sv)) {
784         *op_ptr = parse_keyword_scopelessblock();
785         return KEYWORD_PLUGIN_STMT;
786     } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) &&
787                     keyword_active(hintkey_stmtasexpr_sv)) {
788         *op_ptr = parse_keyword_stmtasexpr();
789         return KEYWORD_PLUGIN_EXPR;
790     } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) &&
791                     keyword_active(hintkey_stmtsasexpr_sv)) {
792         *op_ptr = parse_keyword_stmtsasexpr();
793         return KEYWORD_PLUGIN_EXPR;
794     } else {
795         return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
796     }
797 }
798
799 XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
800 XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
801 XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
802
803 #include "const-c.inc"
804
805 MODULE = XS::APItest            PACKAGE = XS::APItest
806
807 INCLUDE: const-xs.inc
808
809 INCLUDE: numeric.xs
810
811 MODULE = XS::APItest            PACKAGE = XS::APItest::XSUB
812
813 BOOT:
814     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
815     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
816     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
817
818 void
819 XS_VERSION_defined(...)
820     PPCODE:
821         XS_VERSION_BOOTCHECK;
822         XSRETURN_EMPTY;
823
824 void
825 XS_APIVERSION_valid(...)
826     PPCODE:
827         XS_APIVERSION_BOOTCHECK;
828         XSRETURN_EMPTY;
829
830 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
831
832 void
833 rot13_hash(hash)
834         HV *hash
835         CODE:
836         {
837             struct ufuncs uf;
838             uf.uf_val = rot13_key;
839             uf.uf_set = 0;
840             uf.uf_index = 0;
841
842             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
843         }
844
845 void
846 bitflip_hash(hash)
847         HV *hash
848         CODE:
849         {
850             struct ufuncs uf;
851             uf.uf_val = bitflip_key;
852             uf.uf_set = 0;
853             uf.uf_index = 0;
854
855             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
856         }
857
858 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
859
860 bool
861 exists(hash, key_sv)
862         PREINIT:
863         STRLEN len;
864         const char *key;
865         INPUT:
866         HV *hash
867         SV *key_sv
868         CODE:
869         key = SvPV(key_sv, len);
870         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
871         OUTPUT:
872         RETVAL
873
874 bool
875 exists_ent(hash, key_sv)
876         PREINIT:
877         INPUT:
878         HV *hash
879         SV *key_sv
880         CODE:
881         RETVAL = hv_exists_ent(hash, key_sv, 0);
882         OUTPUT:
883         RETVAL
884
885 SV *
886 delete(hash, key_sv, flags = 0)
887         PREINIT:
888         STRLEN len;
889         const char *key;
890         INPUT:
891         HV *hash
892         SV *key_sv
893         I32 flags;
894         CODE:
895         key = SvPV(key_sv, len);
896         /* It's already mortal, so need to increase reference count.  */
897         RETVAL
898             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
899         OUTPUT:
900         RETVAL
901
902 SV *
903 delete_ent(hash, key_sv, flags = 0)
904         INPUT:
905         HV *hash
906         SV *key_sv
907         I32 flags;
908         CODE:
909         /* It's already mortal, so need to increase reference count.  */
910         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
911         OUTPUT:
912         RETVAL
913
914 SV *
915 store_ent(hash, key, value)
916         PREINIT:
917         SV *copy;
918         HE *result;
919         INPUT:
920         HV *hash
921         SV *key
922         SV *value
923         CODE:
924         copy = newSV(0);
925         result = hv_store_ent(hash, key, copy, 0);
926         SvSetMagicSV(copy, value);
927         if (!result) {
928             SvREFCNT_dec(copy);
929             XSRETURN_EMPTY;
930         }
931         /* It's about to become mortal, so need to increase reference count.
932          */
933         RETVAL = SvREFCNT_inc(HeVAL(result));
934         OUTPUT:
935         RETVAL
936
937 SV *
938 store(hash, key_sv, value)
939         PREINIT:
940         STRLEN len;
941         const char *key;
942         SV *copy;
943         SV **result;
944         INPUT:
945         HV *hash
946         SV *key_sv
947         SV *value
948         CODE:
949         key = SvPV(key_sv, len);
950         copy = newSV(0);
951         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
952         SvSetMagicSV(copy, value);
953         if (!result) {
954             SvREFCNT_dec(copy);
955             XSRETURN_EMPTY;
956         }
957         /* It's about to become mortal, so need to increase reference count.
958          */
959         RETVAL = SvREFCNT_inc(*result);
960         OUTPUT:
961         RETVAL
962
963 SV *
964 fetch_ent(hash, key_sv)
965         PREINIT:
966         HE *result;
967         INPUT:
968         HV *hash
969         SV *key_sv
970         CODE:
971         result = hv_fetch_ent(hash, key_sv, 0, 0);
972         if (!result) {
973             XSRETURN_EMPTY;
974         }
975         /* Force mg_get  */
976         RETVAL = newSVsv(HeVAL(result));
977         OUTPUT:
978         RETVAL
979
980 SV *
981 fetch(hash, key_sv)
982         PREINIT:
983         STRLEN len;
984         const char *key;
985         SV **result;
986         INPUT:
987         HV *hash
988         SV *key_sv
989         CODE:
990         key = SvPV(key_sv, len);
991         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
992         if (!result) {
993             XSRETURN_EMPTY;
994         }
995         /* Force mg_get  */
996         RETVAL = newSVsv(*result);
997         OUTPUT:
998         RETVAL
999
1000 #if defined (hv_common)
1001
1002 SV *
1003 common(params)
1004         INPUT:
1005         HV *params
1006         PREINIT:
1007         HE *result;
1008         HV *hv = NULL;
1009         SV *keysv = NULL;
1010         const char *key = NULL;
1011         STRLEN klen = 0;
1012         int flags = 0;
1013         int action = 0;
1014         SV *val = NULL;
1015         U32 hash = 0;
1016         SV **svp;
1017         CODE:
1018         if ((svp = hv_fetchs(params, "hv", 0))) {
1019             SV *const rv = *svp;
1020             if (!SvROK(rv))
1021                 croak("common passed a non-reference for parameter hv");
1022             hv = (HV *)SvRV(rv);
1023         }
1024         if ((svp = hv_fetchs(params, "keysv", 0)))
1025             keysv = *svp;
1026         if ((svp = hv_fetchs(params, "keypv", 0))) {
1027             key = SvPV_const(*svp, klen);
1028             if (SvUTF8(*svp))
1029                 flags = HVhek_UTF8;
1030         }
1031         if ((svp = hv_fetchs(params, "action", 0)))
1032             action = SvIV(*svp);
1033         if ((svp = hv_fetchs(params, "val", 0)))
1034             val = newSVsv(*svp);
1035         if ((svp = hv_fetchs(params, "hash", 0)))
1036             hash = SvUV(*svp);
1037
1038         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
1039             PERL_HASH(hash, key, klen);
1040         }
1041         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
1042             STRLEN len;
1043             const char *const p = SvPV(keysv, len);
1044             PERL_HASH(hash, p, len);
1045         }
1046
1047         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
1048         if (!result) {
1049             XSRETURN_EMPTY;
1050         }
1051         /* Force mg_get  */
1052         RETVAL = newSVsv(HeVAL(result));
1053         OUTPUT:
1054         RETVAL
1055
1056 #endif
1057
1058 void
1059 test_hv_free_ent()
1060         PPCODE:
1061         test_freeent(&Perl_hv_free_ent);
1062         XSRETURN(4);
1063
1064 void
1065 test_hv_delayfree_ent()
1066         PPCODE:
1067         test_freeent(&Perl_hv_delayfree_ent);
1068         XSRETURN(4);
1069
1070 SV *
1071 test_share_unshare_pvn(input)
1072         PREINIT:
1073         STRLEN len;
1074         U32 hash;
1075         char *pvx;
1076         char *p;
1077         INPUT:
1078         SV *input
1079         CODE:
1080         pvx = SvPV(input, len);
1081         PERL_HASH(hash, pvx, len);
1082         p = sharepvn(pvx, len, hash);
1083         RETVAL = newSVpvn(p, len);
1084         unsharepvn(p, len, hash);
1085         OUTPUT:
1086         RETVAL
1087
1088 #if PERL_VERSION >= 9
1089
1090 bool
1091 refcounted_he_exists(key, level=0)
1092         SV *key
1093         IV level
1094         CODE:
1095         if (level) {
1096             croak("level must be zero, not %"IVdf, level);
1097         }
1098         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
1099                                            key, NULL, 0, 0, 0)
1100                   != &PL_sv_placeholder);
1101         OUTPUT:
1102         RETVAL
1103
1104 SV *
1105 refcounted_he_fetch(key, level=0)
1106         SV *key
1107         IV level
1108         CODE:
1109         if (level) {
1110             croak("level must be zero, not %"IVdf, level);
1111         }
1112         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
1113                                           NULL, 0, 0, 0);
1114         SvREFCNT_inc(RETVAL);
1115         OUTPUT:
1116         RETVAL
1117
1118 #endif
1119
1120 =pod
1121
1122 sub TIEHASH  { bless {}, $_[0] }
1123 sub STORE    { $_[0]->{$_[1]} = $_[2] }
1124 sub FETCH    { $_[0]->{$_[1]} }
1125 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1126 sub NEXTKEY  { each %{$_[0]} }
1127 sub EXISTS   { exists $_[0]->{$_[1]} }
1128 sub DELETE   { delete $_[0]->{$_[1]} }
1129 sub CLEAR    { %{$_[0]} = () }
1130
1131 =cut
1132
1133 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
1134
1135 void
1136 make_temp_mg_lv(sv)
1137 SV* sv
1138     PREINIT:
1139         SV * const lv = newSV_type(SVt_PVLV);
1140         STRLEN len;
1141     PPCODE:
1142         SvPV(sv, len);
1143
1144         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1145         LvTYPE(lv) = 'x';
1146         LvTARG(lv) = SvREFCNT_inc_simple(sv);
1147         LvTARGOFF(lv) = len == 0 ? 0 : 1;
1148         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1149
1150         EXTEND(SP, 1);
1151         ST(0) = sv_2mortal(lv);
1152         XSRETURN(1);
1153
1154
1155 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1156
1157 void
1158 ptr_table_new(classname)
1159 const char * classname
1160     PPCODE:
1161     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1162
1163 void
1164 DESTROY(table)
1165 XS::APItest::PtrTable table
1166     CODE:
1167     ptr_table_free(table);
1168
1169 void
1170 ptr_table_store(table, from, to)
1171 XS::APItest::PtrTable table
1172 SVREF from
1173 SVREF to
1174    CODE:
1175    ptr_table_store(table, from, to);
1176
1177 UV
1178 ptr_table_fetch(table, from)
1179 XS::APItest::PtrTable table
1180 SVREF from
1181    CODE:
1182    RETVAL = PTR2UV(ptr_table_fetch(table, from));
1183    OUTPUT:
1184    RETVAL
1185
1186 void
1187 ptr_table_split(table)
1188 XS::APItest::PtrTable table
1189
1190 void
1191 ptr_table_clear(table)
1192 XS::APItest::PtrTable table
1193
1194 MODULE = XS::APItest            PACKAGE = XS::APItest
1195
1196 PROTOTYPES: DISABLE
1197
1198 BOOT:
1199 {
1200     MY_CXT_INIT;
1201
1202     MY_CXT.i  = 99;
1203     MY_CXT.sv = newSVpv("initial",0);
1204
1205     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1206     MY_CXT.bhk_record = 0;
1207
1208     BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
1209     BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
1210     BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
1211     BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
1212     Perl_blockhook_register(aTHX_ &bhk_test);
1213
1214     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1215         GV_ADDMULTI, SVt_PVAV);
1216     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1217
1218     BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
1219     BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
1220     Perl_blockhook_register(aTHX_ &bhk_csc);
1221
1222     MY_CXT.peep_recorder = newAV();
1223     MY_CXT.rpeep_recorder = newAV();
1224
1225     MY_CXT.orig_peep = PL_peepp;
1226     MY_CXT.orig_rpeep = PL_rpeepp;
1227     PL_peepp = my_peep;
1228     PL_rpeepp = my_rpeep;
1229 }
1230
1231 void
1232 CLONE(...)
1233     CODE:
1234     MY_CXT_CLONE;
1235     MY_CXT.sv = newSVpv("initial_clone",0);
1236     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1237         GV_ADDMULTI, SVt_PVAV);
1238     MY_CXT.cscav = NULL;
1239     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1240     MY_CXT.bhk_record = 0;
1241     MY_CXT.peep_recorder = newAV();
1242     MY_CXT.rpeep_recorder = newAV();
1243
1244 void
1245 print_double(val)
1246         double val
1247         CODE:
1248         printf("%5.3f\n",val);
1249
1250 int
1251 have_long_double()
1252         CODE:
1253 #ifdef HAS_LONG_DOUBLE
1254         RETVAL = 1;
1255 #else
1256         RETVAL = 0;
1257 #endif
1258         OUTPUT:
1259         RETVAL
1260
1261 void
1262 print_long_double()
1263         CODE:
1264 #ifdef HAS_LONG_DOUBLE
1265 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
1266         long double val = 7.0;
1267         printf("%5.3" PERL_PRIfldbl "\n",val);
1268 #   else
1269         double val = 7.0;
1270         printf("%5.3f\n",val);
1271 #   endif
1272 #endif
1273
1274 void
1275 print_int(val)
1276         int val
1277         CODE:
1278         printf("%d\n",val);
1279
1280 void
1281 print_long(val)
1282         long val
1283         CODE:
1284         printf("%ld\n",val);
1285
1286 void
1287 print_float(val)
1288         float val
1289         CODE:
1290         printf("%5.3f\n",val);
1291         
1292 void
1293 print_flush()
1294         CODE:
1295         fflush(stdout);
1296
1297 void
1298 mpushp()
1299         PPCODE:
1300         EXTEND(SP, 3);
1301         mPUSHp("one", 3);
1302         mPUSHp("two", 3);
1303         mPUSHp("three", 5);
1304         XSRETURN(3);
1305
1306 void
1307 mpushn()
1308         PPCODE:
1309         EXTEND(SP, 3);
1310         mPUSHn(0.5);
1311         mPUSHn(-0.25);
1312         mPUSHn(0.125);
1313         XSRETURN(3);
1314
1315 void
1316 mpushi()
1317         PPCODE:
1318         EXTEND(SP, 3);
1319         mPUSHi(-1);
1320         mPUSHi(2);
1321         mPUSHi(-3);
1322         XSRETURN(3);
1323
1324 void
1325 mpushu()
1326         PPCODE:
1327         EXTEND(SP, 3);
1328         mPUSHu(1);
1329         mPUSHu(2);
1330         mPUSHu(3);
1331         XSRETURN(3);
1332
1333 void
1334 mxpushp()
1335         PPCODE:
1336         mXPUSHp("one", 3);
1337         mXPUSHp("two", 3);
1338         mXPUSHp("three", 5);
1339         XSRETURN(3);
1340
1341 void
1342 mxpushn()
1343         PPCODE:
1344         mXPUSHn(0.5);
1345         mXPUSHn(-0.25);
1346         mXPUSHn(0.125);
1347         XSRETURN(3);
1348
1349 void
1350 mxpushi()
1351         PPCODE:
1352         mXPUSHi(-1);
1353         mXPUSHi(2);
1354         mXPUSHi(-3);
1355         XSRETURN(3);
1356
1357 void
1358 mxpushu()
1359         PPCODE:
1360         mXPUSHu(1);
1361         mXPUSHu(2);
1362         mXPUSHu(3);
1363         XSRETURN(3);
1364
1365
1366 void
1367 call_sv(sv, flags, ...)
1368     SV* sv
1369     I32 flags
1370     PREINIT:
1371         I32 i;
1372     PPCODE:
1373         for (i=0; i<items-2; i++)
1374             ST(i) = ST(i+2); /* pop first two args */
1375         PUSHMARK(SP);
1376         SP += items - 2;
1377         PUTBACK;
1378         i = call_sv(sv, flags);
1379         SPAGAIN;
1380         EXTEND(SP, 1);
1381         PUSHs(sv_2mortal(newSViv(i)));
1382
1383 void
1384 call_pv(subname, flags, ...)
1385     char* subname
1386     I32 flags
1387     PREINIT:
1388         I32 i;
1389     PPCODE:
1390         for (i=0; i<items-2; i++)
1391             ST(i) = ST(i+2); /* pop first two args */
1392         PUSHMARK(SP);
1393         SP += items - 2;
1394         PUTBACK;
1395         i = call_pv(subname, flags);
1396         SPAGAIN;
1397         EXTEND(SP, 1);
1398         PUSHs(sv_2mortal(newSViv(i)));
1399
1400 void
1401 call_method(methname, flags, ...)
1402     char* methname
1403     I32 flags
1404     PREINIT:
1405         I32 i;
1406     PPCODE:
1407         for (i=0; i<items-2; i++)
1408             ST(i) = ST(i+2); /* pop first two args */
1409         PUSHMARK(SP);
1410         SP += items - 2;
1411         PUTBACK;
1412         i = call_method(methname, flags);
1413         SPAGAIN;
1414         EXTEND(SP, 1);
1415         PUSHs(sv_2mortal(newSViv(i)));
1416
1417 void
1418 eval_sv(sv, flags)
1419     SV* sv
1420     I32 flags
1421     PREINIT:
1422         I32 i;
1423     PPCODE:
1424         PUTBACK;
1425         i = eval_sv(sv, flags);
1426         SPAGAIN;
1427         EXTEND(SP, 1);
1428         PUSHs(sv_2mortal(newSViv(i)));
1429
1430 void
1431 eval_pv(p, croak_on_error)
1432     const char* p
1433     I32 croak_on_error
1434     PPCODE:
1435         PUTBACK;
1436         EXTEND(SP, 1);
1437         PUSHs(eval_pv(p, croak_on_error));
1438
1439 void
1440 require_pv(pv)
1441     const char* pv
1442     PPCODE:
1443         PUTBACK;
1444         require_pv(pv);
1445
1446 int
1447 apitest_exception(throw_e)
1448     int throw_e
1449     OUTPUT:
1450         RETVAL
1451
1452 void
1453 mycroak(sv)
1454     SV* sv
1455     CODE:
1456     if (SvOK(sv)) {
1457         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
1458     }
1459     else {
1460         Perl_croak(aTHX_ NULL);
1461     }
1462
1463 SV*
1464 strtab()
1465    CODE:
1466    RETVAL = newRV_inc((SV*)PL_strtab);
1467    OUTPUT:
1468    RETVAL
1469
1470 int
1471 my_cxt_getint()
1472     CODE:
1473         dMY_CXT;
1474         RETVAL = my_cxt_getint_p(aMY_CXT);
1475     OUTPUT:
1476         RETVAL
1477
1478 void
1479 my_cxt_setint(i)
1480     int i;
1481     CODE:
1482         dMY_CXT;
1483         my_cxt_setint_p(aMY_CXT_ i);
1484
1485 void
1486 my_cxt_getsv(how)
1487     bool how;
1488     PPCODE:
1489         EXTEND(SP, 1);
1490         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
1491         XSRETURN(1);
1492
1493 void
1494 my_cxt_setsv(sv)
1495     SV *sv;
1496     CODE:
1497         dMY_CXT;
1498         SvREFCNT_dec(MY_CXT.sv);
1499         my_cxt_setsv_p(sv _aMY_CXT);
1500         SvREFCNT_inc(sv);
1501
1502 bool
1503 sv_setsv_cow_hashkey_core()
1504
1505 bool
1506 sv_setsv_cow_hashkey_notcore()
1507
1508 void
1509 rmagical_cast(sv, type)
1510     SV *sv;
1511     SV *type;
1512     PREINIT:
1513         struct ufuncs uf;
1514     PPCODE:
1515         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1516         sv = SvRV(sv);
1517         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1518         uf.uf_val = rmagical_a_dummy;
1519         uf.uf_set = NULL;
1520         uf.uf_index = 0;
1521         if (SvTRUE(type)) { /* b */
1522             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1523         } else { /* a */
1524             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1525         }
1526         XSRETURN_YES;
1527
1528 void
1529 rmagical_flags(sv)
1530     SV *sv;
1531     PPCODE:
1532         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1533         sv = SvRV(sv);
1534         EXTEND(SP, 3); 
1535         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1536         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1537         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1538         XSRETURN(3);
1539
1540 void
1541 my_caller(level)
1542         I32 level
1543     PREINIT:
1544         const PERL_CONTEXT *cx, *dbcx;
1545         const char *pv;
1546         const GV *gv;
1547         HV *hv;
1548     PPCODE:
1549         cx = caller_cx(level, &dbcx);
1550         EXTEND(SP, 8);
1551
1552         pv = CopSTASHPV(cx->blk_oldcop);
1553         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1554         gv = CvGV(cx->blk_sub.cv);
1555         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1556
1557         pv = CopSTASHPV(dbcx->blk_oldcop);
1558         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1559         gv = CvGV(dbcx->blk_sub.cv);
1560         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1561
1562         ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1563         ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1564         ST(6) = cop_hints_fetchsv(cx->blk_oldcop, 
1565                 sv_2mortal(newSVpvn("foo", 3)), 0);
1566
1567         hv = cop_hints_2hv(cx->blk_oldcop);
1568         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1569
1570         XSRETURN(8);
1571
1572 void
1573 DPeek (sv)
1574     SV   *sv
1575
1576   PPCODE:
1577     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1578     XSRETURN (1);
1579
1580 void
1581 BEGIN()
1582     CODE:
1583         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1584
1585 void
1586 CHECK()
1587     CODE:
1588         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1589
1590 void
1591 UNITCHECK()
1592     CODE:
1593         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1594
1595 void
1596 INIT()
1597     CODE:
1598         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1599
1600 void
1601 END()
1602     CODE:
1603         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1604
1605 void
1606 utf16_to_utf8 (sv, ...)
1607     SV* sv
1608         ALIAS:
1609             utf16_to_utf8_reversed = 1
1610     PREINIT:
1611         STRLEN len;
1612         U8 *source;
1613         SV *dest;
1614         I32 got; /* Gah, badly thought out APIs */
1615     CODE:
1616         source = (U8 *)SvPVbyte(sv, len);
1617         /* Optionally only convert part of the buffer.  */      
1618         if (items > 1) {
1619             len = SvUV(ST(1));
1620         }
1621         /* Mortalise this right now, as we'll be testing croak()s  */
1622         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1623         if (ix) {
1624             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1625         } else {
1626             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1627         }
1628         SvCUR_set(dest, got);
1629         SvPVX(dest)[got] = '\0';
1630         SvPOK_on(dest);
1631         ST(0) = dest;
1632         XSRETURN(1);
1633
1634 void
1635 my_exit(int exitcode)
1636         PPCODE:
1637         my_exit(exitcode);
1638
1639 I32
1640 sv_count()
1641         CODE:
1642             RETVAL = PL_sv_count;
1643         OUTPUT:
1644             RETVAL
1645
1646 void
1647 bhk_record(bool on)
1648     CODE:
1649         dMY_CXT;
1650         MY_CXT.bhk_record = on;
1651         if (on)
1652             av_clear(MY_CXT.bhkav);
1653
1654 void
1655 test_magic_chain()
1656     PREINIT:
1657         SV *sv;
1658         MAGIC *callmg, *uvarmg;
1659     CODE:
1660         sv = sv_2mortal(newSV(0));
1661         if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
1662         if (SvMAGICAL(sv)) croak_fail();
1663         sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
1664         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1665         if (!SvMAGICAL(sv)) croak_fail();
1666         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
1667         callmg = mg_find(sv, PERL_MAGIC_checkcall);
1668         if (!callmg) croak_fail();
1669         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1670             croak_fail();
1671         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
1672         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1673         if (!SvMAGICAL(sv)) croak_fail();
1674         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1675         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
1676         if (!uvarmg) croak_fail();
1677         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1678             croak_fail();
1679         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1680             croak_fail();
1681         mg_free_type(sv, PERL_MAGIC_vec);
1682         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1683         if (!SvMAGICAL(sv)) croak_fail();
1684         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1685         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
1686         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1687             croak_fail();
1688         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1689             croak_fail();
1690         mg_free_type(sv, PERL_MAGIC_uvar);
1691         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1692         if (!SvMAGICAL(sv)) croak_fail();
1693         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1694         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
1695         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1696             croak_fail();
1697         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
1698         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1699         if (!SvMAGICAL(sv)) croak_fail();
1700         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1701         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
1702         if (!uvarmg) croak_fail();
1703         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1704             croak_fail();
1705         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1706             croak_fail();
1707         mg_free_type(sv, PERL_MAGIC_checkcall);
1708         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1709         if (!SvMAGICAL(sv)) croak_fail();
1710         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
1711         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
1712         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1713             croak_fail();
1714         mg_free_type(sv, PERL_MAGIC_uvar);
1715         if (SvMAGICAL(sv)) croak_fail();
1716         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
1717         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
1718
1719 void
1720 test_op_contextualize()
1721     PREINIT:
1722         OP *o;
1723     CODE:
1724         o = newSVOP(OP_CONST, 0, newSViv(0));
1725         o->op_flags &= ~OPf_WANT;
1726         o = op_contextualize(o, G_SCALAR);
1727         if (o->op_type != OP_CONST ||
1728                 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
1729             croak_fail();
1730         op_free(o);
1731         o = newSVOP(OP_CONST, 0, newSViv(0));
1732         o->op_flags &= ~OPf_WANT;
1733         o = op_contextualize(o, G_ARRAY);
1734         if (o->op_type != OP_CONST ||
1735                 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
1736             croak_fail();
1737         op_free(o);
1738         o = newSVOP(OP_CONST, 0, newSViv(0));
1739         o->op_flags &= ~OPf_WANT;
1740         o = op_contextualize(o, G_VOID);
1741         if (o->op_type != OP_NULL) croak_fail();
1742         op_free(o);
1743
1744 void
1745 test_rv2cv_op_cv()
1746     PROTOTYPE:
1747     PREINIT:
1748         GV *troc_gv, *wibble_gv;
1749         CV *troc_cv;
1750         OP *o;
1751     CODE:
1752         troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
1753         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1754         wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
1755         o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
1756         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
1757         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
1758             croak_fail();
1759         o->op_private |= OPpENTERSUB_AMPER;
1760         if (rv2cv_op_cv(o, 0)) croak_fail();
1761         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1762         o->op_private &= ~OPpENTERSUB_AMPER;
1763         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1764         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1765         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1766         op_free(o);
1767         o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
1768         o->op_private = OPpCONST_BARE;
1769         o = newCVREF(0, o);
1770         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
1771         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
1772             croak_fail();
1773         o->op_private |= OPpENTERSUB_AMPER;
1774         if (rv2cv_op_cv(o, 0)) croak_fail();
1775         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1776         op_free(o);
1777         o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
1778         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
1779         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
1780             croak_fail();
1781         o->op_private |= OPpENTERSUB_AMPER;
1782         if (rv2cv_op_cv(o, 0)) croak_fail();
1783         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1784         o->op_private &= ~OPpENTERSUB_AMPER;
1785         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1786         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1787         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1788         op_free(o);
1789         o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
1790         if (rv2cv_op_cv(o, 0)) croak_fail();
1791         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1792         o->op_private |= OPpENTERSUB_AMPER;
1793         if (rv2cv_op_cv(o, 0)) croak_fail();
1794         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1795         o->op_private &= ~OPpENTERSUB_AMPER;
1796         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1797         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
1798         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1799         op_free(o);
1800         o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
1801         if (rv2cv_op_cv(o, 0)) croak_fail();
1802         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1803         op_free(o);
1804
1805 void
1806 test_cv_getset_call_checker()
1807     PREINIT:
1808         CV *troc_cv, *tsh_cv;
1809         Perl_call_checker ckfun;
1810         SV *ckobj;
1811     CODE:
1812 #define check_cc(cv, xckfun, xckobj) \
1813     do { \
1814         cv_get_call_checker((cv), &ckfun, &ckobj); \
1815         if (ckfun != (xckfun) || ckobj != (xckobj)) croak_fail(); \
1816     } while(0)
1817         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1818         tsh_cv = get_cv("XS::APItest::test_savehints", 0);
1819         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1820         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1821         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1822                                     &PL_sv_yes);
1823         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1824         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1825         cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1826         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1827         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1828         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1829                                     (SV*)tsh_cv);
1830         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1831         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1832         cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
1833                                     (SV*)troc_cv);
1834         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1835         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1836         if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
1837         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
1838 #undef check_cc
1839
1840 void
1841 cv_set_call_checker_lists(CV *cv)
1842     CODE:
1843         cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
1844
1845 void
1846 cv_set_call_checker_scalars(CV *cv)
1847     CODE:
1848         cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
1849
1850 void
1851 cv_set_call_checker_proto(CV *cv, SV *proto)
1852     CODE:
1853         if (SvROK(proto))
1854             proto = SvRV(proto);
1855         cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
1856
1857 void
1858 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
1859     CODE:
1860         if (SvROK(proto))
1861             proto = SvRV(proto);
1862         cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
1863
1864 void
1865 cv_set_call_checker_multi_sum(CV *cv)
1866     CODE:
1867         cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
1868
1869 void
1870 test_savehints()
1871     PREINIT:
1872         SV **svp, *sv;
1873     CODE:
1874 #define store_hint(KEY, VALUE) \
1875                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1876 #define hint_ok(KEY, EXPECT) \
1877                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1878                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
1879                     (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1880                     SvIV(sv) == (EXPECT))
1881 #define check_hint(KEY, EXPECT) \
1882                 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
1883         PL_hints |= HINT_LOCALIZE_HH;
1884         ENTER;
1885         SAVEHINTS();
1886         PL_hints &= HINT_INTEGER;
1887         store_hint("t0", 123);
1888         store_hint("t1", 456);
1889         if (PL_hints & HINT_INTEGER) croak_fail();
1890         check_hint("t0", 123); check_hint("t1", 456);
1891         ENTER;
1892         SAVEHINTS();
1893         if (PL_hints & HINT_INTEGER) croak_fail();
1894         check_hint("t0", 123); check_hint("t1", 456);
1895         PL_hints |= HINT_INTEGER;
1896         store_hint("t0", 321);
1897         if (!(PL_hints & HINT_INTEGER)) croak_fail();
1898         check_hint("t0", 321); check_hint("t1", 456);
1899         LEAVE;
1900         if (PL_hints & HINT_INTEGER) croak_fail();
1901         check_hint("t0", 123); check_hint("t1", 456);
1902         ENTER;
1903         SAVEHINTS();
1904         if (PL_hints & HINT_INTEGER) croak_fail();
1905         check_hint("t0", 123); check_hint("t1", 456);
1906         store_hint("t1", 654);
1907         if (PL_hints & HINT_INTEGER) croak_fail();
1908         check_hint("t0", 123); check_hint("t1", 654);
1909         LEAVE;
1910         if (PL_hints & HINT_INTEGER) croak_fail();
1911         check_hint("t0", 123); check_hint("t1", 456);
1912         LEAVE;
1913 #undef store_hint
1914 #undef hint_ok
1915 #undef check_hint
1916
1917 void
1918 test_copyhints()
1919     PREINIT:
1920         HV *a, *b;
1921     CODE:
1922         PL_hints |= HINT_LOCALIZE_HH;
1923         ENTER;
1924         SAVEHINTS();
1925         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
1926         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail();
1927         a = newHVhv(GvHV(PL_hintgv));
1928         sv_2mortal((SV*)a);
1929         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
1930         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak_fail();
1931         b = hv_copy_hints_hv(a);
1932         sv_2mortal((SV*)b);
1933         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
1934         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak_fail();
1935         LEAVE;
1936
1937 void
1938 test_op_list()
1939     PREINIT:
1940         OP *a;
1941     CODE:
1942 #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
1943 #define check_op(o, expect) \
1944     do { \
1945         if (strcmp(test_op_list_describe(o), (expect))) \
1946             croak("fail %s %s", test_op_list_describe(o), (expect)); \
1947     } while(0)
1948         a = op_append_elem(OP_LIST, NULL, NULL);
1949         check_op(a, "");
1950         a = op_append_elem(OP_LIST, iv_op(1), a);
1951         check_op(a, "const(1).");
1952         a = op_append_elem(OP_LIST, NULL, a);
1953         check_op(a, "const(1).");
1954         a = op_append_elem(OP_LIST, a, iv_op(2));
1955         check_op(a, "list[pushmark.const(1).const(2).]");
1956         a = op_append_elem(OP_LIST, a, iv_op(3));
1957         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
1958         a = op_append_elem(OP_LIST, a, NULL);
1959         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
1960         a = op_append_elem(OP_LIST, NULL, a);
1961         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
1962         a = op_append_elem(OP_LIST, iv_op(4), a);
1963         check_op(a, "list[pushmark.const(4)."
1964                 "list[pushmark.const(1).const(2).const(3).]]");
1965         a = op_append_elem(OP_LIST, a, iv_op(5));
1966         check_op(a, "list[pushmark.const(4)."
1967                 "list[pushmark.const(1).const(2).const(3).]const(5).]");
1968         a = op_append_elem(OP_LIST, a, 
1969                 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
1970         check_op(a, "list[pushmark.const(4)."
1971                 "list[pushmark.const(1).const(2).const(3).]const(5)."
1972                 "list[pushmark.const(7).const(6).]]");
1973         op_free(a);
1974         a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
1975         check_op(a, "lineseq[const(1).const(2).]");
1976         a = op_append_elem(OP_LINESEQ, a, iv_op(3));
1977         check_op(a, "lineseq[const(1).const(2).const(3).]");
1978         op_free(a);
1979         a = op_append_elem(OP_LINESEQ,
1980                 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
1981                 iv_op(3));
1982         check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
1983         op_free(a);
1984         a = op_prepend_elem(OP_LIST, NULL, NULL);
1985         check_op(a, "");
1986         a = op_prepend_elem(OP_LIST, a, iv_op(1));
1987         check_op(a, "const(1).");
1988         a = op_prepend_elem(OP_LIST, a, NULL);
1989         check_op(a, "const(1).");
1990         a = op_prepend_elem(OP_LIST, iv_op(2), a);
1991         check_op(a, "list[pushmark.const(2).const(1).]");
1992         a = op_prepend_elem(OP_LIST, iv_op(3), a);
1993         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
1994         a = op_prepend_elem(OP_LIST, NULL, a);
1995         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
1996         a = op_prepend_elem(OP_LIST, a, NULL);
1997         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
1998         a = op_prepend_elem(OP_LIST, a, iv_op(4));
1999         check_op(a, "list[pushmark."
2000                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2001         a = op_prepend_elem(OP_LIST, iv_op(5), a);
2002         check_op(a, "list[pushmark.const(5)."
2003                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2004         a = op_prepend_elem(OP_LIST,
2005                 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
2006         check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
2007                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2008         op_free(a);
2009         a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
2010         check_op(a, "lineseq[const(2).const(1).]");
2011         a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
2012         check_op(a, "lineseq[const(3).const(2).const(1).]");
2013         op_free(a);
2014         a = op_prepend_elem(OP_LINESEQ, iv_op(3),
2015                 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
2016         check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
2017         op_free(a);
2018         a = op_append_list(OP_LINESEQ, NULL, NULL);
2019         check_op(a, "");
2020         a = op_append_list(OP_LINESEQ, iv_op(1), a);
2021         check_op(a, "const(1).");
2022         a = op_append_list(OP_LINESEQ, NULL, a);
2023         check_op(a, "const(1).");
2024         a = op_append_list(OP_LINESEQ, a, iv_op(2));
2025         check_op(a, "lineseq[const(1).const(2).]");
2026         a = op_append_list(OP_LINESEQ, a, iv_op(3));
2027         check_op(a, "lineseq[const(1).const(2).const(3).]");
2028         a = op_append_list(OP_LINESEQ, iv_op(4), a);
2029         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2030         a = op_append_list(OP_LINESEQ, a, NULL);
2031         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2032         a = op_append_list(OP_LINESEQ, NULL, a);
2033         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2034         a = op_append_list(OP_LINESEQ, a,
2035                 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
2036         check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
2037                 "const(5).const(6).]");
2038         op_free(a);
2039         a = op_append_list(OP_LINESEQ,
2040                 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
2041                 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
2042         check_op(a, "lineseq[const(1).const(2)."
2043                 "list[pushmark.const(3).const(4).]]");
2044         op_free(a);
2045         a = op_append_list(OP_LINESEQ,
2046                 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
2047                 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
2048         check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
2049                 "const(3).const(4).]");
2050         op_free(a);
2051 #undef check_op
2052
2053 void
2054 test_op_linklist ()
2055     PREINIT:
2056         OP *o;
2057     CODE:
2058 #define check_ll(o, expect) \
2059     STMT_START { \
2060         if (strNE(test_op_linklist_describe(o), (expect))) \
2061             croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
2062     } STMT_END
2063         o = iv_op(1);
2064         check_ll(o, ".const1");
2065         op_free(o);
2066
2067         o = mkUNOP(OP_NOT, iv_op(1));
2068         check_ll(o, ".const1.not");
2069         op_free(o);
2070
2071         o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
2072         check_ll(o, ".const1.negate.not");
2073         op_free(o);
2074
2075         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2076         check_ll(o, ".const1.const2.add");
2077         op_free(o);
2078
2079         o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
2080         check_ll(o, ".const1.not.const2.add");
2081         op_free(o);
2082
2083         o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
2084         check_ll(o, ".const1.const2.add.not");
2085         op_free(o);
2086
2087         o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
2088         check_ll(o, ".const1.const2.const3.lineseq");
2089         op_free(o);
2090
2091         o = mkLISTOP(OP_LINESEQ,
2092                 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
2093                 mkUNOP(OP_NOT, iv_op(3)),
2094                 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
2095         check_ll(o, ".const1.const2.add.const3.not"
2096                     ".const4.const5.const6.substr.lineseq");
2097         op_free(o);
2098
2099         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2100         LINKLIST(o);
2101         o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
2102         check_ll(o, ".const1.const2.add.const3.subtract");
2103         op_free(o);
2104 #undef check_ll
2105 #undef iv_op
2106
2107 void
2108 peep_enable ()
2109     PREINIT:
2110         dMY_CXT;
2111     CODE:
2112         av_clear(MY_CXT.peep_recorder);
2113         av_clear(MY_CXT.rpeep_recorder);
2114         MY_CXT.peep_recording = 1;
2115
2116 void
2117 peep_disable ()
2118     PREINIT:
2119         dMY_CXT;
2120     CODE:
2121         MY_CXT.peep_recording = 0;
2122
2123 SV *
2124 peep_record ()
2125     PREINIT:
2126         dMY_CXT;
2127     CODE:
2128         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
2129     OUTPUT:
2130         RETVAL
2131
2132 SV *
2133 rpeep_record ()
2134     PREINIT:
2135         dMY_CXT;
2136     CODE:
2137         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
2138     OUTPUT:
2139         RETVAL
2140
2141 =pod
2142
2143 multicall_each: call a sub for each item in the list. Used to test MULTICALL
2144
2145 =cut
2146
2147 void
2148 multicall_each(block,...)
2149     SV * block
2150 PROTOTYPE: &@
2151 CODE:
2152 {
2153     dMULTICALL;
2154     int index;
2155     GV *gv;
2156     HV *stash;
2157     I32 gimme = G_SCALAR;
2158     SV **args = &PL_stack_base[ax];
2159     CV *cv;
2160
2161     if(items <= 1) {
2162         XSRETURN_UNDEF;
2163     }
2164     cv = sv_2cv(block, &stash, &gv, 0);
2165     if (cv == Nullcv) {
2166        croak("multicall_each: not a subroutine reference");
2167     }
2168     PUSH_MULTICALL(cv);
2169     SAVESPTR(GvSV(PL_defgv));
2170
2171     for(index = 1 ; index < items ; index++) {
2172         GvSV(PL_defgv) = args[index];
2173         MULTICALL;
2174     }
2175     POP_MULTICALL;
2176     XSRETURN_UNDEF;
2177 }
2178
2179
2180 BOOT:
2181         {
2182         HV* stash;
2183         SV** meth = NULL;
2184         CV* cv;
2185         stash = gv_stashpv("XS::APItest::TempLv", 0);
2186         if (stash)
2187             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
2188         if (!meth)
2189             croak("lost method 'make_temp_mg_lv'");
2190         cv = GvCV(*meth);
2191         CvLVALUE_on(cv);
2192         }
2193
2194 BOOT:
2195 {
2196     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
2197     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
2198     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
2199     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
2200     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
2201     hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
2202     hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
2203     hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
2204     next_keyword_plugin = PL_keyword_plugin;
2205     PL_keyword_plugin = my_keyword_plugin;
2206 }