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