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