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