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