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