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