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