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