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