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