This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow space for NUL is UTF-8 array decls
[perl5.git] / ext / XS-APItest / APItest.xs
1 #define PERL_IN_XS_APITEST
2
3 /* We want to be able to test things that aren't API yet. */
4 #define PERL_EXT
5
6 /* Do *not* define PERL_NO_GET_CONTEXT.  This is the one place where we get
7    to test implicit Perl_get_context().  */
8
9 #include "EXTERN.h"
10 #include "perl.h"
11 #include "XSUB.h"
12
13 typedef FILE NativeFile;
14
15 #include "fakesdio.h"   /* Causes us to use PerlIO below */
16
17 typedef SV *SVREF;
18 typedef PTR_TBL_t *XS__APItest__PtrTable;
19 typedef PerlIO * InputStream;
20 typedef PerlIO * OutputStream;
21
22 #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
23 #define croak_fail_nep(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)
24 #define croak_fail_nei(h, w) croak("fail %d!=%d at " __FILE__ " line %d", (int)(h), (int)(w), __LINE__)
25
26 #ifdef EBCDIC
27
28 void
29 cat_utf8a2n(SV* sv, const char * const ascii_utf8, STRLEN len)
30 {
31     /* Converts variant UTF-8 text pointed to by 'ascii_utf8' of length 'len',
32      * to UTF-EBCDIC, appending that text to the text already in 'sv'.
33      * Currently doesn't work on invariants, as that is unneeded here, and we
34      * could get double translations if we did.
35      *
36      * It has the algorithm for strict UTF-8 hard-coded in to find the code
37      * point it represents, then calls uvchr_to_utf8() to convert to
38      * UTF-EBCDIC).
39      *
40      * Note that this uses code points, not characters.  Thus if the input is
41      * the UTF-8 for the code point 0xFF, the output will be the UTF-EBCDIC for
42      * 0xFF, even though that code point represents different characters on
43      * ASCII vs EBCDIC platforms. */
44
45     dTHX;
46     char * p = (char *) ascii_utf8;
47     const char * const e = p + len;
48
49     while (p < e) {
50         UV code_point;
51         U8 native_utf8[UTF8_MAXBYTES + 1];
52         U8 * char_end;
53         U8 start = (U8) *p;
54
55         /* Start bytes are the same in both UTF-8 and I8, therefore we can
56          * treat this ASCII UTF-8 byte as an I8 byte.  But PL_utf8skip[] is
57          * indexed by NATIVE_UTF8 bytes, so transform to that */
58         STRLEN char_bytes_len = PL_utf8skip[I8_TO_NATIVE_UTF8(start)];
59
60         if (start < 0xc2) {
61             croak("fail: Expecting start byte, instead got 0x%X at %s line %d",
62                                                   (U8) *p, __FILE__, __LINE__);
63         }
64         code_point = (start & (((char_bytes_len) >= 7)
65                                 ? 0x00
66                                 : (0x1F >> ((char_bytes_len)-2))));
67         p++;
68         while (p < e && ((( (U8) *p) & 0xC0) == 0x80)) {
69
70             code_point = (code_point << 6) | (( (U8) *p) & 0x3F);
71             p++;
72         }
73
74         char_end = uvchr_to_utf8(native_utf8, code_point);
75         sv_catpvn(sv, (char *) native_utf8, char_end - native_utf8);
76     }
77 }
78
79 #endif
80
81 /* for my_cxt tests */
82
83 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
84
85 typedef struct {
86     int i;
87     SV *sv;
88     GV *cscgv;
89     AV *cscav;
90     AV *bhkav;
91     bool bhk_record;
92     peep_t orig_peep;
93     peep_t orig_rpeep;
94     int peep_recording;
95     AV *peep_recorder;
96     AV *rpeep_recorder;
97     AV *xop_record;
98 } my_cxt_t;
99
100 START_MY_CXT
101
102 int
103 S_myset_set(pTHX_ SV* sv, MAGIC* mg)
104 {
105     SV *isv = (SV*)mg->mg_ptr;
106
107     PERL_UNUSED_ARG(sv);
108     SvIVX(isv)++;
109     return 0;
110 }
111
112 MGVTBL vtbl_foo, vtbl_bar;
113 MGVTBL vtbl_myset = { 0, S_myset_set, 0, 0, 0, 0, 0, 0 };
114
115
116 /* indirect functions to test the [pa]MY_CXT macros */
117
118 int
119 my_cxt_getint_p(pMY_CXT)
120 {
121     return MY_CXT.i;
122 }
123
124 void
125 my_cxt_setint_p(pMY_CXT_ int i)
126 {
127     MY_CXT.i = i;
128 }
129
130 SV*
131 my_cxt_getsv_interp_context(void)
132 {
133     dTHX;
134     dMY_CXT_INTERP(my_perl);
135     return MY_CXT.sv;
136 }
137
138 SV*
139 my_cxt_getsv_interp(void)
140 {
141     dMY_CXT;
142     return MY_CXT.sv;
143 }
144
145 void
146 my_cxt_setsv_p(SV* sv _pMY_CXT)
147 {
148     MY_CXT.sv = sv;
149 }
150
151
152 /* from exception.c */
153 int apitest_exception(int);
154
155 /* from core_or_not.inc */
156 bool sv_setsv_cow_hashkey_core(void);
157 bool sv_setsv_cow_hashkey_notcore(void);
158
159 /* A routine to test hv_delayfree_ent
160    (which itself is tested by testing on hv_free_ent  */
161
162 typedef void (freeent_function)(pTHX_ HV *, HE *);
163
164 void
165 test_freeent(freeent_function *f) {
166     dSP;
167     HV *test_hash = newHV();
168     HE *victim;
169     SV *test_scalar;
170     U32 results[4];
171     int i;
172
173 #ifdef PURIFY
174     victim = (HE*)safemalloc(sizeof(HE));
175 #else
176     /* Storing then deleting something should ensure that a hash entry is
177        available.  */
178     (void) hv_stores(test_hash, "", &PL_sv_yes);
179     (void) hv_deletes(test_hash, "", 0);
180
181     /* We need to "inline" new_he here as it's static, and the functions we
182        test expect to be able to call del_HE on the HE  */
183     if (!PL_body_roots[HE_SVSLOT])
184         croak("PL_he_root is 0");
185     victim = (HE*) PL_body_roots[HE_SVSLOT];
186     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
187 #endif
188
189     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
190
191     test_scalar = newSV(0);
192     SvREFCNT_inc(test_scalar);
193     HeVAL(victim) = test_scalar;
194
195     /* Need this little game else we free the temps on the return stack.  */
196     results[0] = SvREFCNT(test_scalar);
197     SAVETMPS;
198     results[1] = SvREFCNT(test_scalar);
199     f(aTHX_ test_hash, victim);
200     results[2] = SvREFCNT(test_scalar);
201     FREETMPS;
202     results[3] = SvREFCNT(test_scalar);
203
204     i = 0;
205     do {
206         mXPUSHu(results[i]);
207     } while (++i < (int)(sizeof(results)/sizeof(results[0])));
208
209     /* Goodbye to our extra reference.  */
210     SvREFCNT_dec(test_scalar);
211 }
212
213 /* Not that it matters much, but it's handy for the flipped character to just
214  * be the opposite case (at least for ASCII-range and most Latin1 as well). */
215 #define FLIP_BIT ('A' ^ 'a')
216
217 static I32
218 bitflip_key(pTHX_ IV action, SV *field) {
219     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
220     SV *keysv;
221     PERL_UNUSED_ARG(action);
222     if (mg && (keysv = mg->mg_obj)) {
223         STRLEN len;
224         const char *p = SvPV(keysv, len);
225
226         if (len) {
227             /* Allow for the flipped val to be longer than the original.  This
228              * is just for testing, so can afford to have some slop */
229             const STRLEN newlen = len * 2;
230
231             SV *newkey = newSV(newlen);
232             const char * const new_p_orig = SvPVX(newkey);
233             char *new_p = (char *) new_p_orig;
234
235             if (SvUTF8(keysv)) {
236                 const char *const end = p + len;
237                 while (p < end) {
238                     STRLEN curlen;
239                     UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &curlen);
240
241                     /* Make sure don't exceed bounds */
242                     assert(new_p - new_p_orig + curlen < newlen);
243
244                     new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ FLIP_BIT);
245                     p += curlen;
246                 }
247                 SvUTF8_on(newkey);
248             } else {
249                 while (len--)
250                     *new_p++ = *p++ ^ FLIP_BIT;
251             }
252             *new_p = '\0';
253             SvCUR_set(newkey, new_p - new_p_orig);
254             SvPOK_on(newkey);
255
256             mg->mg_obj = newkey;
257         }
258     }
259     return 0;
260 }
261
262 static I32
263 rot13_key(pTHX_ IV action, SV *field) {
264     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
265     SV *keysv;
266     PERL_UNUSED_ARG(action);
267     if (mg && (keysv = mg->mg_obj)) {
268         STRLEN len;
269         const char *p = SvPV(keysv, len);
270
271         if (len) {
272             SV *newkey = newSV(len);
273             char *new_p = SvPVX(newkey);
274
275             /* There's a deliberate fencepost error here to loop len + 1 times
276                to copy the trailing \0  */
277             do {
278                 char new_c = *p++;
279                 /* Try doing this cleanly and clearly in EBCDIC another way: */
280                 switch (new_c) {
281                 case 'A': new_c = 'N'; break;
282                 case 'B': new_c = 'O'; break;
283                 case 'C': new_c = 'P'; break;
284                 case 'D': new_c = 'Q'; break;
285                 case 'E': new_c = 'R'; break;
286                 case 'F': new_c = 'S'; break;
287                 case 'G': new_c = 'T'; break;
288                 case 'H': new_c = 'U'; break;
289                 case 'I': new_c = 'V'; break;
290                 case 'J': new_c = 'W'; break;
291                 case 'K': new_c = 'X'; break;
292                 case 'L': new_c = 'Y'; break;
293                 case 'M': new_c = 'Z'; break;
294                 case 'N': new_c = 'A'; break;
295                 case 'O': new_c = 'B'; break;
296                 case 'P': new_c = 'C'; break;
297                 case 'Q': new_c = 'D'; break;
298                 case 'R': new_c = 'E'; break;
299                 case 'S': new_c = 'F'; break;
300                 case 'T': new_c = 'G'; break;
301                 case 'U': new_c = 'H'; break;
302                 case 'V': new_c = 'I'; break;
303                 case 'W': new_c = 'J'; break;
304                 case 'X': new_c = 'K'; break;
305                 case 'Y': new_c = 'L'; break;
306                 case 'Z': new_c = 'M'; break;
307                 case 'a': new_c = 'n'; break;
308                 case 'b': new_c = 'o'; break;
309                 case 'c': new_c = 'p'; break;
310                 case 'd': new_c = 'q'; break;
311                 case 'e': new_c = 'r'; break;
312                 case 'f': new_c = 's'; break;
313                 case 'g': new_c = 't'; break;
314                 case 'h': new_c = 'u'; break;
315                 case 'i': new_c = 'v'; break;
316                 case 'j': new_c = 'w'; break;
317                 case 'k': new_c = 'x'; break;
318                 case 'l': new_c = 'y'; break;
319                 case 'm': new_c = 'z'; break;
320                 case 'n': new_c = 'a'; break;
321                 case 'o': new_c = 'b'; break;
322                 case 'p': new_c = 'c'; break;
323                 case 'q': new_c = 'd'; break;
324                 case 'r': new_c = 'e'; break;
325                 case 's': new_c = 'f'; break;
326                 case 't': new_c = 'g'; break;
327                 case 'u': new_c = 'h'; break;
328                 case 'v': new_c = 'i'; break;
329                 case 'w': new_c = 'j'; break;
330                 case 'x': new_c = 'k'; break;
331                 case 'y': new_c = 'l'; break;
332                 case 'z': new_c = 'm'; break;
333                 }
334                 *new_p++ = new_c;
335             } while (len--);
336             SvCUR_set(newkey, SvCUR(keysv));
337             SvPOK_on(newkey);
338             if (SvUTF8(keysv))
339                 SvUTF8_on(newkey);
340
341             mg->mg_obj = newkey;
342         }
343     }
344     return 0;
345 }
346
347 STATIC I32
348 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
349     PERL_UNUSED_ARG(idx);
350     PERL_UNUSED_ARG(sv);
351     return 0;
352 }
353
354 /* We could do "= { 0 };" but some versions of gcc do warn
355  * (with -Wextra) about missing initializer, this is probably gcc
356  * being a bit too paranoid.  But since this is file-static, we can
357  * just have it without initializer, since it should get
358  * zero-initialized. */
359 STATIC MGVTBL rmagical_b;
360
361 STATIC void
362 blockhook_csc_start(pTHX_ int full)
363 {
364     dMY_CXT;
365     AV *const cur = GvAV(MY_CXT.cscgv);
366
367     PERL_UNUSED_ARG(full);
368     SAVEGENERICSV(GvAV(MY_CXT.cscgv));
369
370     if (cur) {
371         I32 i;
372         AV *const new_av = newAV();
373
374         for (i = 0; i <= av_tindex(cur); i++) {
375             av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
376         }
377
378         GvAV(MY_CXT.cscgv) = new_av;
379     }
380 }
381
382 STATIC void
383 blockhook_csc_pre_end(pTHX_ OP **o)
384 {
385     dMY_CXT;
386
387     PERL_UNUSED_ARG(o);
388     /* if we hit the end of a scope we missed the start of, we need to
389      * unconditionally clear @CSC */
390     if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
391         av_clear(MY_CXT.cscav);
392     }
393
394 }
395
396 STATIC void
397 blockhook_test_start(pTHX_ int full)
398 {
399     dMY_CXT;
400     AV *av;
401     
402     if (MY_CXT.bhk_record) {
403         av = newAV();
404         av_push(av, newSVpvs("start"));
405         av_push(av, newSViv(full));
406         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
407     }
408 }
409
410 STATIC void
411 blockhook_test_pre_end(pTHX_ OP **o)
412 {
413     dMY_CXT;
414
415     PERL_UNUSED_ARG(o);
416     if (MY_CXT.bhk_record)
417         av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
418 }
419
420 STATIC void
421 blockhook_test_post_end(pTHX_ OP **o)
422 {
423     dMY_CXT;
424
425     PERL_UNUSED_ARG(o);
426     if (MY_CXT.bhk_record)
427         av_push(MY_CXT.bhkav, newSVpvs("post_end"));
428 }
429
430 STATIC void
431 blockhook_test_eval(pTHX_ OP *const o)
432 {
433     dMY_CXT;
434     AV *av;
435
436     if (MY_CXT.bhk_record) {
437         av = newAV();
438         av_push(av, newSVpvs("eval"));
439         av_push(av, newSVpv(OP_NAME(o), 0));
440         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
441     }
442 }
443
444 STATIC BHK bhk_csc, bhk_test;
445
446 STATIC void
447 my_peep (pTHX_ OP *o)
448 {
449     dMY_CXT;
450
451     if (!o)
452         return;
453
454     MY_CXT.orig_peep(aTHX_ o);
455
456     if (!MY_CXT.peep_recording)
457         return;
458
459     for (; o; o = o->op_next) {
460         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
461             av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
462         }
463     }
464 }
465
466 STATIC void
467 my_rpeep (pTHX_ OP *o)
468 {
469     dMY_CXT;
470
471     if (!o)
472         return;
473
474     MY_CXT.orig_rpeep(aTHX_ o);
475
476     if (!MY_CXT.peep_recording)
477         return;
478
479     for (; o; o = o->op_next) {
480         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
481             av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
482         }
483     }
484 }
485
486 STATIC OP *
487 THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
488 {
489     PERL_UNUSED_ARG(namegv);
490     PERL_UNUSED_ARG(ckobj);
491     return ck_entersub_args_list(entersubop);
492 }
493
494 STATIC OP *
495 THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
496 {
497     OP *aop = cUNOPx(entersubop)->op_first;
498     PERL_UNUSED_ARG(namegv);
499     PERL_UNUSED_ARG(ckobj);
500     if (!OpHAS_SIBLING(aop))
501         aop = cUNOPx(aop)->op_first;
502     for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
503         op_contextualize(aop, G_SCALAR);
504     }
505     return entersubop;
506 }
507
508 STATIC OP *
509 THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
510 {
511     OP *sumop = NULL;
512     OP *parent = entersubop;
513     OP *pushop = cUNOPx(entersubop)->op_first;
514     PERL_UNUSED_ARG(namegv);
515     PERL_UNUSED_ARG(ckobj);
516     if (!OpHAS_SIBLING(pushop)) {
517         parent = pushop;
518         pushop = cUNOPx(pushop)->op_first;
519     }
520     while (1) {
521         OP *aop = OpSIBLING(pushop);
522         if (!OpHAS_SIBLING(aop))
523             break;
524         /* cut out first arg */
525         op_sibling_splice(parent, pushop, 1, NULL);
526         op_contextualize(aop, G_SCALAR);
527         if (sumop) {
528             sumop = newBINOP(OP_ADD, 0, sumop, aop);
529         } else {
530             sumop = aop;
531         }
532     }
533     if (!sumop)
534         sumop = newSVOP(OP_CONST, 0, newSViv(0));
535     op_free(entersubop);
536     return sumop;
537 }
538
539 STATIC void test_op_list_describe_part(SV *res, OP *o);
540 STATIC void
541 test_op_list_describe_part(SV *res, OP *o)
542 {
543     sv_catpv(res, PL_op_name[o->op_type]);
544     switch (o->op_type) {
545         case OP_CONST: {
546             sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
547         } break;
548     }
549     if (o->op_flags & OPf_KIDS) {
550         OP *k;
551         sv_catpvs(res, "[");
552         for (k = cUNOPx(o)->op_first; k; k = OpSIBLING(k))
553             test_op_list_describe_part(res, k);
554         sv_catpvs(res, "]");
555     } else {
556         sv_catpvs(res, ".");
557     }
558 }
559
560 STATIC char *
561 test_op_list_describe(OP *o)
562 {
563     SV *res = sv_2mortal(newSVpvs(""));
564     if (o)
565         test_op_list_describe_part(res, o);
566     return SvPVX(res);
567 }
568
569 /* the real new*OP functions have a tendency to call fold_constants, and
570  * other such unhelpful things, so we need our own versions for testing */
571
572 #define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
573 static OP *
574 THX_mkUNOP(pTHX_ U32 type, OP *first)
575 {
576     UNOP *unop;
577     NewOp(1103, unop, 1, UNOP);
578     unop->op_type   = (OPCODE)type;
579     op_sibling_splice((OP*)unop, NULL, 0, first);
580     return (OP *)unop;
581 }
582
583 #define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
584 static OP *
585 THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
586 {
587     BINOP *binop;
588     NewOp(1103, binop, 1, BINOP);
589     binop->op_type      = (OPCODE)type;
590     op_sibling_splice((OP*)binop, NULL, 0, last);
591     op_sibling_splice((OP*)binop, NULL, 0, first);
592     return (OP *)binop;
593 }
594
595 #define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
596 static OP *
597 THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
598 {
599     LISTOP *listop;
600     NewOp(1103, listop, 1, LISTOP);
601     listop->op_type     = (OPCODE)type;
602     op_sibling_splice((OP*)listop, NULL, 0, last);
603     op_sibling_splice((OP*)listop, NULL, 0, sib);
604     op_sibling_splice((OP*)listop, NULL, 0, first);
605     return (OP *)listop;
606 }
607
608 static char *
609 test_op_linklist_describe(OP *start)
610 {
611     SV *rv = sv_2mortal(newSVpvs(""));
612     OP *o;
613     o = start = LINKLIST(start);
614     do {
615         sv_catpvs(rv, ".");
616         sv_catpv(rv, OP_NAME(o));
617         if (o->op_type == OP_CONST)
618             sv_catsv(rv, cSVOPo->op_sv);
619         o = o->op_next;
620     } while (o && o != start);
621     return SvPVX(rv);
622 }
623
624 /** establish_cleanup operator, ripped off from Scope::Cleanup **/
625
626 STATIC void
627 THX_run_cleanup(pTHX_ void *cleanup_code_ref)
628 {
629     dSP;
630     PUSHSTACK;
631     ENTER;
632     SAVETMPS;
633     PUSHMARK(SP);
634     call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
635     FREETMPS;
636     LEAVE;
637     POPSTACK;
638 }
639
640 STATIC OP *
641 THX_pp_establish_cleanup(pTHX)
642 {
643     dSP;
644     SV *cleanup_code_ref;
645     cleanup_code_ref = newSVsv(POPs);
646     SAVEFREESV(cleanup_code_ref);
647     SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref);
648     if(GIMME_V != G_VOID) PUSHs(&PL_sv_undef);
649     RETURN;
650 }
651
652 STATIC OP *
653 THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
654 {
655     OP *parent, *pushop, *argop, *estop;
656     ck_entersub_args_proto(entersubop, namegv, ckobj);
657     parent = entersubop;
658     pushop = cUNOPx(entersubop)->op_first;
659     if(!OpHAS_SIBLING(pushop)) {
660         parent = pushop;
661         pushop = cUNOPx(pushop)->op_first;
662     }
663     /* extract out first arg, then delete the rest of the tree */
664     argop = OpSIBLING(pushop);
665     op_sibling_splice(parent, pushop, 1, NULL);
666     op_free(entersubop);
667
668     estop = mkUNOP(OP_RAND, argop);
669     estop->op_ppaddr = THX_pp_establish_cleanup;
670     PL_hints |= HINT_BLOCK_SCOPE;
671     return estop;
672 }
673
674 STATIC OP *
675 THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
676 {
677     OP *parent, *pushop, *argop;
678     ck_entersub_args_proto(entersubop, namegv, ckobj);
679     parent = entersubop;
680     pushop = cUNOPx(entersubop)->op_first;
681     if(!OpHAS_SIBLING(pushop)) {
682         parent = pushop;
683         pushop = cUNOPx(pushop)->op_first;
684     }
685     argop = OpSIBLING(pushop);
686     op_sibling_splice(parent, pushop, 1, NULL);
687     op_free(entersubop);
688     return newUNOP(OP_POSTINC, 0,
689         op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
690 }
691
692 STATIC OP *
693 THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
694 {
695     OP *pushop, *argop;
696     PADOFFSET padoff = NOT_IN_PAD;
697     SV *a0, *a1;
698     ck_entersub_args_proto(entersubop, namegv, ckobj);
699     pushop = cUNOPx(entersubop)->op_first;
700     if(!OpHAS_SIBLING(pushop))
701         pushop = cUNOPx(pushop)->op_first;
702     argop = OpSIBLING(pushop);
703     if(argop->op_type != OP_CONST || OpSIBLING(argop)->op_type != OP_CONST)
704         croak("bad argument expression type for pad_scalar()");
705     a0 = cSVOPx_sv(argop);
706     a1 = cSVOPx_sv(OpSIBLING(argop));
707     switch(SvIV(a0)) {
708         case 1: {
709             SV *namesv = sv_2mortal(newSVpvs("$"));
710             sv_catsv(namesv, a1);
711             padoff = pad_findmy_sv(namesv, 0);
712         } break;
713         case 2: {
714             char *namepv;
715             STRLEN namelen;
716             SV *namesv = sv_2mortal(newSVpvs("$"));
717             sv_catsv(namesv, a1);
718             namepv = SvPV(namesv, namelen);
719             padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv));
720         } break;
721         case 3: {
722             char *namepv;
723             SV *namesv = sv_2mortal(newSVpvs("$"));
724             sv_catsv(namesv, a1);
725             namepv = SvPV_nolen(namesv);
726             padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
727         } break;
728         case 4: {
729             padoff = pad_findmy_pvs("$foo", 0);
730         } break;
731         default: croak("bad type value for pad_scalar()");
732     }
733     op_free(entersubop);
734     if(padoff == NOT_IN_PAD) {
735         return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
736     } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
737         return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
738     } else {
739         OP *padop = newOP(OP_PADSV, 0);
740         padop->op_targ = padoff;
741         return padop;
742     }
743 }
744
745 /** RPN keyword parser **/
746
747 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
748 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
749 #define sv_is_string(sv) \
750     (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
751      (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
752
753 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
754 static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
755 static SV *hintkey_scopelessblock_sv;
756 static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
757 static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
758 static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv;
759 static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
760 static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
761 static SV *hintkey_arrayexprflags_sv;
762 static SV *hintkey_DEFSV_sv;
763 static SV *hintkey_with_vars_sv;
764 static SV *hintkey_join_with_space_sv;
765 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
766
767 /* low-level parser helpers */
768
769 #define PL_bufptr (PL_parser->bufptr)
770 #define PL_bufend (PL_parser->bufend)
771
772 /* RPN parser */
773
774 #define parse_var() THX_parse_var(aTHX)
775 static OP *THX_parse_var(pTHX)
776 {
777     char *s = PL_bufptr;
778     char *start = s;
779     PADOFFSET varpos;
780     OP *padop;
781     if(*s != '$') croak("RPN syntax error");
782     while(1) {
783         char c = *++s;
784         if(!isALNUM(c)) break;
785     }
786     if(s-start < 2) croak("RPN syntax error");
787     lex_read_to(s);
788     varpos = pad_findmy_pvn(start, s-start, 0);
789     if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
790         croak("RPN only supports \"my\" variables");
791     padop = newOP(OP_PADSV, 0);
792     padop->op_targ = varpos;
793     return padop;
794 }
795
796 #define push_rpn_item(o) \
797     op_sibling_splice(parent, NULL, 0, o);
798 #define pop_rpn_item() ( \
799     (tmpop = op_sibling_splice(parent, NULL, 1, NULL)) \
800         ? tmpop : (croak("RPN stack underflow"), (OP*)NULL))
801
802 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
803 static OP *THX_parse_rpn_expr(pTHX)
804 {
805     OP *tmpop;
806     /* fake parent for splice to mess with */
807     OP *parent = mkBINOP(OP_NULL, NULL, NULL);
808
809     while(1) {
810         I32 c;
811         lex_read_space(0);
812         c = lex_peek_unichar(0);
813         switch(c) {
814             case /*(*/')': case /*{*/'}': {
815                 OP *result = pop_rpn_item();
816                 if(cLISTOPx(parent)->op_first)
817                     croak("RPN expression must return a single value");
818                 op_free(parent);
819                 return result;
820             } break;
821             case '0': case '1': case '2': case '3': case '4':
822             case '5': case '6': case '7': case '8': case '9': {
823                 UV val = 0;
824                 do {
825                     lex_read_unichar(0);
826                     val = 10*val + (c - '0');
827                     c = lex_peek_unichar(0);
828                 } while(c >= '0' && c <= '9');
829                 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
830             } break;
831             case '$': {
832                 push_rpn_item(parse_var());
833             } break;
834             case '+': {
835                 OP *b = pop_rpn_item();
836                 OP *a = pop_rpn_item();
837                 lex_read_unichar(0);
838                 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
839             } break;
840             case '-': {
841                 OP *b = pop_rpn_item();
842                 OP *a = pop_rpn_item();
843                 lex_read_unichar(0);
844                 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
845             } break;
846             case '*': {
847                 OP *b = pop_rpn_item();
848                 OP *a = pop_rpn_item();
849                 lex_read_unichar(0);
850                 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
851             } break;
852             case '/': {
853                 OP *b = pop_rpn_item();
854                 OP *a = pop_rpn_item();
855                 lex_read_unichar(0);
856                 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
857             } break;
858             case '%': {
859                 OP *b = pop_rpn_item();
860                 OP *a = pop_rpn_item();
861                 lex_read_unichar(0);
862                 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
863             } break;
864             default: {
865                 croak("RPN syntax error");
866             } break;
867         }
868     }
869 }
870
871 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
872 static OP *THX_parse_keyword_rpn(pTHX)
873 {
874     OP *op;
875     lex_read_space(0);
876     if(lex_peek_unichar(0) != '('/*)*/)
877         croak("RPN expression must be parenthesised");
878     lex_read_unichar(0);
879     op = parse_rpn_expr();
880     if(lex_peek_unichar(0) != /*(*/')')
881         croak("RPN expression must be parenthesised");
882     lex_read_unichar(0);
883     return op;
884 }
885
886 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
887 static OP *THX_parse_keyword_calcrpn(pTHX)
888 {
889     OP *varop, *exprop;
890     lex_read_space(0);
891     varop = parse_var();
892     lex_read_space(0);
893     if(lex_peek_unichar(0) != '{'/*}*/)
894         croak("RPN expression must be braced");
895     lex_read_unichar(0);
896     exprop = parse_rpn_expr();
897     if(lex_peek_unichar(0) != /*{*/'}')
898         croak("RPN expression must be braced");
899     lex_read_unichar(0);
900     return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
901 }
902
903 #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
904 static OP *THX_parse_keyword_stufftest(pTHX)
905 {
906     I32 c;
907     bool do_stuff;
908     lex_read_space(0);
909     do_stuff = lex_peek_unichar(0) == '+';
910     if(do_stuff) {
911         lex_read_unichar(0);
912         lex_read_space(0);
913     }
914     c = lex_peek_unichar(0);
915     if(c == ';') {
916         lex_read_unichar(0);
917     } else if(c != /*{*/'}') {
918         croak("syntax error");
919     }
920     if(do_stuff) lex_stuff_pvs(" ", 0);
921     return newOP(OP_NULL, 0);
922 }
923
924 #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
925 static OP *THX_parse_keyword_swaptwostmts(pTHX)
926 {
927     OP *a, *b;
928     a = parse_fullstmt(0);
929     b = parse_fullstmt(0);
930     if(a && b)
931         PL_hints |= HINT_BLOCK_SCOPE;
932     return op_append_list(OP_LINESEQ, b, a);
933 }
934
935 #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
936 static OP *THX_parse_keyword_looprest(pTHX)
937 {
938     return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
939                         parse_stmtseq(0), NULL, 1);
940 }
941
942 #define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
943 static OP *THX_parse_keyword_scopelessblock(pTHX)
944 {
945     I32 c;
946     OP *body;
947     lex_read_space(0);
948     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
949     lex_read_unichar(0);
950     body = parse_stmtseq(0);
951     c = lex_peek_unichar(0);
952     if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error");
953     lex_read_unichar(0);
954     return body;
955 }
956
957 #define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
958 static OP *THX_parse_keyword_stmtasexpr(pTHX)
959 {
960     OP *o = parse_barestmt(0);
961     if (!o) o = newOP(OP_STUB, 0);
962     if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
963     return op_scope(o);
964 }
965
966 #define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
967 static OP *THX_parse_keyword_stmtsasexpr(pTHX)
968 {
969     OP *o;
970     lex_read_space(0);
971     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
972     lex_read_unichar(0);
973     o = parse_stmtseq(0);
974     lex_read_space(0);
975     if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
976     lex_read_unichar(0);
977     if (!o) o = newOP(OP_STUB, 0);
978     if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
979     return op_scope(o);
980 }
981
982 #define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX)
983 static OP *THX_parse_keyword_loopblock(pTHX)
984 {
985     return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
986                         parse_block(0), NULL, 1);
987 }
988
989 #define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX)
990 static OP *THX_parse_keyword_blockasexpr(pTHX)
991 {
992     OP *o = parse_block(0);
993     if (!o) o = newOP(OP_STUB, 0);
994     if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
995     return op_scope(o);
996 }
997
998 #define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX)
999 static OP *THX_parse_keyword_swaplabel(pTHX)
1000 {
1001     OP *sop = parse_barestmt(0);
1002     SV *label = parse_label(PARSE_OPTIONAL);
1003     if (label) sv_2mortal(label);
1004     return newSTATEOP(label ? SvUTF8(label) : 0,
1005                       label ? savepv(SvPVX(label)) : NULL,
1006                       sop);
1007 }
1008
1009 #define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
1010 static OP *THX_parse_keyword_labelconst(pTHX)
1011 {
1012     return newSVOP(OP_CONST, 0, parse_label(0));
1013 }
1014
1015 #define parse_keyword_arrayfullexpr() THX_parse_keyword_arrayfullexpr(aTHX)
1016 static OP *THX_parse_keyword_arrayfullexpr(pTHX)
1017 {
1018     return newANONLIST(parse_fullexpr(0));
1019 }
1020
1021 #define parse_keyword_arraylistexpr() THX_parse_keyword_arraylistexpr(aTHX)
1022 static OP *THX_parse_keyword_arraylistexpr(pTHX)
1023 {
1024     return newANONLIST(parse_listexpr(0));
1025 }
1026
1027 #define parse_keyword_arraytermexpr() THX_parse_keyword_arraytermexpr(aTHX)
1028 static OP *THX_parse_keyword_arraytermexpr(pTHX)
1029 {
1030     return newANONLIST(parse_termexpr(0));
1031 }
1032
1033 #define parse_keyword_arrayarithexpr() THX_parse_keyword_arrayarithexpr(aTHX)
1034 static OP *THX_parse_keyword_arrayarithexpr(pTHX)
1035 {
1036     return newANONLIST(parse_arithexpr(0));
1037 }
1038
1039 #define parse_keyword_arrayexprflags() THX_parse_keyword_arrayexprflags(aTHX)
1040 static OP *THX_parse_keyword_arrayexprflags(pTHX)
1041 {
1042     U32 flags = 0;
1043     I32 c;
1044     OP *o;
1045     lex_read_space(0);
1046     c = lex_peek_unichar(0);
1047     if (c != '!' && c != '?') croak("syntax error");
1048     lex_read_unichar(0);
1049     if (c == '?') flags |= PARSE_OPTIONAL;
1050     o = parse_listexpr(flags);
1051     return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
1052 }
1053
1054 #define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX)
1055 static OP *THX_parse_keyword_DEFSV(pTHX)
1056 {
1057     return newDEFSVOP();
1058 }
1059
1060 #define sv_cat_c(a,b) THX_sv_cat_c(aTHX_ a, b)
1061 static void THX_sv_cat_c(pTHX_ SV *sv, U32 c) {
1062     char ds[UTF8_MAXBYTES + 1], *d;
1063     d = (char *)uvchr_to_utf8((U8 *)ds, c);
1064     if (d - ds > 1) {
1065         sv_utf8_upgrade(sv);
1066     }
1067     sv_catpvn(sv, ds, d - ds);
1068 }
1069
1070 #define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX)
1071 static OP *THX_parse_keyword_with_vars(pTHX)
1072 {
1073     I32 c;
1074     IV count;
1075     int save_ix;
1076     OP *vardeclseq, *body;
1077
1078     save_ix = block_start(TRUE);
1079     vardeclseq = NULL;
1080
1081     count = 0;
1082
1083     lex_read_space(0);
1084     c = lex_peek_unichar(0);
1085     while (c != '{') {
1086         SV *varname;
1087         PADOFFSET padoff;
1088
1089         if (c == -1) {
1090             croak("unexpected EOF; expecting '{'");
1091         }
1092
1093         if (!isIDFIRST_uni(c)) {
1094             croak("unexpected '%c'; expecting an identifier", (int)c);
1095         }
1096
1097         varname = newSVpvs("$");
1098         if (lex_bufutf8()) {
1099             SvUTF8_on(varname);
1100         }
1101
1102         sv_cat_c(varname, c);
1103         lex_read_unichar(0);
1104
1105         while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) {
1106             sv_cat_c(varname, c);
1107             lex_read_unichar(0);
1108         }
1109
1110         padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL);
1111
1112         {
1113             OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
1114             my_var->op_targ = padoff;
1115
1116             vardeclseq = op_append_list(
1117                 OP_LINESEQ,
1118                 vardeclseq,
1119                 newSTATEOP(
1120                     0, NULL,
1121                     newASSIGNOP(
1122                         OPf_STACKED,
1123                         my_var, 0,
1124                         newSVOP(
1125                             OP_CONST, 0,
1126                             newSViv(++count)
1127                         )
1128                     )
1129                 )
1130             );
1131         }
1132
1133         lex_read_space(0);
1134         c = lex_peek_unichar(0);
1135     }
1136
1137     intro_my();
1138
1139     body = parse_block(0);
1140
1141     return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body));
1142 }
1143
1144 #define parse_join_with_space() THX_parse_join_with_space(aTHX)
1145 static OP *THX_parse_join_with_space(pTHX)
1146 {
1147     OP *delim, *args;
1148
1149     args = parse_listexpr(0);
1150     delim = newSVOP(OP_CONST, 0, newSVpvs(" "));
1151     return op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, delim, args));
1152 }
1153
1154 /* plugin glue */
1155
1156 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
1157 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
1158 {
1159     HE *he;
1160     if(!GvHV(PL_hintgv)) return 0;
1161     he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
1162                 SvSHARED_HASH(hintkey_sv));
1163     return he && SvTRUE(HeVAL(he));
1164 }
1165
1166 static int my_keyword_plugin(pTHX_
1167     char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
1168 {
1169     if (memEQs(keyword_ptr, keyword_len, "rpn") &&
1170                     keyword_active(hintkey_rpn_sv)) {
1171         *op_ptr = parse_keyword_rpn();
1172         return KEYWORD_PLUGIN_EXPR;
1173     } else if (memEQs(keyword_ptr, keyword_len, "calcrpn") &&
1174                     keyword_active(hintkey_calcrpn_sv)) {
1175         *op_ptr = parse_keyword_calcrpn();
1176         return KEYWORD_PLUGIN_STMT;
1177     } else if (memEQs(keyword_ptr, keyword_len, "stufftest") &&
1178                     keyword_active(hintkey_stufftest_sv)) {
1179         *op_ptr = parse_keyword_stufftest();
1180         return KEYWORD_PLUGIN_STMT;
1181     } else if (memEQs(keyword_ptr, keyword_len, "swaptwostmts") &&
1182                     keyword_active(hintkey_swaptwostmts_sv)) {
1183         *op_ptr = parse_keyword_swaptwostmts();
1184         return KEYWORD_PLUGIN_STMT;
1185     } else if (memEQs(keyword_ptr, keyword_len, "looprest") &&
1186                     keyword_active(hintkey_looprest_sv)) {
1187         *op_ptr = parse_keyword_looprest();
1188         return KEYWORD_PLUGIN_STMT;
1189     } else if (memEQs(keyword_ptr, keyword_len, "scopelessblock") &&
1190                     keyword_active(hintkey_scopelessblock_sv)) {
1191         *op_ptr = parse_keyword_scopelessblock();
1192         return KEYWORD_PLUGIN_STMT;
1193     } else if (memEQs(keyword_ptr, keyword_len, "stmtasexpr") &&
1194                     keyword_active(hintkey_stmtasexpr_sv)) {
1195         *op_ptr = parse_keyword_stmtasexpr();
1196         return KEYWORD_PLUGIN_EXPR;
1197     } else if (memEQs(keyword_ptr, keyword_len, "stmtsasexpr") &&
1198                     keyword_active(hintkey_stmtsasexpr_sv)) {
1199         *op_ptr = parse_keyword_stmtsasexpr();
1200         return KEYWORD_PLUGIN_EXPR;
1201     } else if (memEQs(keyword_ptr, keyword_len, "loopblock") &&
1202                     keyword_active(hintkey_loopblock_sv)) {
1203         *op_ptr = parse_keyword_loopblock();
1204         return KEYWORD_PLUGIN_STMT;
1205     } else if (memEQs(keyword_ptr, keyword_len, "blockasexpr") &&
1206                     keyword_active(hintkey_blockasexpr_sv)) {
1207         *op_ptr = parse_keyword_blockasexpr();
1208         return KEYWORD_PLUGIN_EXPR;
1209     } else if (memEQs(keyword_ptr, keyword_len, "swaplabel") &&
1210                     keyword_active(hintkey_swaplabel_sv)) {
1211         *op_ptr = parse_keyword_swaplabel();
1212         return KEYWORD_PLUGIN_STMT;
1213     } else if (memEQs(keyword_ptr, keyword_len, "labelconst") &&
1214                     keyword_active(hintkey_labelconst_sv)) {
1215         *op_ptr = parse_keyword_labelconst();
1216         return KEYWORD_PLUGIN_EXPR;
1217     } else if (memEQs(keyword_ptr, keyword_len, "arrayfullexpr") &&
1218                     keyword_active(hintkey_arrayfullexpr_sv)) {
1219         *op_ptr = parse_keyword_arrayfullexpr();
1220         return KEYWORD_PLUGIN_EXPR;
1221     } else if (memEQs(keyword_ptr, keyword_len, "arraylistexpr") &&
1222                     keyword_active(hintkey_arraylistexpr_sv)) {
1223         *op_ptr = parse_keyword_arraylistexpr();
1224         return KEYWORD_PLUGIN_EXPR;
1225     } else if (memEQs(keyword_ptr, keyword_len, "arraytermexpr") &&
1226                     keyword_active(hintkey_arraytermexpr_sv)) {
1227         *op_ptr = parse_keyword_arraytermexpr();
1228         return KEYWORD_PLUGIN_EXPR;
1229     } else if (memEQs(keyword_ptr, keyword_len, "arrayarithexpr") &&
1230                     keyword_active(hintkey_arrayarithexpr_sv)) {
1231         *op_ptr = parse_keyword_arrayarithexpr();
1232         return KEYWORD_PLUGIN_EXPR;
1233     } else if (memEQs(keyword_ptr, keyword_len, "arrayexprflags") &&
1234                     keyword_active(hintkey_arrayexprflags_sv)) {
1235         *op_ptr = parse_keyword_arrayexprflags();
1236         return KEYWORD_PLUGIN_EXPR;
1237     } else if (memEQs(keyword_ptr, keyword_len, "DEFSV") &&
1238                     keyword_active(hintkey_DEFSV_sv)) {
1239         *op_ptr = parse_keyword_DEFSV();
1240         return KEYWORD_PLUGIN_EXPR;
1241     } else if (memEQs(keyword_ptr, keyword_len, "with_vars") &&
1242                     keyword_active(hintkey_with_vars_sv)) {
1243         *op_ptr = parse_keyword_with_vars();
1244         return KEYWORD_PLUGIN_STMT;
1245     } else if (memEQs(keyword_ptr, keyword_len, "join_with_space") &&
1246                     keyword_active(hintkey_join_with_space_sv)) {
1247         *op_ptr = parse_join_with_space();
1248         return KEYWORD_PLUGIN_EXPR;
1249     } else {
1250         assert(next_keyword_plugin != my_keyword_plugin);
1251         return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
1252     }
1253 }
1254
1255 static XOP my_xop;
1256
1257 static OP *
1258 pp_xop(pTHX)
1259 {
1260     return PL_op->op_next;
1261 }
1262
1263 static void
1264 peep_xop(pTHX_ OP *o, OP *oldop)
1265 {
1266     dMY_CXT;
1267     av_push(MY_CXT.xop_record, newSVpvf("peep:%" UVxf, PTR2UV(o)));
1268     av_push(MY_CXT.xop_record, newSVpvf("oldop:%" UVxf, PTR2UV(oldop)));
1269 }
1270
1271 static I32
1272 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
1273 {
1274     char *p;
1275     char *end;
1276     int n = FILTER_READ(idx + 1, buf_sv, maxlen);
1277
1278     if (n<=0) return n;
1279
1280     p = SvPV_force_nolen(buf_sv);
1281     end = p + SvCUR(buf_sv);
1282     while (p < end) {
1283         if (*p == 'o') *p = 'e';
1284         p++;
1285     }
1286     return SvCUR(buf_sv);
1287 }
1288
1289 static AV *
1290 myget_linear_isa(pTHX_ HV *stash, U32 level) {
1291     GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
1292     PERL_UNUSED_ARG(level);
1293     return gvp && *gvp && GvAV(*gvp)
1294          ? GvAV(*gvp)
1295          : (AV *)sv_2mortal((SV *)newAV());
1296 }
1297
1298
1299 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
1300 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
1301 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
1302
1303 static struct mro_alg mymro;
1304
1305 static Perl_check_t addissub_nxck_add;
1306
1307 static OP *
1308 addissub_myck_add(pTHX_ OP *op)
1309 {
1310     SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
1311     OP *aop, *bop;
1312     U8 flags;
1313     if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
1314             (aop = cBINOPx(op)->op_first) && (bop = OpSIBLING(aop)) &&
1315             !OpHAS_SIBLING(bop)))
1316         return addissub_nxck_add(aTHX_ op);
1317     flags = op->op_flags;
1318     op_sibling_splice(op, NULL, 1, NULL); /* excise aop */
1319     op_sibling_splice(op, NULL, 1, NULL); /* excise bop */
1320     op_free(op); /* free the empty husk */
1321     flags &= ~OPf_KIDS;
1322     return newBINOP(OP_SUBTRACT, flags, aop, bop);
1323 }
1324
1325 static Perl_check_t old_ck_rv2cv;
1326
1327 static OP *
1328 my_ck_rv2cv(pTHX_ OP *o)
1329 {
1330     SV *ref;
1331     SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addunder", 0);
1332     OP *aop;
1333
1334     if (flag_svp && SvTRUE(*flag_svp) && (o->op_flags & OPf_KIDS)
1335      && (aop = cUNOPx(o)->op_first) && aop->op_type == OP_CONST
1336      && aop->op_private & (OPpCONST_ENTERED|OPpCONST_BARE)
1337      && (ref = cSVOPx(aop)->op_sv) && SvPOK(ref) && SvCUR(ref)
1338      && *(SvEND(ref)-1) == 'o')
1339     {
1340         SvGROW(ref, SvCUR(ref)+2);
1341         *SvEND(ref) = '_';
1342         SvCUR(ref)++;
1343         *SvEND(ref) = '\0';
1344     }
1345     return old_ck_rv2cv(aTHX_ o);
1346 }
1347
1348 #include "const-c.inc"
1349
1350 MODULE = XS::APItest            PACKAGE = XS::APItest
1351
1352 INCLUDE: const-xs.inc
1353
1354 INCLUDE: numeric.xs
1355
1356 void
1357 assertx(int x)
1358     CODE:
1359         /* this only needs to compile and checks that assert() can be
1360            used this way syntactically */
1361         (void)(assert(x), 1);
1362         (void)(x);
1363
1364 MODULE = XS::APItest::utf8      PACKAGE = XS::APItest::utf8
1365
1366 int
1367 bytes_cmp_utf8(bytes, utf8)
1368         SV *bytes
1369         SV *utf8
1370     PREINIT:
1371         const U8 *b;
1372         STRLEN blen;
1373         const U8 *u;
1374         STRLEN ulen;
1375     CODE:
1376         b = (const U8 *)SvPVbyte(bytes, blen);
1377         u = (const U8 *)SvPVbyte(utf8, ulen);
1378         RETVAL = bytes_cmp_utf8(b, blen, u, ulen);
1379     OUTPUT:
1380         RETVAL
1381
1382 AV *
1383 test_utf8n_to_uvchr_error(s, len, flags)
1384
1385         SV *s
1386         SV *len
1387         SV *flags
1388     PREINIT:
1389         STRLEN retlen;
1390         UV ret;
1391         STRLEN slen;
1392         U32 errors;
1393
1394     CODE:
1395         /* Now that utf8n_to_uvchr() is a trivial wrapper for
1396          * utf8n_to_uvchr_error(), call the latter with the inputs.  It always
1397          * asks for the actual length to be returned and errors to be returned
1398          *
1399          * Length to assume <s> is; not checked, so could have buffer overflow
1400          */
1401         RETVAL = newAV();
1402         sv_2mortal((SV*)RETVAL);
1403
1404         ret = utf8n_to_uvchr_error((U8*) SvPV(s, slen),
1405                                          SvUV(len),
1406                                          &retlen,
1407                                          SvUV(flags),
1408                                          &errors);
1409
1410         /* Returns the return value in [0]; <retlen> in [1], <errors> in [2] */
1411         av_push(RETVAL, newSVuv(ret));
1412         if (retlen == (STRLEN) -1) {
1413             av_push(RETVAL, newSViv(-1));
1414         }
1415         else {
1416             av_push(RETVAL, newSVuv(retlen));
1417         }
1418         av_push(RETVAL, newSVuv(errors));
1419
1420     OUTPUT:
1421         RETVAL
1422
1423 AV *
1424 test_valid_utf8_to_uvchr(s)
1425
1426         SV *s
1427     PREINIT:
1428         STRLEN retlen;
1429         UV ret;
1430
1431     CODE:
1432         /* Call utf8n_to_uvchr() with the inputs.  It always asks for the
1433          * actual length to be returned
1434          *
1435          * Length to assume <s> is; not checked, so could have buffer overflow
1436          */
1437         RETVAL = newAV();
1438         sv_2mortal((SV*)RETVAL);
1439
1440         ret = valid_utf8_to_uvchr((U8*) SvPV_nolen(s), &retlen);
1441
1442         /* Returns the return value in [0]; <retlen> in [1] */
1443         av_push(RETVAL, newSVuv(ret));
1444         av_push(RETVAL, newSVuv(retlen));
1445
1446     OUTPUT:
1447         RETVAL
1448
1449 SV *
1450 test_uvchr_to_utf8_flags(uv, flags)
1451
1452         SV *uv
1453         SV *flags
1454     PREINIT:
1455         U8 dest[UTF8_MAXBYTES + 1];
1456         U8 *ret;
1457
1458     CODE:
1459         /* Call uvchr_to_utf8_flags() with the inputs.  */
1460         ret = uvchr_to_utf8_flags(dest, SvUV(uv), SvUV(flags));
1461         if (! ret) {
1462             XSRETURN_UNDEF;
1463         }
1464         RETVAL = newSVpvn((char *) dest, ret - dest);
1465
1466     OUTPUT:
1467         RETVAL
1468
1469 MODULE = XS::APItest:Overload   PACKAGE = XS::APItest::Overload
1470
1471 void
1472 amagic_deref_call(sv, what)
1473         SV *sv
1474         int what
1475     PPCODE:
1476         /* The reference is owned by something else.  */
1477         PUSHs(amagic_deref_call(sv, what));
1478
1479 # I'd certainly like to discourage the use of this macro, given that we now
1480 # have amagic_deref_call
1481
1482 void
1483 tryAMAGICunDEREF_var(sv, what)
1484         SV *sv
1485         int what
1486     PPCODE:
1487         {
1488             SV **sp = &sv;
1489             switch(what) {
1490             case to_av_amg:
1491                 tryAMAGICunDEREF(to_av);
1492                 break;
1493             case to_cv_amg:
1494                 tryAMAGICunDEREF(to_cv);
1495                 break;
1496             case to_gv_amg:
1497                 tryAMAGICunDEREF(to_gv);
1498                 break;
1499             case to_hv_amg:
1500                 tryAMAGICunDEREF(to_hv);
1501                 break;
1502             case to_sv_amg:
1503                 tryAMAGICunDEREF(to_sv);
1504                 break;
1505             default:
1506                 croak("Invalid value %d passed to tryAMAGICunDEREF_var", what);
1507             }
1508         }
1509         /* The reference is owned by something else.  */
1510         PUSHs(sv);
1511
1512 MODULE = XS::APItest            PACKAGE = XS::APItest::XSUB
1513
1514 BOOT:
1515     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
1516     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
1517     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
1518
1519 void
1520 XS_VERSION_defined(...)
1521     PPCODE:
1522         XS_VERSION_BOOTCHECK;
1523         XSRETURN_EMPTY;
1524
1525 void
1526 XS_APIVERSION_valid(...)
1527     PPCODE:
1528         XS_APIVERSION_BOOTCHECK;
1529         XSRETURN_EMPTY;
1530
1531 void
1532 xsreturn( int len )
1533     PPCODE:
1534         int i = 0;
1535         EXTEND( SP, len );
1536         for ( ; i < len; i++ ) {
1537             ST(i) = sv_2mortal( newSViv(i) );
1538         }
1539         XSRETURN( len );
1540
1541 void
1542 xsreturn_iv()
1543     PPCODE:
1544         XSRETURN_IV(I32_MIN + 1);
1545
1546 void
1547 xsreturn_uv()
1548     PPCODE:
1549         XSRETURN_UV( (U32)((1U<<31) + 1) );
1550
1551 void
1552 xsreturn_nv()
1553     PPCODE:
1554         XSRETURN_NV(0.25);
1555
1556 void
1557 xsreturn_pv()
1558     PPCODE:
1559         XSRETURN_PV("returned");
1560
1561 void
1562 xsreturn_pvn()
1563     PPCODE:
1564         XSRETURN_PVN("returned too much",8);
1565
1566 void
1567 xsreturn_no()
1568     PPCODE:
1569         XSRETURN_NO;
1570
1571 void
1572 xsreturn_yes()
1573     PPCODE:
1574         XSRETURN_YES;
1575
1576 void
1577 xsreturn_undef()
1578     PPCODE:
1579         XSRETURN_UNDEF;
1580
1581 void
1582 xsreturn_empty()
1583     PPCODE:
1584         XSRETURN_EMPTY;
1585
1586 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
1587
1588 void
1589 rot13_hash(hash)
1590         HV *hash
1591         CODE:
1592         {
1593             struct ufuncs uf;
1594             uf.uf_val = rot13_key;
1595             uf.uf_set = 0;
1596             uf.uf_index = 0;
1597
1598             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1599         }
1600
1601 void
1602 bitflip_hash(hash)
1603         HV *hash
1604         CODE:
1605         {
1606             struct ufuncs uf;
1607             uf.uf_val = bitflip_key;
1608             uf.uf_set = 0;
1609             uf.uf_index = 0;
1610
1611             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1612         }
1613
1614 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
1615
1616 bool
1617 exists(hash, key_sv)
1618         PREINIT:
1619         STRLEN len;
1620         const char *key;
1621         INPUT:
1622         HV *hash
1623         SV *key_sv
1624         CODE:
1625         key = SvPV(key_sv, len);
1626         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
1627         OUTPUT:
1628         RETVAL
1629
1630 bool
1631 exists_ent(hash, key_sv)
1632         PREINIT:
1633         INPUT:
1634         HV *hash
1635         SV *key_sv
1636         CODE:
1637         RETVAL = hv_exists_ent(hash, key_sv, 0);
1638         OUTPUT:
1639         RETVAL
1640
1641 SV *
1642 delete(hash, key_sv, flags = 0)
1643         PREINIT:
1644         STRLEN len;
1645         const char *key;
1646         INPUT:
1647         HV *hash
1648         SV *key_sv
1649         I32 flags;
1650         CODE:
1651         key = SvPV(key_sv, len);
1652         /* It's already mortal, so need to increase reference count.  */
1653         RETVAL
1654             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
1655         OUTPUT:
1656         RETVAL
1657
1658 SV *
1659 delete_ent(hash, key_sv, flags = 0)
1660         INPUT:
1661         HV *hash
1662         SV *key_sv
1663         I32 flags;
1664         CODE:
1665         /* It's already mortal, so need to increase reference count.  */
1666         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
1667         OUTPUT:
1668         RETVAL
1669
1670 SV *
1671 store_ent(hash, key, value)
1672         PREINIT:
1673         SV *copy;
1674         HE *result;
1675         INPUT:
1676         HV *hash
1677         SV *key
1678         SV *value
1679         CODE:
1680         copy = newSV(0);
1681         result = hv_store_ent(hash, key, copy, 0);
1682         SvSetMagicSV(copy, value);
1683         if (!result) {
1684             SvREFCNT_dec(copy);
1685             XSRETURN_EMPTY;
1686         }
1687         /* It's about to become mortal, so need to increase reference count.
1688          */
1689         RETVAL = SvREFCNT_inc(HeVAL(result));
1690         OUTPUT:
1691         RETVAL
1692
1693 SV *
1694 store(hash, key_sv, value)
1695         PREINIT:
1696         STRLEN len;
1697         const char *key;
1698         SV *copy;
1699         SV **result;
1700         INPUT:
1701         HV *hash
1702         SV *key_sv
1703         SV *value
1704         CODE:
1705         key = SvPV(key_sv, len);
1706         copy = newSV(0);
1707         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
1708         SvSetMagicSV(copy, value);
1709         if (!result) {
1710             SvREFCNT_dec(copy);
1711             XSRETURN_EMPTY;
1712         }
1713         /* It's about to become mortal, so need to increase reference count.
1714          */
1715         RETVAL = SvREFCNT_inc(*result);
1716         OUTPUT:
1717         RETVAL
1718
1719 SV *
1720 fetch_ent(hash, key_sv)
1721         PREINIT:
1722         HE *result;
1723         INPUT:
1724         HV *hash
1725         SV *key_sv
1726         CODE:
1727         result = hv_fetch_ent(hash, key_sv, 0, 0);
1728         if (!result) {
1729             XSRETURN_EMPTY;
1730         }
1731         /* Force mg_get  */
1732         RETVAL = newSVsv(HeVAL(result));
1733         OUTPUT:
1734         RETVAL
1735
1736 SV *
1737 fetch(hash, key_sv)
1738         PREINIT:
1739         STRLEN len;
1740         const char *key;
1741         SV **result;
1742         INPUT:
1743         HV *hash
1744         SV *key_sv
1745         CODE:
1746         key = SvPV(key_sv, len);
1747         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
1748         if (!result) {
1749             XSRETURN_EMPTY;
1750         }
1751         /* Force mg_get  */
1752         RETVAL = newSVsv(*result);
1753         OUTPUT:
1754         RETVAL
1755
1756 #if defined (hv_common)
1757
1758 SV *
1759 common(params)
1760         INPUT:
1761         HV *params
1762         PREINIT:
1763         HE *result;
1764         HV *hv = NULL;
1765         SV *keysv = NULL;
1766         const char *key = NULL;
1767         STRLEN klen = 0;
1768         int flags = 0;
1769         int action = 0;
1770         SV *val = NULL;
1771         U32 hash = 0;
1772         SV **svp;
1773         CODE:
1774         if ((svp = hv_fetchs(params, "hv", 0))) {
1775             SV *const rv = *svp;
1776             if (!SvROK(rv))
1777                 croak("common passed a non-reference for parameter hv");
1778             hv = (HV *)SvRV(rv);
1779         }
1780         if ((svp = hv_fetchs(params, "keysv", 0)))
1781             keysv = *svp;
1782         if ((svp = hv_fetchs(params, "keypv", 0))) {
1783             key = SvPV_const(*svp, klen);
1784             if (SvUTF8(*svp))
1785                 flags = HVhek_UTF8;
1786         }
1787         if ((svp = hv_fetchs(params, "action", 0)))
1788             action = SvIV(*svp);
1789         if ((svp = hv_fetchs(params, "val", 0)))
1790             val = newSVsv(*svp);
1791         if ((svp = hv_fetchs(params, "hash", 0)))
1792             hash = SvUV(*svp);
1793
1794         if (hv_fetchs(params, "hash_pv", 0)) {
1795             assert(key);
1796             PERL_HASH(hash, key, klen);
1797         }
1798         if (hv_fetchs(params, "hash_sv", 0)) {
1799             assert(keysv);
1800             {
1801               STRLEN len;
1802               const char *const p = SvPV(keysv, len);
1803               PERL_HASH(hash, p, len);
1804             }
1805         }
1806
1807         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
1808         if (!result) {
1809             XSRETURN_EMPTY;
1810         }
1811         /* Force mg_get  */
1812         RETVAL = newSVsv(HeVAL(result));
1813         OUTPUT:
1814         RETVAL
1815
1816 #endif
1817
1818 void
1819 test_hv_free_ent()
1820         PPCODE:
1821         test_freeent(&Perl_hv_free_ent);
1822         XSRETURN(4);
1823
1824 void
1825 test_hv_delayfree_ent()
1826         PPCODE:
1827         test_freeent(&Perl_hv_delayfree_ent);
1828         XSRETURN(4);
1829
1830 SV *
1831 test_share_unshare_pvn(input)
1832         PREINIT:
1833         STRLEN len;
1834         U32 hash;
1835         char *pvx;
1836         char *p;
1837         INPUT:
1838         SV *input
1839         CODE:
1840         pvx = SvPV(input, len);
1841         PERL_HASH(hash, pvx, len);
1842         p = sharepvn(pvx, len, hash);
1843         RETVAL = newSVpvn(p, len);
1844         unsharepvn(p, len, hash);
1845         OUTPUT:
1846         RETVAL
1847
1848 #if PERL_VERSION >= 9
1849
1850 bool
1851 refcounted_he_exists(key, level=0)
1852         SV *key
1853         IV level
1854         CODE:
1855         if (level) {
1856             croak("level must be zero, not %" IVdf, level);
1857         }
1858         RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder);
1859         OUTPUT:
1860         RETVAL
1861
1862 SV *
1863 refcounted_he_fetch(key, level=0)
1864         SV *key
1865         IV level
1866         CODE:
1867         if (level) {
1868             croak("level must be zero, not %" IVdf, level);
1869         }
1870         RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0);
1871         SvREFCNT_inc(RETVAL);
1872         OUTPUT:
1873         RETVAL
1874
1875 #endif
1876
1877 void
1878 test_force_keys(HV *hv)
1879     PREINIT:
1880         HE *he;
1881         SSize_t count = 0;
1882     PPCODE:
1883         hv_iterinit(hv);
1884         he = hv_iternext(hv);
1885         while (he) {
1886             SV *sv = HeSVKEY_force(he);
1887             ++count;
1888             EXTEND(SP, count);
1889             PUSHs(sv_mortalcopy(sv));
1890             he = hv_iternext(hv);
1891         }
1892
1893 =pod
1894
1895 sub TIEHASH  { bless {}, $_[0] }
1896 sub STORE    { $_[0]->{$_[1]} = $_[2] }
1897 sub FETCH    { $_[0]->{$_[1]} }
1898 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1899 sub NEXTKEY  { each %{$_[0]} }
1900 sub EXISTS   { exists $_[0]->{$_[1]} }
1901 sub DELETE   { delete $_[0]->{$_[1]} }
1902 sub CLEAR    { %{$_[0]} = () }
1903
1904 =cut
1905
1906 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
1907
1908 void
1909 make_temp_mg_lv(sv)
1910 SV* sv
1911     PREINIT:
1912         SV * const lv = newSV_type(SVt_PVLV);
1913         STRLEN len;
1914     PPCODE:
1915         SvPV(sv, len);
1916
1917         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1918         LvTYPE(lv) = 'x';
1919         LvTARG(lv) = SvREFCNT_inc_simple(sv);
1920         LvTARGOFF(lv) = len == 0 ? 0 : 1;
1921         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1922
1923         EXTEND(SP, 1);
1924         ST(0) = sv_2mortal(lv);
1925         XSRETURN(1);
1926
1927
1928 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1929
1930 void
1931 ptr_table_new(classname)
1932 const char * classname
1933     PPCODE:
1934     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1935
1936 void
1937 DESTROY(table)
1938 XS::APItest::PtrTable table
1939     CODE:
1940     ptr_table_free(table);
1941
1942 void
1943 ptr_table_store(table, from, to)
1944 XS::APItest::PtrTable table
1945 SVREF from
1946 SVREF to
1947    CODE:
1948    ptr_table_store(table, from, to);
1949
1950 UV
1951 ptr_table_fetch(table, from)
1952 XS::APItest::PtrTable table
1953 SVREF from
1954    CODE:
1955    RETVAL = PTR2UV(ptr_table_fetch(table, from));
1956    OUTPUT:
1957    RETVAL
1958
1959 void
1960 ptr_table_split(table)
1961 XS::APItest::PtrTable table
1962
1963 void
1964 ptr_table_clear(table)
1965 XS::APItest::PtrTable table
1966
1967 MODULE = XS::APItest::AutoLoader        PACKAGE = XS::APItest::AutoLoader
1968
1969 SV *
1970 AUTOLOAD()
1971     CODE:
1972         RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1973     OUTPUT:
1974         RETVAL
1975
1976 SV *
1977 AUTOLOADp(...)
1978     PROTOTYPE: *$
1979     CODE:
1980         PERL_UNUSED_ARG(items);
1981         RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1982     OUTPUT:
1983         RETVAL
1984
1985
1986 MODULE = XS::APItest            PACKAGE = XS::APItest
1987
1988 PROTOTYPES: DISABLE
1989
1990 BOOT:
1991     mymro.resolve = myget_linear_isa;
1992     mymro.name    = "justisa";
1993     mymro.length  = 7;
1994     mymro.kflags  = 0;
1995     mymro.hash    = 0;
1996     Perl_mro_register(aTHX_ &mymro);
1997
1998 HV *
1999 xop_custom_ops ()
2000     CODE:
2001         RETVAL = PL_custom_ops;
2002     OUTPUT:
2003         RETVAL
2004
2005 HV *
2006 xop_custom_op_names ()
2007     CODE:
2008         PL_custom_op_names = newHV();
2009         RETVAL = PL_custom_op_names;
2010     OUTPUT:
2011         RETVAL
2012
2013 HV *
2014 xop_custom_op_descs ()
2015     CODE:
2016         PL_custom_op_descs = newHV();
2017         RETVAL = PL_custom_op_descs;
2018     OUTPUT:
2019         RETVAL
2020
2021 void
2022 xop_register ()
2023     CODE:
2024         XopENTRY_set(&my_xop, xop_name, "my_xop");
2025         XopENTRY_set(&my_xop, xop_desc, "XOP for testing");
2026         XopENTRY_set(&my_xop, xop_class, OA_UNOP);
2027         XopENTRY_set(&my_xop, xop_peep, peep_xop);
2028         Perl_custom_op_register(aTHX_ pp_xop, &my_xop);
2029
2030 void
2031 xop_clear ()
2032     CODE:
2033         XopDISABLE(&my_xop, xop_name);
2034         XopDISABLE(&my_xop, xop_desc);
2035         XopDISABLE(&my_xop, xop_class);
2036         XopDISABLE(&my_xop, xop_peep);
2037
2038 IV
2039 xop_my_xop ()
2040     CODE:
2041         RETVAL = PTR2IV(&my_xop);
2042     OUTPUT:
2043         RETVAL
2044
2045 IV
2046 xop_ppaddr ()
2047     CODE:
2048         RETVAL = PTR2IV(pp_xop);
2049     OUTPUT:
2050         RETVAL
2051
2052 IV
2053 xop_OA_UNOP ()
2054     CODE:
2055         RETVAL = OA_UNOP;
2056     OUTPUT:
2057         RETVAL
2058
2059 AV *
2060 xop_build_optree ()
2061     CODE:
2062         dMY_CXT;
2063         UNOP *unop;
2064         OP *kid;
2065
2066         MY_CXT.xop_record = newAV();
2067
2068         kid = newSVOP(OP_CONST, 0, newSViv(42));
2069         
2070         unop = (UNOP*)mkUNOP(OP_CUSTOM, kid);
2071         unop->op_ppaddr     = pp_xop;
2072         unop->op_private    = 0;
2073         unop->op_next       = NULL;
2074         kid->op_next        = (OP*)unop;
2075
2076         av_push(MY_CXT.xop_record, newSVpvf("unop:%" UVxf, PTR2UV(unop)));
2077         av_push(MY_CXT.xop_record, newSVpvf("kid:%" UVxf, PTR2UV(kid)));
2078
2079         av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop)));
2080         av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop)));
2081         av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop)));
2082
2083         PL_rpeepp(aTHX_ kid);
2084
2085         FreeOp(kid);
2086         FreeOp(unop);
2087
2088         RETVAL = MY_CXT.xop_record;
2089         MY_CXT.xop_record = NULL;
2090     OUTPUT:
2091         RETVAL
2092
2093 IV
2094 xop_from_custom_op ()
2095     CODE:
2096 /* author note: this test doesn't imply Perl_custom_op_xop is or isn't public
2097    API or that Perl_custom_op_xop is known to be used outside the core */
2098         UNOP *unop;
2099         XOP *xop;
2100
2101         unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL);
2102         unop->op_ppaddr     = pp_xop;
2103         unop->op_private    = 0;
2104         unop->op_next       = NULL;
2105
2106         xop = Perl_custom_op_xop(aTHX_ (OP *)unop);
2107         FreeOp(unop);
2108         RETVAL = PTR2IV(xop);
2109     OUTPUT:
2110         RETVAL
2111
2112 BOOT:
2113 {
2114     MY_CXT_INIT;
2115
2116     MY_CXT.i  = 99;
2117     MY_CXT.sv = newSVpv("initial",0);
2118
2119     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
2120     MY_CXT.bhk_record = 0;
2121
2122     BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
2123     BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
2124     BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
2125     BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
2126     Perl_blockhook_register(aTHX_ &bhk_test);
2127
2128     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
2129         GV_ADDMULTI, SVt_PVAV);
2130     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
2131
2132     BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
2133     BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
2134     Perl_blockhook_register(aTHX_ &bhk_csc);
2135
2136     MY_CXT.peep_recorder = newAV();
2137     MY_CXT.rpeep_recorder = newAV();
2138
2139     MY_CXT.orig_peep = PL_peepp;
2140     MY_CXT.orig_rpeep = PL_rpeepp;
2141     PL_peepp = my_peep;
2142     PL_rpeepp = my_rpeep;
2143 }
2144
2145 void
2146 CLONE(...)
2147     CODE:
2148     MY_CXT_CLONE;
2149     PERL_UNUSED_VAR(items);
2150     MY_CXT.sv = newSVpv("initial_clone",0);
2151     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
2152         GV_ADDMULTI, SVt_PVAV);
2153     MY_CXT.cscav = NULL;
2154     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
2155     MY_CXT.bhk_record = 0;
2156     MY_CXT.peep_recorder = newAV();
2157     MY_CXT.rpeep_recorder = newAV();
2158
2159 void
2160 print_double(val)
2161         double val
2162         CODE:
2163         printf("%5.3f\n",val);
2164
2165 int
2166 have_long_double()
2167         CODE:
2168 #ifdef HAS_LONG_DOUBLE
2169         RETVAL = 1;
2170 #else
2171         RETVAL = 0;
2172 #endif
2173         OUTPUT:
2174         RETVAL
2175
2176 void
2177 print_long_double()
2178         CODE:
2179 #ifdef HAS_LONG_DOUBLE
2180 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
2181         long double val = 7.0;
2182         printf("%5.3" PERL_PRIfldbl "\n",val);
2183 #   else
2184         double val = 7.0;
2185         printf("%5.3f\n",val);
2186 #   endif
2187 #endif
2188
2189 void
2190 print_int(val)
2191         int val
2192         CODE:
2193         printf("%d\n",val);
2194
2195 void
2196 print_long(val)
2197         long val
2198         CODE:
2199         printf("%ld\n",val);
2200
2201 void
2202 print_float(val)
2203         float val
2204         CODE:
2205         printf("%5.3f\n",val);
2206         
2207 void
2208 print_flush()
2209         CODE:
2210         fflush(stdout);
2211
2212 void
2213 mpushp()
2214         PPCODE:
2215         EXTEND(SP, 3);
2216         mPUSHp("one", 3);
2217         mPUSHp("two", 3);
2218         mPUSHp("three", 5);
2219         XSRETURN(3);
2220
2221 void
2222 mpushn()
2223         PPCODE:
2224         EXTEND(SP, 3);
2225         mPUSHn(0.5);
2226         mPUSHn(-0.25);
2227         mPUSHn(0.125);
2228         XSRETURN(3);
2229
2230 void
2231 mpushi()
2232         PPCODE:
2233         EXTEND(SP, 3);
2234         mPUSHi(-1);
2235         mPUSHi(2);
2236         mPUSHi(-3);
2237         XSRETURN(3);
2238
2239 void
2240 mpushu()
2241         PPCODE:
2242         EXTEND(SP, 3);
2243         mPUSHu(1);
2244         mPUSHu(2);
2245         mPUSHu(3);
2246         XSRETURN(3);
2247
2248 void
2249 mxpushp()
2250         PPCODE:
2251         mXPUSHp("one", 3);
2252         mXPUSHp("two", 3);
2253         mXPUSHp("three", 5);
2254         XSRETURN(3);
2255
2256 void
2257 mxpushn()
2258         PPCODE:
2259         mXPUSHn(0.5);
2260         mXPUSHn(-0.25);
2261         mXPUSHn(0.125);
2262         XSRETURN(3);
2263
2264 void
2265 mxpushi()
2266         PPCODE:
2267         mXPUSHi(-1);
2268         mXPUSHi(2);
2269         mXPUSHi(-3);
2270         XSRETURN(3);
2271
2272 void
2273 mxpushu()
2274         PPCODE:
2275         mXPUSHu(1);
2276         mXPUSHu(2);
2277         mXPUSHu(3);
2278         XSRETURN(3);
2279
2280
2281  # test_EXTEND(): excerise the EXTEND() macro.
2282  # After calling EXTEND(), it also does *(p+n) = NULL and
2283  # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't
2284  # actually been extended properly.
2285  #
2286  # max_offset specifies the SP to use.  It is treated as a signed offset
2287  #              from PL_stack_max.
2288  # nsv        is the SV holding the value of n indicating how many slots
2289  #              to extend the stack by.
2290  # use_ss     is a boolean indicating that n should be cast to a SSize_t
2291
2292 void
2293 test_EXTEND(max_offset, nsv, use_ss)
2294     IV   max_offset;
2295     SV  *nsv;
2296     bool use_ss;
2297 PREINIT:
2298     SV **sp = PL_stack_max + max_offset;
2299 PPCODE:
2300     if (use_ss) {
2301         SSize_t n = (SSize_t)SvIV(nsv);
2302         EXTEND(sp, n);
2303         *(sp + n) = NULL;
2304     }
2305     else {
2306         IV n = SvIV(nsv);
2307         EXTEND(sp, n);
2308         *(sp + n) = NULL;
2309     }
2310     *PL_stack_max = NULL;
2311
2312
2313 void
2314 call_sv_C()
2315 PREINIT:
2316     CV * i_sub;
2317     GV * i_gv;
2318     I32 retcnt;
2319     SV * errsv;
2320     char * errstr;
2321     STRLEN errlen;
2322     SV * miscsv = sv_newmortal();
2323     HV * hv = (HV*)sv_2mortal((SV*)newHV());
2324 CODE:
2325     i_sub = get_cv("i", 0);
2326     PUSHMARK(SP);
2327     /* PUTBACK not needed since this sub was called with 0 args, and is calling
2328       0 args, so global SP doesn't need to be moved before a call_* */
2329     retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */
2330     SPAGAIN;
2331     SP -= retcnt; /* dont care about return count, wipe everything off */
2332     sv_setpvs(miscsv, "i");
2333     PUSHMARK(SP);
2334     retcnt = call_sv(miscsv, 0); /* try a PV */
2335     SPAGAIN;
2336     SP -= retcnt;
2337     /* no add and SVt_NULL are intentional, sub i should be defined already */
2338     i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL);
2339     PUSHMARK(SP);
2340     retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */
2341     SPAGAIN;
2342     SP -= retcnt;
2343     /* the tests below are not declaring this being public API behavior,
2344        only current internal behavior, these tests can be changed in the
2345        future if necessery */
2346     PUSHMARK(SP);
2347     retcnt = call_sv(&PL_sv_yes, G_EVAL);
2348     SPAGAIN;
2349     SP -= retcnt;
2350     errsv = ERRSV;
2351     errstr = SvPV(errsv, errlen);
2352     if(memBEGINs(errstr, errlen, "Undefined subroutine &main::1 called at")) {
2353         PUSHMARK(SP);
2354         retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2355         SPAGAIN;
2356         SP -= retcnt;
2357     }
2358     PUSHMARK(SP);
2359     retcnt = call_sv(&PL_sv_no, G_EVAL);
2360     SPAGAIN;
2361     SP -= retcnt;
2362     errsv = ERRSV;
2363     errstr = SvPV(errsv, errlen);
2364     if(memBEGINs(errstr, errlen, "Undefined subroutine &main:: called at")) {
2365         PUSHMARK(SP);
2366         retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2367         SPAGAIN;
2368         SP -= retcnt;
2369     }
2370     PUSHMARK(SP);
2371     retcnt = call_sv(&PL_sv_undef,  G_EVAL);
2372     SPAGAIN;
2373     SP -= retcnt;
2374     errsv = ERRSV;
2375     errstr = SvPV(errsv, errlen);
2376     if(memBEGINs(errstr, errlen, "Can't use an undefined value as a subroutine reference at")) {
2377         PUSHMARK(SP);
2378         retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2379         SPAGAIN;
2380         SP -= retcnt;
2381     }
2382     PUSHMARK(SP);
2383     retcnt = call_sv((SV*)hv,  G_EVAL);
2384     SPAGAIN;
2385     SP -= retcnt;
2386     errsv = ERRSV;
2387     errstr = SvPV(errsv, errlen);
2388     if(memBEGINs(errstr, errlen, "Not a CODE reference at")) {
2389         PUSHMARK(SP);
2390         retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
2391         SPAGAIN;
2392         SP -= retcnt;
2393     }
2394
2395 void
2396 call_sv(sv, flags, ...)
2397     SV* sv
2398     I32 flags
2399     PREINIT:
2400         I32 i;
2401     PPCODE:
2402         for (i=0; i<items-2; i++)
2403             ST(i) = ST(i+2); /* pop first two args */
2404         PUSHMARK(SP);
2405         SP += items - 2;
2406         PUTBACK;
2407         i = call_sv(sv, flags);
2408         SPAGAIN;
2409         EXTEND(SP, 1);
2410         PUSHs(sv_2mortal(newSViv(i)));
2411
2412 void
2413 call_pv(subname, flags, ...)
2414     char* subname
2415     I32 flags
2416     PREINIT:
2417         I32 i;
2418     PPCODE:
2419         for (i=0; i<items-2; i++)
2420             ST(i) = ST(i+2); /* pop first two args */
2421         PUSHMARK(SP);
2422         SP += items - 2;
2423         PUTBACK;
2424         i = call_pv(subname, flags);
2425         SPAGAIN;
2426         EXTEND(SP, 1);
2427         PUSHs(sv_2mortal(newSViv(i)));
2428
2429 void
2430 call_argv(subname, flags, ...)
2431     char* subname
2432     I32 flags
2433     PREINIT:
2434         I32 i;
2435         char *tmpary[4];
2436     PPCODE:
2437         for (i=0; i<items-2; i++)
2438             tmpary[i] = SvPV_nolen(ST(i+2)); /* ignore first two args */
2439         tmpary[i] = NULL;
2440         PUTBACK;
2441         i = call_argv(subname, flags, tmpary);
2442         SPAGAIN;
2443         EXTEND(SP, 1);
2444         PUSHs(sv_2mortal(newSViv(i)));
2445
2446 void
2447 call_method(methname, flags, ...)
2448     char* methname
2449     I32 flags
2450     PREINIT:
2451         I32 i;
2452     PPCODE:
2453         for (i=0; i<items-2; i++)
2454             ST(i) = ST(i+2); /* pop first two args */
2455         PUSHMARK(SP);
2456         SP += items - 2;
2457         PUTBACK;
2458         i = call_method(methname, flags);
2459         SPAGAIN;
2460         EXTEND(SP, 1);
2461         PUSHs(sv_2mortal(newSViv(i)));
2462
2463 void
2464 newCONSTSUB(stash, name, flags, sv)
2465     HV* stash
2466     SV* name
2467     I32 flags
2468     SV* sv
2469     ALIAS:
2470         newCONSTSUB_flags = 1
2471     PREINIT:
2472         CV* mycv = NULL;
2473         STRLEN len;
2474         const char *pv = SvPV(name, len);
2475     PPCODE:
2476         switch (ix) {
2477            case 0:
2478                mycv = newCONSTSUB(stash, pv, SvOK(sv) ? SvREFCNT_inc(sv) : NULL);
2479                break;
2480            case 1:
2481                mycv = newCONSTSUB_flags(
2482                  stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? SvREFCNT_inc(sv) : NULL
2483                );
2484                break;
2485         }
2486         EXTEND(SP, 2);
2487         assert(mycv);
2488         PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no );
2489         PUSHs((SV*)CvGV(mycv));
2490
2491 void
2492 gv_init_type(namesv, multi, flags, type)
2493     SV* namesv
2494     int multi
2495     I32 flags
2496     int type
2497     PREINIT:
2498         STRLEN len;
2499         const char * const name = SvPV_const(namesv, len);
2500         GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
2501     PPCODE:
2502         if (SvTYPE(gv) == SVt_PVGV)
2503             Perl_croak(aTHX_ "GV is already a PVGV");
2504         if (multi) flags |= GV_ADDMULTI;
2505         switch (type) {
2506            case 0:
2507                gv_init(gv, PL_defstash, name, len, multi);
2508                break;
2509            case 1:
2510                gv_init_sv(gv, PL_defstash, namesv, flags);
2511                break;
2512            case 2:
2513                gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
2514                break;
2515            case 3:
2516                gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
2517                break;
2518         }
2519         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2520
2521 void
2522 gv_fetchmeth_type(stash, methname, type, level, flags)
2523     HV* stash
2524     SV* methname
2525     int type
2526     I32 level
2527     I32 flags
2528     PREINIT:
2529         STRLEN len;
2530         const char * const name = SvPV_const(methname, len);
2531         GV* gv = NULL;
2532     PPCODE:
2533         switch (type) {
2534            case 0:
2535                gv = gv_fetchmeth(stash, name, len, level);
2536                break;
2537            case 1:
2538                gv = gv_fetchmeth_sv(stash, methname, level, flags);
2539                break;
2540            case 2:
2541                gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
2542                break;
2543            case 3:
2544                gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
2545                break;
2546         }
2547         XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2548
2549 void
2550 gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
2551     HV* stash
2552     SV* methname
2553     int type
2554     I32 level
2555     I32 flags
2556     PREINIT:
2557         STRLEN len;
2558         const char * const name = SvPV_const(methname, len);
2559         GV* gv = NULL;
2560     PPCODE:
2561         switch (type) {
2562            case 0:
2563                gv = gv_fetchmeth_autoload(stash, name, len, level);
2564                break;
2565            case 1:
2566                gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
2567                break;
2568            case 2:
2569                gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
2570                break;
2571            case 3:
2572                gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
2573                break;
2574         }
2575         XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2576
2577 void
2578 gv_fetchmethod_flags_type(stash, methname, type, flags)
2579     HV* stash
2580     SV* methname
2581     int type
2582     I32 flags
2583     PREINIT:
2584         GV* gv = NULL;
2585     PPCODE:
2586         switch (type) {
2587            case 0:
2588                gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
2589                break;
2590            case 1:
2591                gv = gv_fetchmethod_sv_flags(stash, methname, flags);
2592                break;
2593            case 2:
2594                gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
2595                break;
2596            case 3: {
2597                STRLEN len;
2598                const char * const name = SvPV_const(methname, len);
2599                gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
2600                break;
2601             }
2602            case 4:
2603                gv = gv_fetchmethod_pvn_flags(stash, SvPV_nolen(methname),
2604                                              flags, SvUTF8(methname));
2605         }
2606         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2607
2608 void
2609 gv_autoload_type(stash, methname, type, method)
2610     HV* stash
2611     SV* methname
2612     int type
2613     I32 method
2614     PREINIT:
2615         STRLEN len;
2616         const char * const name = SvPV_const(methname, len);
2617         GV* gv = NULL;
2618         I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
2619     PPCODE:
2620         switch (type) {
2621            case 0:
2622                gv = gv_autoload4(stash, name, len, method);
2623                break;
2624            case 1:
2625                gv = gv_autoload_sv(stash, methname, flags);
2626                break;
2627            case 2:
2628                gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
2629                break;
2630            case 3:
2631                gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
2632                break;
2633         }
2634         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2635
2636 SV *
2637 gv_const_sv(SV *name)
2638     PREINIT:
2639         GV *gv;
2640     CODE:
2641         if (SvPOK(name)) {
2642             HV *stash = gv_stashpv("main",0);
2643             HE *he = hv_fetch_ent(stash, name, 0, 0);
2644             gv = (GV *)HeVAL(he);
2645         }
2646         else {
2647             gv = (GV *)name;
2648         }
2649         RETVAL = gv_const_sv(gv);
2650         if (!RETVAL)
2651             XSRETURN_EMPTY;
2652         RETVAL = newSVsv(RETVAL);
2653     OUTPUT:
2654         RETVAL
2655
2656 void
2657 whichsig_type(namesv, type)
2658     SV* namesv
2659     int type
2660     PREINIT:
2661         STRLEN len;
2662         const char * const name = SvPV_const(namesv, len);
2663         I32 i = 0;
2664     PPCODE:
2665         switch (type) {
2666            case 0:
2667               i = whichsig(name);
2668                break;
2669            case 1:
2670                i = whichsig_sv(namesv);
2671                break;
2672            case 2:
2673                i = whichsig_pv(name);
2674                break;
2675            case 3:
2676                i = whichsig_pvn(name, len);
2677                break;
2678         }
2679         XPUSHs(sv_2mortal(newSViv(i)));
2680
2681 void
2682 eval_sv(sv, flags)
2683     SV* sv
2684     I32 flags
2685     PREINIT:
2686         I32 i;
2687     PPCODE:
2688         PUTBACK;
2689         i = eval_sv(sv, flags);
2690         SPAGAIN;
2691         EXTEND(SP, 1);
2692         PUSHs(sv_2mortal(newSViv(i)));
2693
2694 void
2695 eval_pv(p, croak_on_error)
2696     const char* p
2697     I32 croak_on_error
2698     PPCODE:
2699         PUTBACK;
2700         EXTEND(SP, 1);
2701         PUSHs(eval_pv(p, croak_on_error));
2702
2703 void
2704 require_pv(pv)
2705     const char* pv
2706     PPCODE:
2707         PUTBACK;
2708         require_pv(pv);
2709
2710 int
2711 apitest_exception(throw_e)
2712     int throw_e
2713     OUTPUT:
2714         RETVAL
2715
2716 void
2717 mycroak(sv)
2718     SV* sv
2719     CODE:
2720     if (SvOK(sv)) {
2721         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
2722     }
2723     else {
2724         Perl_croak(aTHX_ NULL);
2725     }
2726
2727 SV*
2728 strtab()
2729    CODE:
2730    RETVAL = newRV_inc((SV*)PL_strtab);
2731    OUTPUT:
2732    RETVAL
2733
2734 int
2735 my_cxt_getint()
2736     CODE:
2737         dMY_CXT;
2738         RETVAL = my_cxt_getint_p(aMY_CXT);
2739     OUTPUT:
2740         RETVAL
2741
2742 void
2743 my_cxt_setint(i)
2744     int i;
2745     CODE:
2746         dMY_CXT;
2747         my_cxt_setint_p(aMY_CXT_ i);
2748
2749 void
2750 my_cxt_getsv(how)
2751     bool how;
2752     PPCODE:
2753         EXTEND(SP, 1);
2754         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
2755         XSRETURN(1);
2756
2757 void
2758 my_cxt_setsv(sv)
2759     SV *sv;
2760     CODE:
2761         dMY_CXT;
2762         SvREFCNT_dec(MY_CXT.sv);
2763         my_cxt_setsv_p(sv _aMY_CXT);
2764         SvREFCNT_inc(sv);
2765
2766 bool
2767 sv_setsv_cow_hashkey_core()
2768
2769 bool
2770 sv_setsv_cow_hashkey_notcore()
2771
2772 void
2773 sv_set_deref(SV *sv, SV *sv2, int which)
2774     CODE:
2775     {
2776         STRLEN len;
2777         const char *pv = SvPV(sv2,len);
2778         if (!SvROK(sv)) croak("Not a ref");
2779         sv = SvRV(sv);
2780         switch (which) {
2781             case 0: sv_setsv(sv,sv2); break;
2782             case 1: sv_setpv(sv,pv); break;
2783             case 2: sv_setpvn(sv,pv,len); break;
2784         }
2785     }
2786
2787 void
2788 rmagical_cast(sv, type)
2789     SV *sv;
2790     SV *type;
2791     PREINIT:
2792         struct ufuncs uf;
2793     PPCODE:
2794         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
2795         sv = SvRV(sv);
2796         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
2797         uf.uf_val = rmagical_a_dummy;
2798         uf.uf_set = NULL;
2799         uf.uf_index = 0;
2800         if (SvTRUE(type)) { /* b */
2801             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
2802         } else { /* a */
2803             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
2804         }
2805         XSRETURN_YES;
2806
2807 void
2808 rmagical_flags(sv)
2809     SV *sv;
2810     PPCODE:
2811         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
2812         sv = SvRV(sv);
2813         EXTEND(SP, 3); 
2814         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
2815         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
2816         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
2817         XSRETURN(3);
2818
2819 void
2820 my_caller(level)
2821         I32 level
2822     PREINIT:
2823         const PERL_CONTEXT *cx, *dbcx;
2824         const char *pv;
2825         const GV *gv;
2826         HV *hv;
2827     PPCODE:
2828         cx = caller_cx(level, &dbcx);
2829         EXTEND(SP, 8);
2830
2831         pv = CopSTASHPV(cx->blk_oldcop);
2832         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2833         gv = CvGV(cx->blk_sub.cv);
2834         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2835
2836         pv = CopSTASHPV(dbcx->blk_oldcop);
2837         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2838         gv = CvGV(dbcx->blk_sub.cv);
2839         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2840
2841         ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
2842         ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
2843         ST(6) = cop_hints_fetch_sv(cx->blk_oldcop, 
2844                 sv_2mortal(newSVpvs("foo")), 0, 0);
2845
2846         hv = cop_hints_2hv(cx->blk_oldcop, 0);
2847         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
2848
2849         XSRETURN(8);
2850
2851 void
2852 DPeek (sv)
2853     SV   *sv
2854
2855   PPCODE:
2856     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
2857     XSRETURN (1);
2858
2859 void
2860 BEGIN()
2861     CODE:
2862         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
2863
2864 void
2865 CHECK()
2866     CODE:
2867         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
2868
2869 void
2870 UNITCHECK()
2871     CODE:
2872         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
2873
2874 void
2875 INIT()
2876     CODE:
2877         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
2878
2879 void
2880 END()
2881     CODE:
2882         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
2883
2884 void
2885 utf16_to_utf8 (sv, ...)
2886     SV* sv
2887         ALIAS:
2888             utf16_to_utf8_reversed = 1
2889     PREINIT:
2890         STRLEN len;
2891         U8 *source;
2892         SV *dest;
2893         I32 got; /* Gah, badly thought out APIs */
2894     CODE:
2895         if (ix) (void)SvPV_force_nolen(sv);
2896         source = (U8 *)SvPVbyte(sv, len);
2897         /* Optionally only convert part of the buffer.  */      
2898         if (items > 1) {
2899             len = SvUV(ST(1));
2900         }
2901         /* Mortalise this right now, as we'll be testing croak()s  */
2902         dest = sv_2mortal(newSV(len * 2 + 1));
2903         if (ix) {
2904             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
2905         } else {
2906             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
2907         }
2908         SvCUR_set(dest, got);
2909         SvPVX(dest)[got] = '\0';
2910         SvPOK_on(dest);
2911         ST(0) = dest;
2912         XSRETURN(1);
2913
2914 void
2915 my_exit(int exitcode)
2916         PPCODE:
2917         my_exit(exitcode);
2918
2919 U8
2920 first_byte(sv)
2921         SV *sv
2922    CODE:
2923     char *s;
2924     STRLEN len;
2925         s = SvPVbyte(sv, len);
2926         RETVAL = s[0];
2927    OUTPUT:
2928     RETVAL
2929
2930 I32
2931 sv_count()
2932         CODE:
2933             RETVAL = PL_sv_count;
2934         OUTPUT:
2935             RETVAL
2936
2937 void
2938 bhk_record(bool on)
2939     CODE:
2940         dMY_CXT;
2941         MY_CXT.bhk_record = on;
2942         if (on)
2943             av_clear(MY_CXT.bhkav);
2944
2945 void
2946 test_magic_chain()
2947     PREINIT:
2948         SV *sv;
2949         MAGIC *callmg, *uvarmg;
2950     CODE:
2951         sv = sv_2mortal(newSV(0));
2952         if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
2953         if (SvMAGICAL(sv)) croak_fail();
2954         sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
2955         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2956         if (!SvMAGICAL(sv)) croak_fail();
2957         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2958         callmg = mg_find(sv, PERL_MAGIC_checkcall);
2959         if (!callmg) croak_fail();
2960         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2961             croak_fail();
2962         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2963         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2964         if (!SvMAGICAL(sv)) croak_fail();
2965         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2966         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2967         if (!uvarmg) croak_fail();
2968         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2969             croak_fail();
2970         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2971             croak_fail();
2972         mg_free_type(sv, PERL_MAGIC_vec);
2973         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2974         if (!SvMAGICAL(sv)) croak_fail();
2975         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2976         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2977         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2978             croak_fail();
2979         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2980             croak_fail();
2981         mg_free_type(sv, PERL_MAGIC_uvar);
2982         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2983         if (!SvMAGICAL(sv)) croak_fail();
2984         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2985         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2986         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2987             croak_fail();
2988         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2989         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2990         if (!SvMAGICAL(sv)) croak_fail();
2991         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2992         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2993         if (!uvarmg) croak_fail();
2994         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2995             croak_fail();
2996         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2997             croak_fail();
2998         mg_free_type(sv, PERL_MAGIC_checkcall);
2999         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
3000         if (!SvMAGICAL(sv)) croak_fail();
3001         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
3002         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
3003         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
3004             croak_fail();
3005         mg_free_type(sv, PERL_MAGIC_uvar);
3006         if (SvMAGICAL(sv)) croak_fail();
3007         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
3008         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
3009
3010 void
3011 test_op_contextualize()
3012     PREINIT:
3013         OP *o;
3014     CODE:
3015         o = newSVOP(OP_CONST, 0, newSViv(0));
3016         o->op_flags &= ~OPf_WANT;
3017         o = op_contextualize(o, G_SCALAR);
3018         if (o->op_type != OP_CONST ||
3019                 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
3020             croak_fail();
3021         op_free(o);
3022         o = newSVOP(OP_CONST, 0, newSViv(0));
3023         o->op_flags &= ~OPf_WANT;
3024         o = op_contextualize(o, G_ARRAY);
3025         if (o->op_type != OP_CONST ||
3026                 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
3027             croak_fail();
3028         op_free(o);
3029         o = newSVOP(OP_CONST, 0, newSViv(0));
3030         o->op_flags &= ~OPf_WANT;
3031         o = op_contextualize(o, G_VOID);
3032         if (o->op_type != OP_NULL) croak_fail();
3033         op_free(o);
3034
3035 void
3036 test_rv2cv_op_cv()
3037     PROTOTYPE:
3038     PREINIT:
3039         GV *troc_gv;
3040         CV *troc_cv;
3041         OP *o;
3042     CODE:
3043         troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
3044         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
3045         o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
3046         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3047         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3048             croak_fail();
3049         o->op_private |= OPpENTERSUB_AMPER;
3050         if (rv2cv_op_cv(o, 0)) croak_fail();
3051         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3052         o->op_private &= ~OPpENTERSUB_AMPER;
3053         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3054         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3055         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3056         op_free(o);
3057         o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
3058         o->op_private = OPpCONST_BARE;
3059         o = newCVREF(0, o);
3060         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3061         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3062             croak_fail();
3063         o->op_private |= OPpENTERSUB_AMPER;
3064         if (rv2cv_op_cv(o, 0)) croak_fail();
3065         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3066         op_free(o);
3067         o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
3068         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3069         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3070             croak_fail();
3071         o->op_private |= OPpENTERSUB_AMPER;
3072         if (rv2cv_op_cv(o, 0)) croak_fail();
3073         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3074         o->op_private &= ~OPpENTERSUB_AMPER;
3075         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3076         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3077         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3078         op_free(o);
3079         o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
3080         if (rv2cv_op_cv(o, 0)) croak_fail();
3081         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3082         o->op_private |= OPpENTERSUB_AMPER;
3083         if (rv2cv_op_cv(o, 0)) croak_fail();
3084         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3085         o->op_private &= ~OPpENTERSUB_AMPER;
3086         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3087         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
3088         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3089         op_free(o);
3090         o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
3091         if (rv2cv_op_cv(o, 0)) croak_fail();
3092         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3093         op_free(o);
3094
3095 void
3096 test_cv_getset_call_checker()
3097     PREINIT:
3098         CV *troc_cv, *tsh_cv;
3099         Perl_call_checker ckfun;
3100         SV *ckobj;
3101         U32 ckflags;
3102     CODE:
3103 #define check_cc(cv, xckfun, xckobj, xckflags) \
3104     do { \
3105         cv_get_call_checker((cv), &ckfun, &ckobj); \
3106         if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \
3107         if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \
3108         cv_get_call_checker_flags((cv), CALL_CHECKER_REQUIRE_GV, &ckfun, &ckobj, &ckflags); \
3109         if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \
3110         if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \
3111         if (ckflags != CALL_CHECKER_REQUIRE_GV) croak_fail_nei(ckflags, CALL_CHECKER_REQUIRE_GV); \
3112         cv_get_call_checker_flags((cv), 0, &ckfun, &ckobj, &ckflags); \
3113         if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \
3114         if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \
3115         if (ckflags != (xckflags)) croak_fail_nei(ckflags, (xckflags)); \
3116     } while(0)
3117         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
3118         tsh_cv = get_cv("XS::APItest::test_savehints", 0);
3119         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
3120         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3121         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3122                                     &PL_sv_yes);
3123         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
3124         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3125         cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3126         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV);
3127         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3128         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3129                                     (SV*)tsh_cv);
3130         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV);
3131         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3132         cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
3133                                     (SV*)troc_cv);
3134         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0);
3135         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3136         if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
3137         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
3138         cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3139                                     &PL_sv_yes, 0);
3140         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 0);
3141         cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3142                                     &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3143         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3144         cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3145                                     (SV*)tsh_cv, 0);
3146         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3147         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
3148         cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3149                                     &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3150         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV);
3151         cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3152                                     (SV*)tsh_cv, CALL_CHECKER_REQUIRE_GV);
3153         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0);
3154         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
3155 #undef check_cc
3156
3157 void
3158 cv_set_call_checker_lists(CV *cv)
3159     CODE:
3160         cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
3161
3162 void
3163 cv_set_call_checker_scalars(CV *cv)
3164     CODE:
3165         cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
3166
3167 void
3168 cv_set_call_checker_proto(CV *cv, SV *proto)
3169     CODE:
3170         if (SvROK(proto))
3171             proto = SvRV(proto);
3172         cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
3173
3174 void
3175 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
3176     CODE:
3177         if (SvROK(proto))
3178             proto = SvRV(proto);
3179         cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
3180
3181 void
3182 cv_set_call_checker_multi_sum(CV *cv)
3183     CODE:
3184         cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
3185
3186 void
3187 test_cophh()
3188     PREINIT:
3189         COPHH *a, *b;
3190 #ifdef EBCDIC
3191         SV* key_sv;
3192         char * key_name;
3193         STRLEN key_len;
3194 #endif
3195     CODE:
3196 #define check_ph(EXPR) \
3197             do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
3198 #define check_iv(EXPR, EXPECT) \
3199             do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
3200 #define msvpvs(STR) sv_2mortal(newSVpvs(STR))
3201 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3202         a = cophh_new_empty();
3203         check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
3204         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3205         check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
3206         check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
3207         a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
3208         a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
3209         a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
3210         a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
3211         check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
3212         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3213         check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
3214         check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
3215         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3216         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3217         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3218         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3219         b = cophh_copy(a);
3220         b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
3221         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3222         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3223         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3224         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3225         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3226         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3227         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3228         check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
3229         check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
3230         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3231         a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
3232         a = cophh_delete_pvs(a, "foo_2", 0);
3233         b = cophh_delete_pv(b, "foo_3", 0, 0);
3234         b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
3235         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3236         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3237         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3238         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3239         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3240         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3241         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3242         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3243         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3244         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3245         b = cophh_delete_pvs(b, "foo_3", 0);
3246         b = cophh_delete_pvs(b, "foo_5", 0);
3247         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3248         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3249         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3250         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3251         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3252         cophh_free(b);
3253         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3254         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3255         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3256         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3257         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3258         a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
3259         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
3260 #ifndef EBCDIC
3261         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
3262 #else
3263         /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the
3264          * equivalent UTF-EBCDIC for the code page.  This is done at runtime
3265          * (with the helper function in this file).  Therefore we can't use
3266          * cophhh_store_pvs(), as we don't have literal string */
3267         key_sv = sv_2mortal(newSVpvs("foo_"));
3268         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3269         key_name = SvPV(key_sv, key_len);
3270         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3271 #endif
3272 #ifndef EBCDIC
3273         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
3274 #else
3275         sv_setpvs(key_sv, "foo_");
3276         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3277         key_name = SvPV(key_sv, key_len);
3278         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3279 #endif
3280 #ifndef EBCDIC
3281         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
3282 #else
3283         sv_setpvs(key_sv, "foo_");
3284         cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3285         key_name = SvPV(key_sv, key_len);
3286         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3287 #endif
3288         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
3289         check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
3290         check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
3291 #ifndef EBCDIC
3292         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
3293         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
3294 #else
3295         sv_setpvs(key_sv, "foo_");
3296         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa"));
3297         key_name = SvPV(key_sv, key_len);
3298         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123);
3299         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3300 #endif
3301         check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
3302 #ifndef EBCDIC
3303         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
3304         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
3305 #else
3306         sv_setpvs(key_sv, "foo_");
3307         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3308         key_name = SvPV(key_sv, key_len);
3309         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456);
3310         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3311 #endif
3312         check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
3313 #ifndef EBCDIC
3314         check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
3315         check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
3316 #else
3317         sv_setpvs(key_sv, "foo_");
3318         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3319         key_name = SvPV(key_sv, key_len);
3320         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789);
3321         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3322 #endif
3323 #ifndef EBCDIC
3324         check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
3325         check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
3326 #else
3327         sv_setpvs(key_sv, "foo_");
3328         cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3329         key_name = SvPV(key_sv, key_len);
3330         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666);
3331         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3332 #endif
3333         ENTER;
3334         SAVEFREECOPHH(a);
3335         LEAVE;
3336 #undef check_ph
3337 #undef check_iv
3338 #undef msvpvs
3339 #undef msviv
3340
3341 void
3342 test_coplabel()
3343     PREINIT:
3344         COP *cop;
3345         const char *label;
3346         STRLEN len;
3347         U32 utf8;
3348     CODE:
3349         cop = &PL_compiling;
3350         Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
3351         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3352         if (strNE(label,"foo")) croak("fail # cop_fetch_label label");
3353         if (len != 3) croak("fail # cop_fetch_label len");
3354         if (utf8) croak("fail # cop_fetch_label utf8");
3355         /* SMALL GERMAN UMLAUT A */
3356         Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
3357         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3358         if (strNE(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
3359         if (len != 4) croak("fail # cop_fetch_label len");
3360         if (!utf8) croak("fail # cop_fetch_label utf8");
3361
3362
3363 HV *
3364 example_cophh_2hv()
3365     PREINIT:
3366         COPHH *a;
3367 #ifdef EBCDIC
3368         SV* key_sv;
3369         char * key_name;
3370         STRLEN key_len;
3371 #endif
3372     CODE:
3373 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3374         a = cophh_new_empty();
3375         a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
3376         a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
3377         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
3378 #ifndef EBCDIC
3379         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
3380 #else
3381         key_sv = sv_2mortal(newSVpvs("foo_"));
3382         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3383         key_name = SvPV(key_sv, key_len);
3384         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3385 #endif
3386 #ifndef EBCDIC
3387         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
3388 #else
3389         sv_setpvs(key_sv, "foo_");
3390         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3391         key_name = SvPV(key_sv, key_len);
3392         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3393 #endif
3394 #ifndef EBCDIC
3395         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
3396 #else
3397         sv_setpvs(key_sv, "foo_");
3398         cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3399         key_name = SvPV(key_sv, key_len);
3400         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3401 #endif
3402         a = cophh_delete_pvs(a, "foo_0", 0);
3403         a = cophh_delete_pvs(a, "foo_2", 0);
3404         RETVAL = cophh_2hv(a, 0);
3405         cophh_free(a);
3406 #undef msviv
3407     OUTPUT:
3408         RETVAL
3409
3410 void
3411 test_savehints()
3412     PREINIT:
3413         SV **svp, *sv;
3414     CODE:
3415 #define store_hint(KEY, VALUE) \
3416                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
3417 #define hint_ok(KEY, EXPECT) \
3418                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
3419                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
3420                     (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
3421                     SvIV(sv) == (EXPECT))
3422 #define check_hint(KEY, EXPECT) \
3423                 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
3424         PL_hints |= HINT_LOCALIZE_HH;
3425         ENTER;
3426         SAVEHINTS();
3427         PL_hints &= HINT_INTEGER;
3428         store_hint("t0", 123);
3429         store_hint("t1", 456);
3430         if (PL_hints & HINT_INTEGER) croak_fail();
3431         check_hint("t0", 123); check_hint("t1", 456);
3432         ENTER;
3433         SAVEHINTS();
3434         if (PL_hints & HINT_INTEGER) croak_fail();
3435         check_hint("t0", 123); check_hint("t1", 456);
3436         PL_hints |= HINT_INTEGER;
3437         store_hint("t0", 321);
3438         if (!(PL_hints & HINT_INTEGER)) croak_fail();
3439         check_hint("t0", 321); check_hint("t1", 456);
3440         LEAVE;
3441         if (PL_hints & HINT_INTEGER) croak_fail();
3442         check_hint("t0", 123); check_hint("t1", 456);
3443         ENTER;
3444         SAVEHINTS();
3445         if (PL_hints & HINT_INTEGER) croak_fail();
3446         check_hint("t0", 123); check_hint("t1", 456);
3447         store_hint("t1", 654);
3448         if (PL_hints & HINT_INTEGER) croak_fail();
3449         check_hint("t0", 123); check_hint("t1", 654);
3450         LEAVE;
3451         if (PL_hints & HINT_INTEGER) croak_fail();
3452         check_hint("t0", 123); check_hint("t1", 456);
3453         LEAVE;
3454 #undef store_hint
3455 #undef hint_ok
3456 #undef check_hint
3457
3458 void
3459 test_copyhints()
3460     PREINIT:
3461         HV *a, *b;
3462     CODE:
3463         PL_hints |= HINT_LOCALIZE_HH;
3464         ENTER;
3465         SAVEHINTS();
3466         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
3467         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3468             croak_fail();
3469         a = newHVhv(GvHV(PL_hintgv));
3470         sv_2mortal((SV*)a);
3471         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
3472         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3473             croak_fail();
3474         b = hv_copy_hints_hv(a);
3475         sv_2mortal((SV*)b);
3476         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
3477         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
3478             croak_fail();
3479         LEAVE;
3480
3481 void
3482 test_op_list()
3483     PREINIT:
3484         OP *a;
3485     CODE:
3486 #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
3487 #define check_op(o, expect) \
3488     do { \
3489         if (strNE(test_op_list_describe(o), (expect))) \
3490             croak("fail %s %s", test_op_list_describe(o), (expect)); \
3491     } while(0)
3492         a = op_append_elem(OP_LIST, NULL, NULL);
3493         check_op(a, "");
3494         a = op_append_elem(OP_LIST, iv_op(1), a);
3495         check_op(a, "const(1).");
3496         a = op_append_elem(OP_LIST, NULL, a);
3497         check_op(a, "const(1).");
3498         a = op_append_elem(OP_LIST, a, iv_op(2));
3499         check_op(a, "list[pushmark.const(1).const(2).]");
3500         a = op_append_elem(OP_LIST, a, iv_op(3));
3501         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3502         a = op_append_elem(OP_LIST, a, NULL);
3503         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3504         a = op_append_elem(OP_LIST, NULL, a);
3505         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3506         a = op_append_elem(OP_LIST, iv_op(4), a);
3507         check_op(a, "list[pushmark.const(4)."
3508                 "list[pushmark.const(1).const(2).const(3).]]");
3509         a = op_append_elem(OP_LIST, a, iv_op(5));
3510         check_op(a, "list[pushmark.const(4)."
3511                 "list[pushmark.const(1).const(2).const(3).]const(5).]");
3512         a = op_append_elem(OP_LIST, a, 
3513                 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
3514         check_op(a, "list[pushmark.const(4)."
3515                 "list[pushmark.const(1).const(2).const(3).]const(5)."
3516                 "list[pushmark.const(7).const(6).]]");
3517         op_free(a);
3518         a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
3519         check_op(a, "lineseq[const(1).const(2).]");
3520         a = op_append_elem(OP_LINESEQ, a, iv_op(3));
3521         check_op(a, "lineseq[const(1).const(2).const(3).]");
3522         op_free(a);
3523         a = op_append_elem(OP_LINESEQ,
3524                 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
3525                 iv_op(3));
3526         check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
3527         op_free(a);
3528         a = op_prepend_elem(OP_LIST, NULL, NULL);
3529         check_op(a, "");
3530         a = op_prepend_elem(OP_LIST, a, iv_op(1));
3531         check_op(a, "const(1).");
3532         a = op_prepend_elem(OP_LIST, a, NULL);
3533         check_op(a, "const(1).");
3534         a = op_prepend_elem(OP_LIST, iv_op(2), a);
3535         check_op(a, "list[pushmark.const(2).const(1).]");
3536         a = op_prepend_elem(OP_LIST, iv_op(3), a);
3537         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3538         a = op_prepend_elem(OP_LIST, NULL, a);
3539         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3540         a = op_prepend_elem(OP_LIST, a, NULL);
3541         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3542         a = op_prepend_elem(OP_LIST, a, iv_op(4));
3543         check_op(a, "list[pushmark."
3544                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3545         a = op_prepend_elem(OP_LIST, iv_op(5), a);
3546         check_op(a, "list[pushmark.const(5)."
3547                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3548         a = op_prepend_elem(OP_LIST,
3549                 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
3550         check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
3551                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3552         op_free(a);
3553         a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
3554         check_op(a, "lineseq[const(2).const(1).]");
3555         a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
3556         check_op(a, "lineseq[const(3).const(2).const(1).]");
3557         op_free(a);
3558         a = op_prepend_elem(OP_LINESEQ, iv_op(3),
3559                 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
3560         check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
3561         op_free(a);
3562         a = op_append_list(OP_LINESEQ, NULL, NULL);
3563         check_op(a, "");
3564         a = op_append_list(OP_LINESEQ, iv_op(1), a);
3565         check_op(a, "const(1).");
3566         a = op_append_list(OP_LINESEQ, NULL, a);
3567         check_op(a, "const(1).");
3568         a = op_append_list(OP_LINESEQ, a, iv_op(2));
3569         check_op(a, "lineseq[const(1).const(2).]");
3570         a = op_append_list(OP_LINESEQ, a, iv_op(3));
3571         check_op(a, "lineseq[const(1).const(2).const(3).]");
3572         a = op_append_list(OP_LINESEQ, iv_op(4), a);
3573         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3574         a = op_append_list(OP_LINESEQ, a, NULL);
3575         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3576         a = op_append_list(OP_LINESEQ, NULL, a);
3577         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3578         a = op_append_list(OP_LINESEQ, a,
3579                 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
3580         check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
3581                 "const(5).const(6).]");
3582         op_free(a);
3583         a = op_append_list(OP_LINESEQ,
3584                 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
3585                 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
3586         check_op(a, "lineseq[const(1).const(2)."
3587                 "list[pushmark.const(3).const(4).]]");
3588         op_free(a);
3589         a = op_append_list(OP_LINESEQ,
3590                 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
3591                 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
3592         check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
3593                 "const(3).const(4).]");
3594         op_free(a);
3595 #undef check_op
3596
3597 void
3598 test_op_linklist ()
3599     PREINIT:
3600         OP *o;
3601     CODE:
3602 #define check_ll(o, expect) \
3603     STMT_START { \
3604         if (strNE(test_op_linklist_describe(o), (expect))) \
3605             croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
3606     } STMT_END
3607         o = iv_op(1);
3608         check_ll(o, ".const1");
3609         op_free(o);
3610
3611         o = mkUNOP(OP_NOT, iv_op(1));
3612         check_ll(o, ".const1.not");
3613         op_free(o);
3614
3615         o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
3616         check_ll(o, ".const1.negate.not");
3617         op_free(o);
3618
3619         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3620         check_ll(o, ".const1.const2.add");
3621         op_free(o);
3622
3623         o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
3624         check_ll(o, ".const1.not.const2.add");
3625         op_free(o);
3626
3627         o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
3628         check_ll(o, ".const1.const2.add.not");
3629         op_free(o);
3630
3631         o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
3632         check_ll(o, ".const1.const2.const3.lineseq");
3633         op_free(o);
3634
3635         o = mkLISTOP(OP_LINESEQ,
3636                 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
3637                 mkUNOP(OP_NOT, iv_op(3)),
3638                 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
3639         check_ll(o, ".const1.const2.add.const3.not"
3640                     ".const4.const5.const6.substr.lineseq");
3641         op_free(o);
3642
3643         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3644         LINKLIST(o);
3645         o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
3646         check_ll(o, ".const1.const2.add.const3.subtract");
3647         op_free(o);
3648 #undef check_ll
3649 #undef iv_op
3650
3651 void
3652 peep_enable ()
3653     PREINIT:
3654         dMY_CXT;
3655     CODE:
3656         av_clear(MY_CXT.peep_recorder);
3657         av_clear(MY_CXT.rpeep_recorder);
3658         MY_CXT.peep_recording = 1;
3659
3660 void
3661 peep_disable ()
3662     PREINIT:
3663         dMY_CXT;
3664     CODE:
3665         MY_CXT.peep_recording = 0;
3666
3667 SV *
3668 peep_record ()
3669     PREINIT:
3670         dMY_CXT;
3671     CODE:
3672         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
3673     OUTPUT:
3674         RETVAL
3675
3676 SV *
3677 rpeep_record ()
3678     PREINIT:
3679         dMY_CXT;
3680     CODE:
3681         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
3682     OUTPUT:
3683         RETVAL
3684
3685 =pod
3686
3687 multicall_each: call a sub for each item in the list. Used to test MULTICALL
3688
3689 =cut
3690
3691 void
3692 multicall_each(block,...)
3693     SV * block
3694 PROTOTYPE: &@
3695 CODE:
3696 {
3697     dMULTICALL;
3698     int index;
3699     GV *gv;
3700     HV *stash;
3701     I32 gimme = G_SCALAR;
3702     SV **args = &PL_stack_base[ax];
3703     CV *cv;
3704
3705     if(items <= 1) {
3706         XSRETURN_UNDEF;
3707     }
3708     cv = sv_2cv(block, &stash, &gv, 0);
3709     if (cv == Nullcv) {
3710        croak("multicall_each: not a subroutine reference");
3711     }
3712     PUSH_MULTICALL(cv);
3713     SAVESPTR(GvSV(PL_defgv));
3714
3715     for(index = 1 ; index < items ; index++) {
3716         GvSV(PL_defgv) = args[index];
3717         MULTICALL;
3718     }
3719     POP_MULTICALL;
3720     XSRETURN_UNDEF;
3721 }
3722
3723 =pod
3724
3725 multicall_return(): call the passed sub once in the specificed context
3726 and return whatever it returns
3727
3728 =cut
3729
3730 void
3731 multicall_return(block, context)
3732     SV *block
3733     I32 context
3734 PROTOTYPE: &$
3735 CODE:
3736 {
3737     dSP;
3738     dMULTICALL;
3739     GV *gv;
3740     HV *stash;
3741     I32 gimme = context;
3742     CV *cv;
3743     AV *av;
3744     SV **p;
3745     SSize_t i, size;
3746
3747     cv = sv_2cv(block, &stash, &gv, 0);
3748     if (cv == Nullcv) {
3749        croak("multicall_return not a subroutine reference");
3750     }
3751     PUSH_MULTICALL(cv);
3752
3753     MULTICALL;
3754
3755     /* copy returned values into an array so they're not freed during
3756      * POP_MULTICALL */
3757
3758     av = newAV();
3759     SPAGAIN;
3760
3761     switch (context) {
3762     case G_VOID:
3763         break;
3764
3765     case G_SCALAR:
3766         av_push(av, SvREFCNT_inc(TOPs));
3767         break;
3768
3769     case G_ARRAY:
3770         for (p = PL_stack_base + 1; p <= SP; p++)
3771             av_push(av, SvREFCNT_inc(*p));
3772         break;
3773     }
3774
3775     POP_MULTICALL;
3776
3777     size = AvFILLp(av) + 1;
3778     EXTEND(SP, size);
3779     for (i = 0; i < size; i++)
3780         ST(i) = *av_fetch(av, i, FALSE);
3781     sv_2mortal((SV*)av);
3782     XSRETURN(size);
3783 }
3784
3785
3786 #ifdef USE_ITHREADS
3787
3788 void
3789 clone_with_stack()
3790 CODE:
3791 {
3792     PerlInterpreter *interp = aTHX; /* The original interpreter */
3793     PerlInterpreter *interp_dup;    /* The duplicate interpreter */
3794     int oldscope = 1; /* We are responsible for all scopes */
3795
3796     interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
3797
3798     /* destroy old perl */
3799     PERL_SET_CONTEXT(interp);
3800
3801     POPSTACK_TO(PL_mainstack);
3802     if (cxstack_ix >= 0) {
3803         dounwind(-1);
3804         cx_popblock(cxstack);
3805     }
3806     LEAVE_SCOPE(0);
3807     PL_scopestack_ix = oldscope;
3808     FREETMPS;
3809
3810     perl_destruct(interp);
3811     perl_free(interp);
3812
3813     /* switch to new perl */
3814     PERL_SET_CONTEXT(interp_dup);
3815
3816     /* continue after 'clone_with_stack' */
3817     if (interp_dup->Iop)
3818         interp_dup->Iop = interp_dup->Iop->op_next;
3819
3820     /* run with new perl */
3821     Perl_runops_standard(interp_dup);
3822
3823     /* We may have additional unclosed scopes if fork() was called
3824      * from within a BEGIN block.  See perlfork.pod for more details.
3825      * We cannot clean up these other scopes because they belong to a
3826      * different interpreter, but we also cannot leave PL_scopestack_ix
3827      * dangling because that can trigger an assertion in perl_destruct().
3828      */
3829     if (PL_scopestack_ix > oldscope) {
3830         PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
3831         PL_scopestack_ix = oldscope;
3832     }
3833
3834     perl_destruct(interp_dup);
3835     perl_free(interp_dup);
3836
3837     /* call the real 'exit' not PerlProc_exit */
3838 #undef exit
3839     exit(0);
3840 }
3841
3842 #endif /* USE_ITHREDS */
3843
3844 SV*
3845 take_svref(SVREF sv)
3846 CODE:
3847     RETVAL = newRV_inc(sv);
3848 OUTPUT:
3849     RETVAL
3850
3851 SV*
3852 take_avref(AV* av)
3853 CODE:
3854     RETVAL = newRV_inc((SV*)av);
3855 OUTPUT:
3856     RETVAL
3857
3858 SV*
3859 take_hvref(HV* hv)
3860 CODE:
3861     RETVAL = newRV_inc((SV*)hv);
3862 OUTPUT:
3863     RETVAL
3864
3865
3866 SV*
3867 take_cvref(CV* cv)
3868 CODE:
3869     RETVAL = newRV_inc((SV*)cv);
3870 OUTPUT:
3871     RETVAL
3872
3873
3874 BOOT:
3875         {
3876         HV* stash;
3877         SV** meth = NULL;
3878         CV* cv;
3879         stash = gv_stashpv("XS::APItest::TempLv", 0);
3880         if (stash)
3881             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
3882         if (!meth)
3883             croak("lost method 'make_temp_mg_lv'");
3884         cv = GvCV(*meth);
3885         CvLVALUE_on(cv);
3886         }
3887
3888 BOOT:
3889 {
3890     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
3891     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
3892     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
3893     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
3894     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
3895     hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
3896     hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
3897     hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
3898     hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
3899     hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
3900     hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
3901     hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
3902     hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
3903     hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
3904     hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
3905     hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
3906     hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
3907     hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
3908     hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
3909     hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
3910     wrap_keyword_plugin(my_keyword_plugin, &next_keyword_plugin);
3911 }
3912
3913 void
3914 establish_cleanup(...)
3915 PROTOTYPE: $
3916 CODE:
3917     PERL_UNUSED_VAR(items);
3918     croak("establish_cleanup called as a function");
3919
3920 BOOT:
3921 {
3922     CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
3923     cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
3924 }
3925
3926 void
3927 postinc(...)
3928 PROTOTYPE: $
3929 CODE:
3930     PERL_UNUSED_VAR(items);
3931     croak("postinc called as a function");
3932
3933 void
3934 filter()
3935 CODE:
3936     filter_add(filter_call, NULL);
3937
3938 BOOT:
3939 {
3940     CV *asscv = get_cv("XS::APItest::postinc", 0);
3941     cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
3942 }
3943
3944 SV *
3945 lv_temp_object()
3946 CODE:
3947     RETVAL =
3948           sv_bless(
3949             newRV_noinc(newSV(0)),
3950             gv_stashpvs("XS::APItest::TempObj",GV_ADD)
3951           );             /* Package defined in test script */
3952 OUTPUT:
3953     RETVAL
3954
3955 void
3956 fill_hash_with_nulls(HV *hv)
3957 PREINIT:
3958     UV i = 0;
3959 CODE:
3960     for(; i < 1000; ++i) {
3961         HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
3962         SvREFCNT_dec(HeVAL(entry));
3963         HeVAL(entry) = NULL;
3964     }
3965
3966 HV *
3967 newHVhv(HV *hv)
3968 CODE:
3969     RETVAL = newHVhv(hv);
3970 OUTPUT:
3971     RETVAL
3972
3973 U32
3974 SvIsCOW(SV *sv)
3975 CODE:
3976     RETVAL = SvIsCOW(sv);
3977 OUTPUT:
3978     RETVAL
3979
3980 void
3981 pad_scalar(...)
3982 PROTOTYPE: $$
3983 CODE:
3984     PERL_UNUSED_VAR(items);
3985     croak("pad_scalar called as a function");
3986
3987 BOOT:
3988 {
3989     CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
3990     cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
3991 }
3992
3993 SV*
3994 fetch_pad_names( cv )
3995 CV* cv
3996  PREINIT:
3997   I32 i;
3998   PADNAMELIST *pad_namelist;
3999   AV *retav = newAV();
4000  CODE:
4001   pad_namelist = PadlistNAMES(CvPADLIST(cv));
4002
4003   for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
4004     PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
4005
4006     if (PadnameLEN(name)) {
4007         av_push(retav, newSVpadname(name));
4008     }
4009   }
4010   RETVAL = newRV_noinc((SV*)retav);
4011  OUTPUT:
4012   RETVAL
4013
4014 STRLEN
4015 underscore_length()
4016 PROTOTYPE:
4017 PREINIT:
4018     SV *u;
4019     U8 *pv;
4020     STRLEN bytelen;
4021 CODE:
4022     u = find_rundefsv();
4023     pv = (U8*)SvPV(u, bytelen);
4024     RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
4025 OUTPUT:
4026     RETVAL
4027
4028 void
4029 stringify(SV *sv)
4030 CODE:
4031     (void)SvPV_nolen(sv);
4032
4033 SV *
4034 HvENAME(HV *hv)
4035 CODE:
4036     RETVAL = hv && HvENAME(hv)
4037               ? newSVpvn_flags(
4038                   HvENAME(hv),HvENAMELEN(hv),
4039                   (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
4040                 )
4041               : NULL;
4042 OUTPUT:
4043     RETVAL
4044
4045 int
4046 xs_cmp(int a, int b)
4047 CODE:
4048     /* Odd sorting (odd numbers first), to make sure we are actually
4049        being called */
4050     RETVAL = a % 2 != b % 2
4051                ? a % 2 ? -1 : 1
4052                : a < b ? -1 : a == b ? 0 : 1;
4053 OUTPUT:
4054     RETVAL
4055
4056 SV *
4057 xs_cmp_undef(SV *a, SV *b)
4058 CODE:
4059     PERL_UNUSED_ARG(a);
4060     PERL_UNUSED_ARG(b);
4061     RETVAL = &PL_sv_undef;
4062 OUTPUT:
4063     RETVAL
4064
4065 char *
4066 SvPVbyte(SV *sv)
4067 CODE:
4068     RETVAL = SvPVbyte_nolen(sv);
4069 OUTPUT:
4070     RETVAL
4071
4072 char *
4073 SvPVutf8(SV *sv)
4074 CODE:
4075     RETVAL = SvPVutf8_nolen(sv);
4076 OUTPUT:
4077     RETVAL
4078
4079 void
4080 setup_addissub()
4081 CODE:
4082     wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
4083
4084 void
4085 setup_rv2cv_addunderbar()
4086 CODE:
4087     wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv);
4088
4089 #ifdef USE_ITHREADS
4090
4091 bool
4092 test_alloccopstash()
4093 CODE:
4094     RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
4095 OUTPUT:
4096     RETVAL
4097
4098 #endif
4099
4100 bool
4101 test_newFOROP_without_slab()
4102 CODE:
4103     {
4104         const I32 floor = start_subparse(0,0);
4105         OP *o;
4106         /* The slab allocator does not like CvROOT being set. */
4107         CvROOT(PL_compcv) = (OP *)1;
4108         o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0);
4109 #ifdef PERL_OP_PARENT
4110         if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent
4111                 != cUNOPo->op_first)
4112         {
4113             Perl_warn(aTHX_ "Op parent pointer is stale");
4114             RETVAL = FALSE;
4115         }
4116         else
4117 #endif
4118             /* If we do not crash before returning, the test passes. */
4119             RETVAL = TRUE;
4120         op_free(o);
4121         CvROOT(PL_compcv) = NULL;
4122         SvREFCNT_dec(PL_compcv);
4123         LEAVE_SCOPE(floor);
4124     }
4125 OUTPUT:
4126     RETVAL
4127
4128  # provide access to CALLREGEXEC, except replace pointers within the
4129  # string with offsets from the start of the string
4130
4131 I32
4132 callregexec(SV *prog, STRLEN stringarg, STRLEN strend, I32 minend, SV *sv, U32 nosave)
4133 CODE:
4134     {
4135         STRLEN len;
4136         char *strbeg;
4137         if (SvROK(prog))
4138             prog = SvRV(prog);
4139         strbeg = SvPV_force(sv, len);
4140         RETVAL = CALLREGEXEC((REGEXP *)prog,
4141                             strbeg + stringarg,
4142                             strbeg + strend,
4143                             strbeg,
4144                             minend,
4145                             sv,
4146                             NULL, /* data */
4147                             nosave);
4148     }
4149 OUTPUT:
4150     RETVAL
4151
4152 void
4153 lexical_import(SV *name, CV *cv)
4154     CODE:
4155     {
4156         PADLIST *pl;
4157         PADOFFSET off;
4158         if (!PL_compcv)
4159             Perl_croak(aTHX_
4160                       "lexical_import can only be called at compile time");
4161         pl = CvPADLIST(PL_compcv);
4162         ENTER;
4163         SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl);
4164         SAVESPTR(PL_comppad);      PL_comppad      = PadlistARRAY(pl)[1];
4165         SAVESPTR(PL_curpad);       PL_curpad       = PadARRAY(PL_comppad);
4166         off = pad_add_name_sv(sv_2mortal(newSVpvf("&%" SVf,name)),
4167                               padadd_STATE, 0, 0);
4168         SvREFCNT_dec(PL_curpad[off]);
4169         PL_curpad[off] = SvREFCNT_inc(cv);
4170         intro_my();
4171         LEAVE;
4172     }
4173
4174 SV *
4175 sv_mortalcopy(SV *sv)
4176     CODE:
4177         RETVAL = SvREFCNT_inc(sv_mortalcopy(sv));
4178     OUTPUT:
4179         RETVAL
4180
4181 SV *
4182 newRV(SV *sv)
4183
4184 void
4185 alias_av(AV *av, IV ix, SV *sv)
4186     CODE:
4187         av_store(av, ix, SvREFCNT_inc(sv));
4188
4189 SV *
4190 cv_name(SVREF ref, ...)
4191     CODE:
4192         RETVAL = SvREFCNT_inc(cv_name((CV *)ref,
4193                                       items>1 && ST(1) != &PL_sv_undef
4194                                         ? ST(1)
4195                                         : NULL,
4196                                       items>2 ? SvUV(ST(2)) : 0));
4197     OUTPUT:
4198         RETVAL
4199
4200 void
4201 sv_catpvn(SV *sv, SV *sv2)
4202     CODE:
4203     {
4204         STRLEN len;
4205         const char *s = SvPV(sv2,len);
4206         sv_catpvn_flags(sv,s,len, SvUTF8(sv2) ? SV_CATUTF8 : SV_CATBYTES);
4207     }
4208
4209 bool
4210 test_newOP_CUSTOM()
4211     CODE:
4212     {
4213         OP *o = newLISTOP(OP_CUSTOM, 0, NULL, NULL);
4214         op_free(o);
4215         o = newOP(OP_CUSTOM, 0);
4216         op_free(o);
4217         o = newUNOP(OP_CUSTOM, 0, NULL);
4218         op_free(o);
4219         o = newUNOP_AUX(OP_CUSTOM, 0, NULL, NULL);
4220         op_free(o);
4221         o = newMETHOP(OP_CUSTOM, 0, newOP(OP_NULL,0));
4222         op_free(o);
4223         o = newMETHOP_named(OP_CUSTOM, 0, newSV(0));
4224         op_free(o);
4225         o = newBINOP(OP_CUSTOM, 0, NULL, NULL);
4226         op_free(o);
4227         o = newPMOP(OP_CUSTOM, 0);
4228         op_free(o);
4229         o = newSVOP(OP_CUSTOM, 0, newSV(0));
4230         op_free(o);
4231 #ifdef USE_ITHREADS
4232         ENTER;
4233         lex_start(NULL, NULL, 0);
4234         {
4235             I32 ix = start_subparse(FALSE,0);
4236             o = newPADOP(OP_CUSTOM, 0, newSV(0));
4237             op_free(o);
4238             LEAVE_SCOPE(ix);
4239         }
4240         LEAVE;
4241 #endif
4242         o = newPVOP(OP_CUSTOM, 0, NULL);
4243         op_free(o);
4244         o = newLOGOP(OP_CUSTOM, 0, newOP(OP_NULL,0), newOP(OP_NULL,0));
4245         op_free(o);
4246         o = newLOOPEX(OP_CUSTOM, newOP(OP_NULL,0));
4247         op_free(o);
4248         RETVAL = TRUE;
4249     }
4250     OUTPUT:
4251         RETVAL
4252
4253 void
4254 test_sv_catpvf(SV *fmtsv)
4255     PREINIT:
4256         SV *sv;
4257         char *fmt;
4258     CODE:
4259         fmt = SvPV_nolen(fmtsv);
4260         sv = sv_2mortal(newSVpvn("", 0));
4261         sv_catpvf(sv, fmt, 5, 6, 7, 8);
4262
4263 void
4264 load_module(flags, name, ...)
4265     U32 flags
4266     SV *name
4267 CODE:
4268     if (items == 2) {
4269         Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL);
4270     } else if (items == 3) {
4271         Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2)));
4272     } else
4273         Perl_croak(aTHX_ "load_module can't yet support %" IVdf " items",
4274                           (IV)items);
4275
4276 SV *
4277 string_without_null(SV *sv)
4278     CODE:
4279     {
4280         STRLEN len;
4281         const char *s = SvPV(sv, len);
4282         RETVAL = newSVpvn_flags(s, len, SvUTF8(sv));
4283         *SvEND(RETVAL) = 0xff;
4284     }
4285     OUTPUT:
4286         RETVAL
4287
4288 CV *
4289 get_cv(SV *sv)
4290     CODE:
4291     {
4292         STRLEN len;
4293         const char *s = SvPV(sv, len);
4294         RETVAL = get_cvn_flags(s, len, 0);
4295     }
4296     OUTPUT:
4297         RETVAL
4298
4299 CV *
4300 get_cv_flags(SV *sv, UV flags)
4301     CODE:
4302     {
4303         STRLEN len;
4304         const char *s = SvPV(sv, len);
4305         RETVAL = get_cvn_flags(s, len, flags);
4306     }
4307     OUTPUT:
4308         RETVAL
4309
4310 PerlIO *
4311 PerlIO_stderr()
4312
4313 OutputStream
4314 PerlIO_stdout()
4315
4316 InputStream
4317 PerlIO_stdin()
4318
4319 #undef FILE
4320 #define FILE NativeFile
4321
4322 FILE *
4323 PerlIO_exportFILE(PerlIO *f, const char *mode)
4324
4325 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
4326
4327 int
4328 AUTOLOAD(...)
4329   INIT:
4330     SV* comms;
4331     SV* class_and_method;
4332   CODE:
4333     PERL_UNUSED_ARG(items);
4334     class_and_method = GvSV(CvGV(cv));
4335     comms = get_sv("main::the_method", 1);
4336     if (class_and_method == NULL) {
4337       RETVAL = 1;
4338     } else if (!SvOK(class_and_method)) {
4339       RETVAL = 2;
4340     } else if (!SvPOK(class_and_method)) {
4341       RETVAL = 3;
4342     } else {
4343       sv_setsv(comms, class_and_method);
4344       RETVAL = 0;
4345     }
4346   OUTPUT: RETVAL
4347
4348
4349 MODULE = XS::APItest            PACKAGE = XS::APItest::Magic
4350
4351 PROTOTYPES: DISABLE
4352
4353 void
4354 sv_magic_foo(SV *sv, SV *thingy)
4355 ALIAS:
4356     sv_magic_bar = 1
4357 CODE:
4358     sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
4359
4360 SV *
4361 mg_find_foo(SV *sv)
4362 ALIAS:
4363     mg_find_bar = 1
4364 CODE:
4365     MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
4366     RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef;
4367 OUTPUT:
4368     RETVAL
4369
4370 void
4371 sv_unmagic_foo(SV *sv)
4372 ALIAS:
4373     sv_unmagic_bar = 1
4374 CODE:
4375     sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
4376
4377 void
4378 sv_magic(SV *sv, SV *thingy)
4379 CODE:
4380     sv_magic(SvRV(sv), NULL, PERL_MAGIC_ext, (const char *)thingy, 0);
4381
4382 UV
4383 test_get_vtbl()
4384     PREINIT:
4385         MGVTBL *have;
4386         MGVTBL *want;
4387     CODE:
4388 #define test_get_this_vtable(name) \
4389         want = (MGVTBL*)CAT2(&PL_vtbl_, name); \
4390         have = get_vtbl(CAT2(want_vtbl_, name)); \
4391         if (have != want) \
4392             croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
4393
4394         test_get_this_vtable(sv);
4395         test_get_this_vtable(env);
4396         test_get_this_vtable(envelem);
4397         test_get_this_vtable(sigelem);
4398         test_get_this_vtable(pack);
4399         test_get_this_vtable(packelem);
4400         test_get_this_vtable(dbline);
4401         test_get_this_vtable(isa);
4402         test_get_this_vtable(isaelem);
4403         test_get_this_vtable(arylen);
4404         test_get_this_vtable(mglob);
4405         test_get_this_vtable(nkeys);
4406         test_get_this_vtable(taint);
4407         test_get_this_vtable(substr);
4408         test_get_this_vtable(vec);
4409         test_get_this_vtable(pos);
4410         test_get_this_vtable(bm);
4411         test_get_this_vtable(fm);
4412         test_get_this_vtable(uvar);
4413         test_get_this_vtable(defelem);
4414         test_get_this_vtable(regexp);
4415         test_get_this_vtable(regdata);
4416         test_get_this_vtable(regdatum);
4417 #ifdef USE_LOCALE_COLLATE
4418         test_get_this_vtable(collxfrm);
4419 #endif
4420         test_get_this_vtable(backref);
4421         test_get_this_vtable(utf8);
4422
4423         RETVAL = PTR2UV(get_vtbl(-1));
4424     OUTPUT:
4425         RETVAL
4426
4427
4428     # attach ext magic to the SV pointed to by rsv that only has set magic,
4429     # where that magic's job is to increment thingy
4430
4431 void
4432 sv_magic_myset(SV *rsv, SV *thingy)
4433 CODE:
4434     sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset,
4435         (const char *)thingy, 0);
4436
4437
4438
4439 bool
4440 test_isBLANK_uni(UV ord)
4441     CODE:
4442         RETVAL = isBLANK_uni(ord);
4443     OUTPUT:
4444         RETVAL
4445
4446 bool
4447 test_isBLANK_uvchr(UV ord)
4448     CODE:
4449         RETVAL = isBLANK_uvchr(ord);
4450     OUTPUT:
4451         RETVAL
4452
4453 bool
4454 test_isBLANK_LC_uvchr(UV ord)
4455     CODE:
4456         RETVAL = isBLANK_LC_uvchr(ord);
4457     OUTPUT:
4458         RETVAL
4459
4460 bool
4461 test_isBLANK(UV ord)
4462     CODE:
4463         RETVAL = isBLANK(ord);
4464     OUTPUT:
4465         RETVAL
4466
4467 bool
4468 test_isBLANK_A(UV ord)
4469     CODE:
4470         RETVAL = isBLANK_A(ord);
4471     OUTPUT:
4472         RETVAL
4473
4474 bool
4475 test_isBLANK_L1(UV ord)
4476     CODE:
4477         RETVAL = isBLANK_L1(ord);
4478     OUTPUT:
4479         RETVAL
4480
4481 bool
4482 test_isBLANK_LC(UV ord)
4483     CODE:
4484         RETVAL = isBLANK_LC(ord);
4485     OUTPUT:
4486         RETVAL
4487
4488 bool
4489 test_isBLANK_utf8(unsigned char * p, int type)
4490     PREINIT:
4491         const unsigned char * e;
4492     CODE:
4493
4494         /* In this function and those that follow, the boolean 'type'
4495          * indicates if to pass a malformed UTF-8 string to the tested macro
4496          * (malformed by making it too short) */
4497         if (type >= 0) {
4498             e = p + UTF8SKIP(p) - type;
4499             RETVAL = isBLANK_utf8_safe(p, e);
4500         }
4501         else {
4502             RETVAL = isBLANK_utf8(p);
4503         }
4504     OUTPUT:
4505         RETVAL
4506
4507 bool
4508 test_isBLANK_LC_utf8(unsigned char * p, int type)
4509     PREINIT:
4510         const unsigned char * e;
4511     CODE:
4512         if (type >= 0) {
4513             e = p + UTF8SKIP(p) - type;
4514             RETVAL = isBLANK_LC_utf8_safe(p, e);
4515         }
4516         else {
4517             RETVAL = isBLANK_LC_utf8(p);
4518         }
4519     OUTPUT:
4520         RETVAL
4521
4522 bool
4523 test_isVERTWS_uni(UV ord)
4524     CODE:
4525         RETVAL = isVERTWS_uni(ord);
4526     OUTPUT:
4527         RETVAL
4528
4529 bool
4530 test_isVERTWS_uvchr(UV ord)
4531     CODE:
4532         RETVAL = isVERTWS_uvchr(ord);
4533     OUTPUT:
4534         RETVAL
4535
4536 bool
4537 test_isVERTWS_utf8(unsigned char * p, int type)
4538     PREINIT:
4539         const unsigned char * e;
4540     CODE:
4541         if (type >= 0) {
4542             e = p + UTF8SKIP(p) - type;
4543             RETVAL = isVERTWS_utf8_safe(p, e);
4544         }
4545         else {
4546             RETVAL = isVERTWS_utf8(p);
4547         }
4548     OUTPUT:
4549         RETVAL
4550
4551 bool
4552 test_isUPPER_uni(UV ord)
4553     CODE:
4554         RETVAL = isUPPER_uni(ord);
4555     OUTPUT:
4556         RETVAL
4557
4558 bool
4559 test_isUPPER_uvchr(UV ord)
4560     CODE:
4561         RETVAL = isUPPER_uvchr(ord);
4562     OUTPUT:
4563         RETVAL
4564
4565 bool
4566 test_isUPPER_LC_uvchr(UV ord)
4567     CODE:
4568         RETVAL = isUPPER_LC_uvchr(ord);
4569     OUTPUT:
4570         RETVAL
4571
4572 bool
4573 test_isUPPER(UV ord)
4574     CODE:
4575         RETVAL = isUPPER(ord);
4576     OUTPUT:
4577         RETVAL
4578
4579 bool
4580 test_isUPPER_A(UV ord)
4581     CODE:
4582         RETVAL = isUPPER_A(ord);
4583     OUTPUT:
4584         RETVAL
4585
4586 bool
4587 test_isUPPER_L1(UV ord)
4588     CODE:
4589         RETVAL = isUPPER_L1(ord);
4590     OUTPUT:
4591         RETVAL
4592
4593 bool
4594 test_isUPPER_LC(UV ord)
4595     CODE:
4596         RETVAL = isUPPER_LC(ord);
4597     OUTPUT:
4598         RETVAL
4599
4600 bool
4601 test_isUPPER_utf8(unsigned char * p, int type)
4602     PREINIT:
4603         const unsigned char * e;
4604     CODE:
4605         if (type >= 0) {
4606             e = p + UTF8SKIP(p) - type;
4607             RETVAL = isUPPER_utf8_safe(p, e);
4608         }
4609         else {
4610             RETVAL = isUPPER_utf8(p);
4611         }
4612     OUTPUT:
4613         RETVAL
4614
4615 bool
4616 test_isUPPER_LC_utf8(unsigned char * p, int type)
4617     PREINIT:
4618         const unsigned char * e;
4619     CODE:
4620         if (type >= 0) {
4621             e = p + UTF8SKIP(p) - type;
4622             RETVAL = isUPPER_LC_utf8_safe(p, e);
4623         }
4624         else {
4625             RETVAL = isUPPER_LC_utf8(p);
4626         }
4627     OUTPUT:
4628         RETVAL
4629
4630 bool
4631 test_isLOWER_uni(UV ord)
4632     CODE:
4633         RETVAL = isLOWER_uni(ord);
4634     OUTPUT:
4635         RETVAL
4636
4637 bool
4638 test_isLOWER_uvchr(UV ord)
4639     CODE:
4640         RETVAL = isLOWER_uvchr(ord);
4641     OUTPUT:
4642         RETVAL
4643
4644 bool
4645 test_isLOWER_LC_uvchr(UV ord)
4646     CODE:
4647         RETVAL = isLOWER_LC_uvchr(ord);
4648     OUTPUT:
4649         RETVAL
4650
4651 bool
4652 test_isLOWER(UV ord)
4653     CODE:
4654         RETVAL = isLOWER(ord);
4655     OUTPUT:
4656         RETVAL
4657
4658 bool
4659 test_isLOWER_A(UV ord)
4660     CODE:
4661         RETVAL = isLOWER_A(ord);
4662     OUTPUT:
4663         RETVAL
4664
4665 bool
4666 test_isLOWER_L1(UV ord)
4667     CODE:
4668         RETVAL = isLOWER_L1(ord);
4669     OUTPUT:
4670         RETVAL
4671
4672 bool
4673 test_isLOWER_LC(UV ord)
4674     CODE:
4675         RETVAL = isLOWER_LC(ord);
4676     OUTPUT:
4677         RETVAL
4678
4679 bool
4680 test_isLOWER_utf8(unsigned char * p, int type)
4681     PREINIT:
4682         const unsigned char * e;
4683     CODE:
4684         if (type >= 0) {
4685             e = p + UTF8SKIP(p) - type;
4686             RETVAL = isLOWER_utf8_safe(p, e);
4687         }
4688         else {
4689             RETVAL = isLOWER_utf8(p);
4690         }
4691     OUTPUT:
4692         RETVAL
4693
4694 bool
4695 test_isLOWER_LC_utf8(unsigned char * p, int type)
4696     PREINIT:
4697         const unsigned char * e;
4698     CODE:
4699         if (type >= 0) {
4700             e = p + UTF8SKIP(p) - type;
4701             RETVAL = isLOWER_LC_utf8_safe(p, e);
4702         }
4703         else {
4704             RETVAL = isLOWER_LC_utf8(p);
4705         }
4706     OUTPUT: