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