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