This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5498a4cb055c6db2081d8510d4c04a90ffa7f670
[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     SV   *my_sv = FILTER_DATA(idx);
1053     char *p;
1054     char *end;
1055     int n = FILTER_READ(idx + 1, buf_sv, maxlen);
1056
1057     if (n<=0) return n;
1058
1059     p = SvPV_force_nolen(buf_sv);
1060     end = p + SvCUR(buf_sv);
1061     while (p < end) {
1062         if (*p == 'o') *p = 'e';
1063         p++;
1064     }
1065     return SvCUR(buf_sv);
1066 }
1067
1068 static AV *
1069 myget_linear_isa(pTHX_ HV *stash, U32 level) {
1070     GV **gvp = (GV **)hv_fetchs(stash, "ISA", 0);
1071     PERL_UNUSED_ARG(level);
1072     return gvp && *gvp && GvAV(*gvp)
1073          ? GvAV(*gvp)
1074          : (AV *)sv_2mortal((SV *)newAV());
1075 }
1076
1077
1078 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
1079 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
1080 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
1081
1082 static struct mro_alg mymro;
1083
1084 static Perl_check_t addissub_nxck_add;
1085
1086 static OP *
1087 addissub_myck_add(pTHX_ OP *op)
1088 {
1089     SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addissub", 0);
1090     OP *aop, *bop;
1091     U8 flags;
1092     if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
1093             (aop = cBINOPx(op)->op_first) && (bop = aop->op_sibling) &&
1094             !bop->op_sibling))
1095         return addissub_nxck_add(aTHX_ op);
1096     aop->op_sibling = NULL;
1097     cBINOPx(op)->op_first = NULL;
1098     op->op_flags &= ~OPf_KIDS;
1099     flags = op->op_flags;
1100     op_free(op);
1101     return newBINOP(OP_SUBTRACT, flags, aop, bop);
1102 }
1103
1104 static Perl_check_t old_ck_rv2cv;
1105
1106 static OP *
1107 my_ck_rv2cv(pTHX_ OP *o)
1108 {
1109     SV *ref;
1110     SV **flag_svp = hv_fetchs(GvHV(PL_hintgv), "XS::APItest/addunder", 0);
1111     OP *aop;
1112
1113     if (flag_svp && SvTRUE(*flag_svp) && (o->op_flags & OPf_KIDS)
1114      && (aop = cUNOPx(o)->op_first) && aop->op_type == OP_CONST
1115      && aop->op_private & (OPpCONST_ENTERED|OPpCONST_BARE)
1116      && (ref = cSVOPx(aop)->op_sv) && SvPOK(ref) && SvCUR(ref)
1117      && *(SvEND(ref)-1) == 'o')
1118     {
1119         SvGROW(ref, SvCUR(ref)+2);
1120         *SvEND(ref) = '_';
1121         SvCUR(ref)++;
1122         *SvEND(ref) = '\0';
1123     }
1124     return old_ck_rv2cv(aTHX_ o);
1125 }
1126
1127 #include "const-c.inc"
1128
1129 MODULE = XS::APItest            PACKAGE = XS::APItest
1130
1131 INCLUDE: const-xs.inc
1132
1133 INCLUDE: numeric.xs
1134
1135 MODULE = XS::APItest::utf8      PACKAGE = XS::APItest::utf8
1136
1137 int
1138 bytes_cmp_utf8(bytes, utf8)
1139         SV *bytes
1140         SV *utf8
1141     PREINIT:
1142         const U8 *b;
1143         STRLEN blen;
1144         const U8 *u;
1145         STRLEN ulen;
1146     CODE:
1147         b = (const U8 *)SvPVbyte(bytes, blen);
1148         u = (const U8 *)SvPVbyte(utf8, ulen);
1149         RETVAL = bytes_cmp_utf8(b, blen, u, ulen);
1150     OUTPUT:
1151         RETVAL
1152
1153 AV *
1154 test_utf8n_to_uvchr(s, len, flags)
1155
1156         SV *s
1157         SV *len
1158         SV *flags
1159     PREINIT:
1160         STRLEN retlen;
1161         UV ret;
1162         STRLEN slen;
1163
1164     CODE:
1165         /* Call utf8n_to_uvchr() with the inputs.  It always asks for the
1166          * actual length to be returned
1167          *
1168          * Length to assume <s> is; not checked, so could have buffer overflow
1169          */
1170         RETVAL = newAV();
1171         sv_2mortal((SV*)RETVAL);
1172
1173         ret
1174          = utf8n_to_uvchr((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags));
1175
1176         /* Returns the return value in [0]; <retlen> in [1] */
1177         av_push(RETVAL, newSVuv(ret));
1178         if (retlen == (STRLEN) -1) {
1179             av_push(RETVAL, newSViv(-1));
1180         }
1181         else {
1182             av_push(RETVAL, newSVuv(retlen));
1183         }
1184
1185     OUTPUT:
1186         RETVAL
1187
1188 MODULE = XS::APItest:Overload   PACKAGE = XS::APItest::Overload
1189
1190 void
1191 amagic_deref_call(sv, what)
1192         SV *sv
1193         int what
1194     PPCODE:
1195         /* The reference is owned by something else.  */
1196         PUSHs(amagic_deref_call(sv, what));
1197
1198 # I'd certainly like to discourage the use of this macro, given that we now
1199 # have amagic_deref_call
1200
1201 void
1202 tryAMAGICunDEREF_var(sv, what)
1203         SV *sv
1204         int what
1205     PPCODE:
1206         {
1207             SV **sp = &sv;
1208             switch(what) {
1209             case to_av_amg:
1210                 tryAMAGICunDEREF(to_av);
1211                 break;
1212             case to_cv_amg:
1213                 tryAMAGICunDEREF(to_cv);
1214                 break;
1215             case to_gv_amg:
1216                 tryAMAGICunDEREF(to_gv);
1217                 break;
1218             case to_hv_amg:
1219                 tryAMAGICunDEREF(to_hv);
1220                 break;
1221             case to_sv_amg:
1222                 tryAMAGICunDEREF(to_sv);
1223                 break;
1224             default:
1225                 croak("Invalid value %d passed to tryAMAGICunDEREF_var", what);
1226             }
1227         }
1228         /* The reference is owned by something else.  */
1229         PUSHs(sv);
1230
1231 MODULE = XS::APItest            PACKAGE = XS::APItest::XSUB
1232
1233 BOOT:
1234     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
1235     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
1236     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
1237
1238 void
1239 XS_VERSION_defined(...)
1240     PPCODE:
1241         XS_VERSION_BOOTCHECK;
1242         XSRETURN_EMPTY;
1243
1244 void
1245 XS_APIVERSION_valid(...)
1246     PPCODE:
1247         XS_APIVERSION_BOOTCHECK;
1248         XSRETURN_EMPTY;
1249
1250 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
1251
1252 void
1253 rot13_hash(hash)
1254         HV *hash
1255         CODE:
1256         {
1257             struct ufuncs uf;
1258             uf.uf_val = rot13_key;
1259             uf.uf_set = 0;
1260             uf.uf_index = 0;
1261
1262             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1263         }
1264
1265 void
1266 bitflip_hash(hash)
1267         HV *hash
1268         CODE:
1269         {
1270             struct ufuncs uf;
1271             uf.uf_val = bitflip_key;
1272             uf.uf_set = 0;
1273             uf.uf_index = 0;
1274
1275             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1276         }
1277
1278 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
1279
1280 bool
1281 exists(hash, key_sv)
1282         PREINIT:
1283         STRLEN len;
1284         const char *key;
1285         INPUT:
1286         HV *hash
1287         SV *key_sv
1288         CODE:
1289         key = SvPV(key_sv, len);
1290         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
1291         OUTPUT:
1292         RETVAL
1293
1294 bool
1295 exists_ent(hash, key_sv)
1296         PREINIT:
1297         INPUT:
1298         HV *hash
1299         SV *key_sv
1300         CODE:
1301         RETVAL = hv_exists_ent(hash, key_sv, 0);
1302         OUTPUT:
1303         RETVAL
1304
1305 SV *
1306 delete(hash, key_sv, flags = 0)
1307         PREINIT:
1308         STRLEN len;
1309         const char *key;
1310         INPUT:
1311         HV *hash
1312         SV *key_sv
1313         I32 flags;
1314         CODE:
1315         key = SvPV(key_sv, len);
1316         /* It's already mortal, so need to increase reference count.  */
1317         RETVAL
1318             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
1319         OUTPUT:
1320         RETVAL
1321
1322 SV *
1323 delete_ent(hash, key_sv, flags = 0)
1324         INPUT:
1325         HV *hash
1326         SV *key_sv
1327         I32 flags;
1328         CODE:
1329         /* It's already mortal, so need to increase reference count.  */
1330         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
1331         OUTPUT:
1332         RETVAL
1333
1334 SV *
1335 store_ent(hash, key, value)
1336         PREINIT:
1337         SV *copy;
1338         HE *result;
1339         INPUT:
1340         HV *hash
1341         SV *key
1342         SV *value
1343         CODE:
1344         copy = newSV(0);
1345         result = hv_store_ent(hash, key, copy, 0);
1346         SvSetMagicSV(copy, value);
1347         if (!result) {
1348             SvREFCNT_dec(copy);
1349             XSRETURN_EMPTY;
1350         }
1351         /* It's about to become mortal, so need to increase reference count.
1352          */
1353         RETVAL = SvREFCNT_inc(HeVAL(result));
1354         OUTPUT:
1355         RETVAL
1356
1357 SV *
1358 store(hash, key_sv, value)
1359         PREINIT:
1360         STRLEN len;
1361         const char *key;
1362         SV *copy;
1363         SV **result;
1364         INPUT:
1365         HV *hash
1366         SV *key_sv
1367         SV *value
1368         CODE:
1369         key = SvPV(key_sv, len);
1370         copy = newSV(0);
1371         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
1372         SvSetMagicSV(copy, value);
1373         if (!result) {
1374             SvREFCNT_dec(copy);
1375             XSRETURN_EMPTY;
1376         }
1377         /* It's about to become mortal, so need to increase reference count.
1378          */
1379         RETVAL = SvREFCNT_inc(*result);
1380         OUTPUT:
1381         RETVAL
1382
1383 SV *
1384 fetch_ent(hash, key_sv)
1385         PREINIT:
1386         HE *result;
1387         INPUT:
1388         HV *hash
1389         SV *key_sv
1390         CODE:
1391         result = hv_fetch_ent(hash, key_sv, 0, 0);
1392         if (!result) {
1393             XSRETURN_EMPTY;
1394         }
1395         /* Force mg_get  */
1396         RETVAL = newSVsv(HeVAL(result));
1397         OUTPUT:
1398         RETVAL
1399
1400 SV *
1401 fetch(hash, key_sv)
1402         PREINIT:
1403         STRLEN len;
1404         const char *key;
1405         SV **result;
1406         INPUT:
1407         HV *hash
1408         SV *key_sv
1409         CODE:
1410         key = SvPV(key_sv, len);
1411         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
1412         if (!result) {
1413             XSRETURN_EMPTY;
1414         }
1415         /* Force mg_get  */
1416         RETVAL = newSVsv(*result);
1417         OUTPUT:
1418         RETVAL
1419
1420 #if defined (hv_common)
1421
1422 SV *
1423 common(params)
1424         INPUT:
1425         HV *params
1426         PREINIT:
1427         HE *result;
1428         HV *hv = NULL;
1429         SV *keysv = NULL;
1430         const char *key = NULL;
1431         STRLEN klen = 0;
1432         int flags = 0;
1433         int action = 0;
1434         SV *val = NULL;
1435         U32 hash = 0;
1436         SV **svp;
1437         CODE:
1438         if ((svp = hv_fetchs(params, "hv", 0))) {
1439             SV *const rv = *svp;
1440             if (!SvROK(rv))
1441                 croak("common passed a non-reference for parameter hv");
1442             hv = (HV *)SvRV(rv);
1443         }
1444         if ((svp = hv_fetchs(params, "keysv", 0)))
1445             keysv = *svp;
1446         if ((svp = hv_fetchs(params, "keypv", 0))) {
1447             key = SvPV_const(*svp, klen);
1448             if (SvUTF8(*svp))
1449                 flags = HVhek_UTF8;
1450         }
1451         if ((svp = hv_fetchs(params, "action", 0)))
1452             action = SvIV(*svp);
1453         if ((svp = hv_fetchs(params, "val", 0)))
1454             val = newSVsv(*svp);
1455         if ((svp = hv_fetchs(params, "hash", 0)))
1456             hash = SvUV(*svp);
1457
1458         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
1459             PERL_HASH(hash, key, klen);
1460         }
1461         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
1462             STRLEN len;
1463             const char *const p = SvPV(keysv, len);
1464             PERL_HASH(hash, p, len);
1465         }
1466
1467         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
1468         if (!result) {
1469             XSRETURN_EMPTY;
1470         }
1471         /* Force mg_get  */
1472         RETVAL = newSVsv(HeVAL(result));
1473         OUTPUT:
1474         RETVAL
1475
1476 #endif
1477
1478 void
1479 test_hv_free_ent()
1480         PPCODE:
1481         test_freeent(&Perl_hv_free_ent);
1482         XSRETURN(4);
1483
1484 void
1485 test_hv_delayfree_ent()
1486         PPCODE:
1487         test_freeent(&Perl_hv_delayfree_ent);
1488         XSRETURN(4);
1489
1490 SV *
1491 test_share_unshare_pvn(input)
1492         PREINIT:
1493         STRLEN len;
1494         U32 hash;
1495         char *pvx;
1496         char *p;
1497         INPUT:
1498         SV *input
1499         CODE:
1500         pvx = SvPV(input, len);
1501         PERL_HASH(hash, pvx, len);
1502         p = sharepvn(pvx, len, hash);
1503         RETVAL = newSVpvn(p, len);
1504         unsharepvn(p, len, hash);
1505         OUTPUT:
1506         RETVAL
1507
1508 #if PERL_VERSION >= 9
1509
1510 bool
1511 refcounted_he_exists(key, level=0)
1512         SV *key
1513         IV level
1514         CODE:
1515         if (level) {
1516             croak("level must be zero, not %"IVdf, level);
1517         }
1518         RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder);
1519         OUTPUT:
1520         RETVAL
1521
1522 SV *
1523 refcounted_he_fetch(key, level=0)
1524         SV *key
1525         IV level
1526         CODE:
1527         if (level) {
1528             croak("level must be zero, not %"IVdf, level);
1529         }
1530         RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0);
1531         SvREFCNT_inc(RETVAL);
1532         OUTPUT:
1533         RETVAL
1534
1535 #endif
1536
1537 void
1538 test_force_keys(HV *hv)
1539     PREINIT:
1540         HE *he;
1541         STRLEN count = 0;
1542     PPCODE:
1543         hv_iterinit(hv);
1544         he = hv_iternext(hv);
1545         while (he) {
1546             SV *sv = HeSVKEY_force(he);
1547             ++count;
1548             EXTEND(SP, count);
1549             PUSHs(sv_mortalcopy(sv));
1550             he = hv_iternext(hv);
1551         }
1552
1553 =pod
1554
1555 sub TIEHASH  { bless {}, $_[0] }
1556 sub STORE    { $_[0]->{$_[1]} = $_[2] }
1557 sub FETCH    { $_[0]->{$_[1]} }
1558 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1559 sub NEXTKEY  { each %{$_[0]} }
1560 sub EXISTS   { exists $_[0]->{$_[1]} }
1561 sub DELETE   { delete $_[0]->{$_[1]} }
1562 sub CLEAR    { %{$_[0]} = () }
1563
1564 =cut
1565
1566 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
1567
1568 void
1569 make_temp_mg_lv(sv)
1570 SV* sv
1571     PREINIT:
1572         SV * const lv = newSV_type(SVt_PVLV);
1573         STRLEN len;
1574     PPCODE:
1575         SvPV(sv, len);
1576
1577         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1578         LvTYPE(lv) = 'x';
1579         LvTARG(lv) = SvREFCNT_inc_simple(sv);
1580         LvTARGOFF(lv) = len == 0 ? 0 : 1;
1581         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1582
1583         EXTEND(SP, 1);
1584         ST(0) = sv_2mortal(lv);
1585         XSRETURN(1);
1586
1587
1588 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1589
1590 void
1591 ptr_table_new(classname)
1592 const char * classname
1593     PPCODE:
1594     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1595
1596 void
1597 DESTROY(table)
1598 XS::APItest::PtrTable table
1599     CODE:
1600     ptr_table_free(table);
1601
1602 void
1603 ptr_table_store(table, from, to)
1604 XS::APItest::PtrTable table
1605 SVREF from
1606 SVREF to
1607    CODE:
1608    ptr_table_store(table, from, to);
1609
1610 UV
1611 ptr_table_fetch(table, from)
1612 XS::APItest::PtrTable table
1613 SVREF from
1614    CODE:
1615    RETVAL = PTR2UV(ptr_table_fetch(table, from));
1616    OUTPUT:
1617    RETVAL
1618
1619 void
1620 ptr_table_split(table)
1621 XS::APItest::PtrTable table
1622
1623 void
1624 ptr_table_clear(table)
1625 XS::APItest::PtrTable table
1626
1627 MODULE = XS::APItest::AutoLoader        PACKAGE = XS::APItest::AutoLoader
1628
1629 SV *
1630 AUTOLOAD()
1631     CODE:
1632         RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1633     OUTPUT:
1634         RETVAL
1635
1636 SV *
1637 AUTOLOADp(...)
1638     PROTOTYPE: *$
1639     CODE:
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
1946 void
1947 call_sv(sv, flags, ...)
1948     SV* sv
1949     I32 flags
1950     PREINIT:
1951         I32 i;
1952     PPCODE:
1953         for (i=0; i<items-2; i++)
1954             ST(i) = ST(i+2); /* pop first two args */
1955         PUSHMARK(SP);
1956         SP += items - 2;
1957         PUTBACK;
1958         i = call_sv(sv, flags);
1959         SPAGAIN;
1960         EXTEND(SP, 1);
1961         PUSHs(sv_2mortal(newSViv(i)));
1962
1963 void
1964 call_pv(subname, flags, ...)
1965     char* subname
1966     I32 flags
1967     PREINIT:
1968         I32 i;
1969     PPCODE:
1970         for (i=0; i<items-2; i++)
1971             ST(i) = ST(i+2); /* pop first two args */
1972         PUSHMARK(SP);
1973         SP += items - 2;
1974         PUTBACK;
1975         i = call_pv(subname, flags);
1976         SPAGAIN;
1977         EXTEND(SP, 1);
1978         PUSHs(sv_2mortal(newSViv(i)));
1979
1980 void
1981 call_method(methname, flags, ...)
1982     char* methname
1983     I32 flags
1984     PREINIT:
1985         I32 i;
1986     PPCODE:
1987         for (i=0; i<items-2; i++)
1988             ST(i) = ST(i+2); /* pop first two args */
1989         PUSHMARK(SP);
1990         SP += items - 2;
1991         PUTBACK;
1992         i = call_method(methname, flags);
1993         SPAGAIN;
1994         EXTEND(SP, 1);
1995         PUSHs(sv_2mortal(newSViv(i)));
1996
1997 void
1998 newCONSTSUB(stash, name, flags, sv)
1999     HV* stash
2000     SV* name
2001     I32 flags
2002     SV* sv
2003     ALIAS:
2004         newCONSTSUB_flags = 1
2005     PREINIT:
2006         CV* mycv;
2007         STRLEN len;
2008         const char *pv = SvPV(name, len);
2009     PPCODE:
2010         switch (ix) {
2011            case 0:
2012                mycv = newCONSTSUB(stash, pv, SvOK(sv) ? SvREFCNT_inc(sv) : NULL);
2013                break;
2014            case 1:
2015                mycv = newCONSTSUB_flags(
2016                  stash, pv, len, flags | SvUTF8(name), SvOK(sv) ? SvREFCNT_inc(sv) : NULL
2017                );
2018                break;
2019         }
2020         EXTEND(SP, 2);
2021         PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no );
2022         PUSHs((SV*)CvGV(mycv));
2023
2024 void
2025 gv_init_type(namesv, multi, flags, type)
2026     SV* namesv
2027     int multi
2028     I32 flags
2029     int type
2030     PREINIT:
2031         STRLEN len;
2032         const char * const name = SvPV_const(namesv, len);
2033         GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
2034     PPCODE:
2035         if (SvTYPE(gv) == SVt_PVGV)
2036             Perl_croak(aTHX_ "GV is already a PVGV");
2037         if (multi) flags |= GV_ADDMULTI;
2038         switch (type) {
2039            case 0:
2040                gv_init(gv, PL_defstash, name, len, multi);
2041                break;
2042            case 1:
2043                gv_init_sv(gv, PL_defstash, namesv, flags);
2044                break;
2045            case 2:
2046                gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
2047                break;
2048            case 3:
2049                gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
2050                break;
2051         }
2052         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2053
2054 void
2055 gv_fetchmeth_type(stash, methname, type, level, flags)
2056     HV* stash
2057     SV* methname
2058     int type
2059     I32 level
2060     I32 flags
2061     PREINIT:
2062         STRLEN len;
2063         const char * const name = SvPV_const(methname, len);
2064         GV* gv;
2065     PPCODE:
2066         switch (type) {
2067            case 0:
2068                gv = gv_fetchmeth(stash, name, len, level);
2069                break;
2070            case 1:
2071                gv = gv_fetchmeth_sv(stash, methname, level, flags);
2072                break;
2073            case 2:
2074                gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
2075                break;
2076            case 3:
2077                gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
2078                break;
2079         }
2080         XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2081
2082 void
2083 gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
2084     HV* stash
2085     SV* methname
2086     int type
2087     I32 level
2088     I32 flags
2089     PREINIT:
2090         STRLEN len;
2091         const char * const name = SvPV_const(methname, len);
2092         GV* gv;
2093     PPCODE:
2094         switch (type) {
2095            case 0:
2096                gv = gv_fetchmeth_autoload(stash, name, len, level);
2097                break;
2098            case 1:
2099                gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
2100                break;
2101            case 2:
2102                gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
2103                break;
2104            case 3:
2105                gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
2106                break;
2107         }
2108         XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
2109
2110 void
2111 gv_fetchmethod_flags_type(stash, methname, type, flags)
2112     HV* stash
2113     SV* methname
2114     int type
2115     I32 flags
2116     PREINIT:
2117         GV* gv;
2118     PPCODE:
2119         switch (type) {
2120            case 0:
2121                gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
2122                break;
2123            case 1:
2124                gv = gv_fetchmethod_sv_flags(stash, methname, flags);
2125                break;
2126            case 2:
2127                gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
2128                break;
2129            case 3: {
2130                STRLEN len;
2131                const char * const name = SvPV_const(methname, len);
2132                gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
2133                break;
2134             }
2135         }
2136         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2137
2138 void
2139 gv_autoload_type(stash, methname, type, method)
2140     HV* stash
2141     SV* methname
2142     int type
2143     I32 method
2144     PREINIT:
2145         STRLEN len;
2146         const char * const name = SvPV_const(methname, len);
2147         GV* gv;
2148         I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
2149     PPCODE:
2150         switch (type) {
2151            case 0:
2152                gv = gv_autoload4(stash, name, len, method);
2153                break;
2154            case 1:
2155                gv = gv_autoload_sv(stash, methname, flags);
2156                break;
2157            case 2:
2158                gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
2159                break;
2160            case 3:
2161                gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
2162                break;
2163         }
2164         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2165
2166 void
2167 whichsig_type(namesv, type)
2168     SV* namesv
2169     int type
2170     PREINIT:
2171         STRLEN len;
2172         const char * const name = SvPV_const(namesv, len);
2173         I32 i;
2174     PPCODE:
2175         switch (type) {
2176            case 0:
2177               i = whichsig(name);
2178                break;
2179            case 1:
2180                i = whichsig_sv(namesv);
2181                break;
2182            case 2:
2183                i = whichsig_pv(name);
2184                break;
2185            case 3:
2186                i = whichsig_pvn(name, len);
2187                break;
2188         }
2189         XPUSHs(sv_2mortal(newSViv(i)));
2190
2191 void
2192 eval_sv(sv, flags)
2193     SV* sv
2194     I32 flags
2195     PREINIT:
2196         I32 i;
2197     PPCODE:
2198         PUTBACK;
2199         i = eval_sv(sv, flags);
2200         SPAGAIN;
2201         EXTEND(SP, 1);
2202         PUSHs(sv_2mortal(newSViv(i)));
2203
2204 void
2205 eval_pv(p, croak_on_error)
2206     const char* p
2207     I32 croak_on_error
2208     PPCODE:
2209         PUTBACK;
2210         EXTEND(SP, 1);
2211         PUSHs(eval_pv(p, croak_on_error));
2212
2213 void
2214 require_pv(pv)
2215     const char* pv
2216     PPCODE:
2217         PUTBACK;
2218         require_pv(pv);
2219
2220 int
2221 apitest_exception(throw_e)
2222     int throw_e
2223     OUTPUT:
2224         RETVAL
2225
2226 void
2227 mycroak(sv)
2228     SV* sv
2229     CODE:
2230     if (SvOK(sv)) {
2231         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
2232     }
2233     else {
2234         Perl_croak(aTHX_ NULL);
2235     }
2236
2237 SV*
2238 strtab()
2239    CODE:
2240    RETVAL = newRV_inc((SV*)PL_strtab);
2241    OUTPUT:
2242    RETVAL
2243
2244 int
2245 my_cxt_getint()
2246     CODE:
2247         dMY_CXT;
2248         RETVAL = my_cxt_getint_p(aMY_CXT);
2249     OUTPUT:
2250         RETVAL
2251
2252 void
2253 my_cxt_setint(i)
2254     int i;
2255     CODE:
2256         dMY_CXT;
2257         my_cxt_setint_p(aMY_CXT_ i);
2258
2259 void
2260 my_cxt_getsv(how)
2261     bool how;
2262     PPCODE:
2263         EXTEND(SP, 1);
2264         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
2265         XSRETURN(1);
2266
2267 void
2268 my_cxt_setsv(sv)
2269     SV *sv;
2270     CODE:
2271         dMY_CXT;
2272         SvREFCNT_dec(MY_CXT.sv);
2273         my_cxt_setsv_p(sv _aMY_CXT);
2274         SvREFCNT_inc(sv);
2275
2276 bool
2277 sv_setsv_cow_hashkey_core()
2278
2279 bool
2280 sv_setsv_cow_hashkey_notcore()
2281
2282 void
2283 sv_set_deref(SV *sv, SV *sv2, int which)
2284     CODE:
2285     {
2286         STRLEN len;
2287         const char *pv = SvPV(sv2,len);
2288         if (!SvROK(sv)) croak("Not a ref");
2289         sv = SvRV(sv);
2290         switch (which) {
2291             case 0: sv_setsv(sv,sv2); break;
2292             case 1: sv_setpv(sv,pv); break;
2293             case 2: sv_setpvn(sv,pv,len); break;
2294         }
2295     }
2296
2297 void
2298 rmagical_cast(sv, type)
2299     SV *sv;
2300     SV *type;
2301     PREINIT:
2302         struct ufuncs uf;
2303     PPCODE:
2304         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
2305         sv = SvRV(sv);
2306         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
2307         uf.uf_val = rmagical_a_dummy;
2308         uf.uf_set = NULL;
2309         uf.uf_index = 0;
2310         if (SvTRUE(type)) { /* b */
2311             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
2312         } else { /* a */
2313             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
2314         }
2315         XSRETURN_YES;
2316
2317 void
2318 rmagical_flags(sv)
2319     SV *sv;
2320     PPCODE:
2321         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
2322         sv = SvRV(sv);
2323         EXTEND(SP, 3); 
2324         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
2325         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
2326         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
2327         XSRETURN(3);
2328
2329 void
2330 my_caller(level)
2331         I32 level
2332     PREINIT:
2333         const PERL_CONTEXT *cx, *dbcx;
2334         const char *pv;
2335         const GV *gv;
2336         HV *hv;
2337     PPCODE:
2338         cx = caller_cx(level, &dbcx);
2339         EXTEND(SP, 8);
2340
2341         pv = CopSTASHPV(cx->blk_oldcop);
2342         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2343         gv = CvGV(cx->blk_sub.cv);
2344         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2345
2346         pv = CopSTASHPV(dbcx->blk_oldcop);
2347         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2348         gv = CvGV(dbcx->blk_sub.cv);
2349         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2350
2351         ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
2352         ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
2353         ST(6) = cop_hints_fetch_sv(cx->blk_oldcop, 
2354                 sv_2mortal(newSVpvn("foo", 3)), 0, 0);
2355
2356         hv = cop_hints_2hv(cx->blk_oldcop, 0);
2357         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
2358
2359         XSRETURN(8);
2360
2361 void
2362 DPeek (sv)
2363     SV   *sv
2364
2365   PPCODE:
2366     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
2367     XSRETURN (1);
2368
2369 void
2370 BEGIN()
2371     CODE:
2372         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
2373
2374 void
2375 CHECK()
2376     CODE:
2377         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
2378
2379 void
2380 UNITCHECK()
2381     CODE:
2382         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
2383
2384 void
2385 INIT()
2386     CODE:
2387         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
2388
2389 void
2390 END()
2391     CODE:
2392         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
2393
2394 void
2395 utf16_to_utf8 (sv, ...)
2396     SV* sv
2397         ALIAS:
2398             utf16_to_utf8_reversed = 1
2399     PREINIT:
2400         STRLEN len;
2401         U8 *source;
2402         SV *dest;
2403         I32 got; /* Gah, badly thought out APIs */
2404     CODE:
2405         source = (U8 *)SvPVbyte(sv, len);
2406         /* Optionally only convert part of the buffer.  */      
2407         if (items > 1) {
2408             len = SvUV(ST(1));
2409         }
2410         /* Mortalise this right now, as we'll be testing croak()s  */
2411         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
2412         if (ix) {
2413             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
2414         } else {
2415             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
2416         }
2417         SvCUR_set(dest, got);
2418         SvPVX(dest)[got] = '\0';
2419         SvPOK_on(dest);
2420         ST(0) = dest;
2421         XSRETURN(1);
2422
2423 void
2424 my_exit(int exitcode)
2425         PPCODE:
2426         my_exit(exitcode);
2427
2428 U8
2429 first_byte(sv)
2430         SV *sv
2431    CODE:
2432     char *s;
2433     STRLEN len;
2434         s = SvPVbyte(sv, len);
2435         RETVAL = s[0];
2436    OUTPUT:
2437     RETVAL
2438
2439 I32
2440 sv_count()
2441         CODE:
2442             RETVAL = PL_sv_count;
2443         OUTPUT:
2444             RETVAL
2445
2446 void
2447 bhk_record(bool on)
2448     CODE:
2449         dMY_CXT;
2450         MY_CXT.bhk_record = on;
2451         if (on)
2452             av_clear(MY_CXT.bhkav);
2453
2454 void
2455 test_magic_chain()
2456     PREINIT:
2457         SV *sv;
2458         MAGIC *callmg, *uvarmg;
2459     CODE:
2460         sv = sv_2mortal(newSV(0));
2461         if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
2462         if (SvMAGICAL(sv)) croak_fail();
2463         sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
2464         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2465         if (!SvMAGICAL(sv)) croak_fail();
2466         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2467         callmg = mg_find(sv, PERL_MAGIC_checkcall);
2468         if (!callmg) croak_fail();
2469         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2470             croak_fail();
2471         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2472         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2473         if (!SvMAGICAL(sv)) croak_fail();
2474         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2475         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2476         if (!uvarmg) croak_fail();
2477         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2478             croak_fail();
2479         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2480             croak_fail();
2481         mg_free_type(sv, PERL_MAGIC_vec);
2482         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2483         if (!SvMAGICAL(sv)) croak_fail();
2484         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2485         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2486         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2487             croak_fail();
2488         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2489             croak_fail();
2490         mg_free_type(sv, PERL_MAGIC_uvar);
2491         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2492         if (!SvMAGICAL(sv)) croak_fail();
2493         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2494         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2495         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2496             croak_fail();
2497         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2498         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2499         if (!SvMAGICAL(sv)) croak_fail();
2500         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2501         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2502         if (!uvarmg) croak_fail();
2503         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2504             croak_fail();
2505         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2506             croak_fail();
2507         mg_free_type(sv, PERL_MAGIC_checkcall);
2508         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2509         if (!SvMAGICAL(sv)) croak_fail();
2510         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2511         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2512         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2513             croak_fail();
2514         mg_free_type(sv, PERL_MAGIC_uvar);
2515         if (SvMAGICAL(sv)) croak_fail();
2516         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2517         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2518
2519 void
2520 test_op_contextualize()
2521     PREINIT:
2522         OP *o;
2523     CODE:
2524         o = newSVOP(OP_CONST, 0, newSViv(0));
2525         o->op_flags &= ~OPf_WANT;
2526         o = op_contextualize(o, G_SCALAR);
2527         if (o->op_type != OP_CONST ||
2528                 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2529             croak_fail();
2530         op_free(o);
2531         o = newSVOP(OP_CONST, 0, newSViv(0));
2532         o->op_flags &= ~OPf_WANT;
2533         o = op_contextualize(o, G_ARRAY);
2534         if (o->op_type != OP_CONST ||
2535                 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
2536             croak_fail();
2537         op_free(o);
2538         o = newSVOP(OP_CONST, 0, newSViv(0));
2539         o->op_flags &= ~OPf_WANT;
2540         o = op_contextualize(o, G_VOID);
2541         if (o->op_type != OP_NULL) croak_fail();
2542         op_free(o);
2543
2544 void
2545 test_rv2cv_op_cv()
2546     PROTOTYPE:
2547     PREINIT:
2548         GV *troc_gv, *wibble_gv;
2549         CV *troc_cv;
2550         OP *o;
2551     CODE:
2552         troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
2553         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
2554         wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
2555         o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
2556         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
2557         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
2558             croak_fail();
2559         o->op_private |= OPpENTERSUB_AMPER;
2560         if (rv2cv_op_cv(o, 0)) croak_fail();
2561         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2562         o->op_private &= ~OPpENTERSUB_AMPER;
2563         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2564         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
2565         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2566         op_free(o);
2567         o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
2568         o->op_private = OPpCONST_BARE;
2569         o = newCVREF(0, o);
2570         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
2571         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
2572             croak_fail();
2573         o->op_private |= OPpENTERSUB_AMPER;
2574         if (rv2cv_op_cv(o, 0)) croak_fail();
2575         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2576         op_free(o);
2577         o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
2578         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
2579         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
2580             croak_fail();
2581         o->op_private |= OPpENTERSUB_AMPER;
2582         if (rv2cv_op_cv(o, 0)) croak_fail();
2583         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2584         o->op_private &= ~OPpENTERSUB_AMPER;
2585         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2586         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
2587         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2588         op_free(o);
2589         o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
2590         if (rv2cv_op_cv(o, 0)) croak_fail();
2591         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2592         o->op_private |= OPpENTERSUB_AMPER;
2593         if (rv2cv_op_cv(o, 0)) croak_fail();
2594         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2595         o->op_private &= ~OPpENTERSUB_AMPER;
2596         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2597         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
2598         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2599         op_free(o);
2600         o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
2601         if (rv2cv_op_cv(o, 0)) croak_fail();
2602         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2603         op_free(o);
2604
2605 void
2606 test_cv_getset_call_checker()
2607     PREINIT:
2608         CV *troc_cv, *tsh_cv;
2609         Perl_call_checker ckfun;
2610         SV *ckobj;
2611     CODE:
2612 #define check_cc(cv, xckfun, xckobj) \
2613     do { \
2614         cv_get_call_checker((cv), &ckfun, &ckobj); \
2615         if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \
2616         if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \
2617     } while(0)
2618         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
2619         tsh_cv = get_cv("XS::APItest::test_savehints", 0);
2620         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2621         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2622         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
2623                                     &PL_sv_yes);
2624         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2625         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
2626         cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2627         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2628         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
2629         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
2630                                     (SV*)tsh_cv);
2631         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2632         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2633         cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
2634                                     (SV*)troc_cv);
2635         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2636         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2637         if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
2638         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
2639 #undef check_cc
2640
2641 void
2642 cv_set_call_checker_lists(CV *cv)
2643     CODE:
2644         cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
2645
2646 void
2647 cv_set_call_checker_scalars(CV *cv)
2648     CODE:
2649         cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
2650
2651 void
2652 cv_set_call_checker_proto(CV *cv, SV *proto)
2653     CODE:
2654         if (SvROK(proto))
2655             proto = SvRV(proto);
2656         cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
2657
2658 void
2659 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
2660     CODE:
2661         if (SvROK(proto))
2662             proto = SvRV(proto);
2663         cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
2664
2665 void
2666 cv_set_call_checker_multi_sum(CV *cv)
2667     CODE:
2668         cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
2669
2670 void
2671 test_cophh()
2672     PREINIT:
2673         COPHH *a, *b;
2674     CODE:
2675 #define check_ph(EXPR) \
2676             do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
2677 #define check_iv(EXPR, EXPECT) \
2678             do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
2679 #define msvpvs(STR) sv_2mortal(newSVpvs(STR))
2680 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
2681         a = cophh_new_empty();
2682         check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
2683         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
2684         check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
2685         check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
2686         a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
2687         a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
2688         a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
2689         a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
2690         check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
2691         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
2692         check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
2693         check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
2694         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
2695         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2696         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2697         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2698         b = cophh_copy(a);
2699         b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
2700         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
2701         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
2702         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2703         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2704         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2705         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
2706         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
2707         check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
2708         check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
2709         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
2710         a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
2711         a = cophh_delete_pvs(a, "foo_2", 0);
2712         b = cophh_delete_pv(b, "foo_3", 0, 0);
2713         b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
2714         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
2715         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
2716         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2717         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2718         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2719         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
2720         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
2721         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
2722         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
2723         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
2724         b = cophh_delete_pvs(b, "foo_3", 0);
2725         b = cophh_delete_pvs(b, "foo_5", 0);
2726         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
2727         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
2728         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
2729         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
2730         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
2731         cophh_free(b);
2732         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
2733         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
2734         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2735         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2736         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2737         a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
2738         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
2739         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
2740         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
2741         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
2742         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
2743         check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
2744         check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
2745         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
2746         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
2747         check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
2748         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
2749         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
2750         check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
2751         check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
2752         check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
2753         check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
2754         check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
2755         ENTER;
2756         SAVEFREECOPHH(a);
2757         LEAVE;
2758 #undef check_ph
2759 #undef check_iv
2760 #undef msvpvs
2761 #undef msviv
2762
2763 void
2764 test_coplabel()
2765     PREINIT:
2766         COP *cop;
2767         const char *label;
2768         STRLEN len;
2769         U32 utf8;
2770     CODE:
2771         cop = &PL_compiling;
2772         Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
2773         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
2774         if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
2775         if (len != 3) croak("fail # cop_fetch_label len");
2776         if (utf8) croak("fail # cop_fetch_label utf8");
2777         /* SMALL GERMAN UMLAUT A */
2778         Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
2779         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
2780         if (strcmp(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
2781         if (len != 4) croak("fail # cop_fetch_label len");
2782         if (!utf8) croak("fail # cop_fetch_label utf8");
2783
2784
2785 HV *
2786 example_cophh_2hv()
2787     PREINIT:
2788         COPHH *a;
2789     CODE:
2790 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
2791         a = cophh_new_empty();
2792         a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
2793         a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
2794         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
2795         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
2796         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
2797         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
2798         a = cophh_delete_pvs(a, "foo_0", 0);
2799         a = cophh_delete_pvs(a, "foo_2", 0);
2800         RETVAL = cophh_2hv(a, 0);
2801         cophh_free(a);
2802 #undef msviv
2803     OUTPUT:
2804         RETVAL
2805
2806 void
2807 test_savehints()
2808     PREINIT:
2809         SV **svp, *sv;
2810     CODE:
2811 #define store_hint(KEY, VALUE) \
2812                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
2813 #define hint_ok(KEY, EXPECT) \
2814                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
2815                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
2816                     (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
2817                     SvIV(sv) == (EXPECT))
2818 #define check_hint(KEY, EXPECT) \
2819                 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
2820         PL_hints |= HINT_LOCALIZE_HH;
2821         ENTER;
2822         SAVEHINTS();
2823         PL_hints &= HINT_INTEGER;
2824         store_hint("t0", 123);
2825         store_hint("t1", 456);
2826         if (PL_hints & HINT_INTEGER) croak_fail();
2827         check_hint("t0", 123); check_hint("t1", 456);
2828         ENTER;
2829         SAVEHINTS();
2830         if (PL_hints & HINT_INTEGER) croak_fail();
2831         check_hint("t0", 123); check_hint("t1", 456);
2832         PL_hints |= HINT_INTEGER;
2833         store_hint("t0", 321);
2834         if (!(PL_hints & HINT_INTEGER)) croak_fail();
2835         check_hint("t0", 321); check_hint("t1", 456);
2836         LEAVE;
2837         if (PL_hints & HINT_INTEGER) croak_fail();
2838         check_hint("t0", 123); check_hint("t1", 456);
2839         ENTER;
2840         SAVEHINTS();
2841         if (PL_hints & HINT_INTEGER) croak_fail();
2842         check_hint("t0", 123); check_hint("t1", 456);
2843         store_hint("t1", 654);
2844         if (PL_hints & HINT_INTEGER) croak_fail();
2845         check_hint("t0", 123); check_hint("t1", 654);
2846         LEAVE;
2847         if (PL_hints & HINT_INTEGER) croak_fail();
2848         check_hint("t0", 123); check_hint("t1", 456);
2849         LEAVE;
2850 #undef store_hint
2851 #undef hint_ok
2852 #undef check_hint
2853
2854 void
2855 test_copyhints()
2856     PREINIT:
2857         HV *a, *b;
2858     CODE:
2859         PL_hints |= HINT_LOCALIZE_HH;
2860         ENTER;
2861         SAVEHINTS();
2862         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
2863         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
2864             croak_fail();
2865         a = newHVhv(GvHV(PL_hintgv));
2866         sv_2mortal((SV*)a);
2867         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
2868         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
2869             croak_fail();
2870         b = hv_copy_hints_hv(a);
2871         sv_2mortal((SV*)b);
2872         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
2873         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
2874             croak_fail();
2875         LEAVE;
2876
2877 void
2878 test_op_list()
2879     PREINIT:
2880         OP *a;
2881     CODE:
2882 #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
2883 #define check_op(o, expect) \
2884     do { \
2885         if (strcmp(test_op_list_describe(o), (expect))) \
2886             croak("fail %s %s", test_op_list_describe(o), (expect)); \
2887     } while(0)
2888         a = op_append_elem(OP_LIST, NULL, NULL);
2889         check_op(a, "");
2890         a = op_append_elem(OP_LIST, iv_op(1), a);
2891         check_op(a, "const(1).");
2892         a = op_append_elem(OP_LIST, NULL, a);
2893         check_op(a, "const(1).");
2894         a = op_append_elem(OP_LIST, a, iv_op(2));
2895         check_op(a, "list[pushmark.const(1).const(2).]");
2896         a = op_append_elem(OP_LIST, a, iv_op(3));
2897         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2898         a = op_append_elem(OP_LIST, a, NULL);
2899         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2900         a = op_append_elem(OP_LIST, NULL, a);
2901         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2902         a = op_append_elem(OP_LIST, iv_op(4), a);
2903         check_op(a, "list[pushmark.const(4)."
2904                 "list[pushmark.const(1).const(2).const(3).]]");
2905         a = op_append_elem(OP_LIST, a, iv_op(5));
2906         check_op(a, "list[pushmark.const(4)."
2907                 "list[pushmark.const(1).const(2).const(3).]const(5).]");
2908         a = op_append_elem(OP_LIST, a, 
2909                 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
2910         check_op(a, "list[pushmark.const(4)."
2911                 "list[pushmark.const(1).const(2).const(3).]const(5)."
2912                 "list[pushmark.const(7).const(6).]]");
2913         op_free(a);
2914         a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
2915         check_op(a, "lineseq[const(1).const(2).]");
2916         a = op_append_elem(OP_LINESEQ, a, iv_op(3));
2917         check_op(a, "lineseq[const(1).const(2).const(3).]");
2918         op_free(a);
2919         a = op_append_elem(OP_LINESEQ,
2920                 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
2921                 iv_op(3));
2922         check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
2923         op_free(a);
2924         a = op_prepend_elem(OP_LIST, NULL, NULL);
2925         check_op(a, "");
2926         a = op_prepend_elem(OP_LIST, a, iv_op(1));
2927         check_op(a, "const(1).");
2928         a = op_prepend_elem(OP_LIST, a, NULL);
2929         check_op(a, "const(1).");
2930         a = op_prepend_elem(OP_LIST, iv_op(2), a);
2931         check_op(a, "list[pushmark.const(2).const(1).]");
2932         a = op_prepend_elem(OP_LIST, iv_op(3), a);
2933         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2934         a = op_prepend_elem(OP_LIST, NULL, a);
2935         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2936         a = op_prepend_elem(OP_LIST, a, NULL);
2937         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2938         a = op_prepend_elem(OP_LIST, a, iv_op(4));
2939         check_op(a, "list[pushmark."
2940                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2941         a = op_prepend_elem(OP_LIST, iv_op(5), a);
2942         check_op(a, "list[pushmark.const(5)."
2943                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2944         a = op_prepend_elem(OP_LIST,
2945                 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
2946         check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
2947                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2948         op_free(a);
2949         a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
2950         check_op(a, "lineseq[const(2).const(1).]");
2951         a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
2952         check_op(a, "lineseq[const(3).const(2).const(1).]");
2953         op_free(a);
2954         a = op_prepend_elem(OP_LINESEQ, iv_op(3),
2955                 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
2956         check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
2957         op_free(a);
2958         a = op_append_list(OP_LINESEQ, NULL, NULL);
2959         check_op(a, "");
2960         a = op_append_list(OP_LINESEQ, iv_op(1), a);
2961         check_op(a, "const(1).");
2962         a = op_append_list(OP_LINESEQ, NULL, a);
2963         check_op(a, "const(1).");
2964         a = op_append_list(OP_LINESEQ, a, iv_op(2));
2965         check_op(a, "lineseq[const(1).const(2).]");
2966         a = op_append_list(OP_LINESEQ, a, iv_op(3));
2967         check_op(a, "lineseq[const(1).const(2).const(3).]");
2968         a = op_append_list(OP_LINESEQ, iv_op(4), a);
2969         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2970         a = op_append_list(OP_LINESEQ, a, NULL);
2971         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2972         a = op_append_list(OP_LINESEQ, NULL, a);
2973         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2974         a = op_append_list(OP_LINESEQ, a,
2975                 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
2976         check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
2977                 "const(5).const(6).]");
2978         op_free(a);
2979         a = op_append_list(OP_LINESEQ,
2980                 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
2981                 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
2982         check_op(a, "lineseq[const(1).const(2)."
2983                 "list[pushmark.const(3).const(4).]]");
2984         op_free(a);
2985         a = op_append_list(OP_LINESEQ,
2986                 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
2987                 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
2988         check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
2989                 "const(3).const(4).]");
2990         op_free(a);
2991 #undef check_op
2992
2993 void
2994 test_op_linklist ()
2995     PREINIT:
2996         OP *o;
2997     CODE:
2998 #define check_ll(o, expect) \
2999     STMT_START { \
3000         if (strNE(test_op_linklist_describe(o), (expect))) \
3001             croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
3002     } STMT_END
3003         o = iv_op(1);
3004         check_ll(o, ".const1");
3005         op_free(o);
3006
3007         o = mkUNOP(OP_NOT, iv_op(1));
3008         check_ll(o, ".const1.not");
3009         op_free(o);
3010
3011         o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
3012         check_ll(o, ".const1.negate.not");
3013         op_free(o);
3014
3015         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3016         check_ll(o, ".const1.const2.add");
3017         op_free(o);
3018
3019         o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
3020         check_ll(o, ".const1.not.const2.add");
3021         op_free(o);
3022
3023         o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
3024         check_ll(o, ".const1.const2.add.not");
3025         op_free(o);
3026
3027         o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
3028         check_ll(o, ".const1.const2.const3.lineseq");
3029         op_free(o);
3030
3031         o = mkLISTOP(OP_LINESEQ,
3032                 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
3033                 mkUNOP(OP_NOT, iv_op(3)),
3034                 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
3035         check_ll(o, ".const1.const2.add.const3.not"
3036                     ".const4.const5.const6.substr.lineseq");
3037         op_free(o);
3038
3039         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3040         LINKLIST(o);
3041         o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
3042         check_ll(o, ".const1.const2.add.const3.subtract");
3043         op_free(o);
3044 #undef check_ll
3045 #undef iv_op
3046
3047 void
3048 peep_enable ()
3049     PREINIT:
3050         dMY_CXT;
3051     CODE:
3052         av_clear(MY_CXT.peep_recorder);
3053         av_clear(MY_CXT.rpeep_recorder);
3054         MY_CXT.peep_recording = 1;
3055
3056 void
3057 peep_disable ()
3058     PREINIT:
3059         dMY_CXT;
3060     CODE:
3061         MY_CXT.peep_recording = 0;
3062
3063 SV *
3064 peep_record ()
3065     PREINIT:
3066         dMY_CXT;
3067     CODE:
3068         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
3069     OUTPUT:
3070         RETVAL
3071
3072 SV *
3073 rpeep_record ()
3074     PREINIT:
3075         dMY_CXT;
3076     CODE:
3077         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
3078     OUTPUT:
3079         RETVAL
3080
3081 =pod
3082
3083 multicall_each: call a sub for each item in the list. Used to test MULTICALL
3084
3085 =cut
3086
3087 void
3088 multicall_each(block,...)
3089     SV * block
3090 PROTOTYPE: &@
3091 CODE:
3092 {
3093     dMULTICALL;
3094     int index;
3095     GV *gv;
3096     HV *stash;
3097     I32 gimme = G_SCALAR;
3098     SV **args = &PL_stack_base[ax];
3099     CV *cv;
3100
3101     if(items <= 1) {
3102         XSRETURN_UNDEF;
3103     }
3104     cv = sv_2cv(block, &stash, &gv, 0);
3105     if (cv == Nullcv) {
3106        croak("multicall_each: not a subroutine reference");
3107     }
3108     PUSH_MULTICALL(cv);
3109     SAVESPTR(GvSV(PL_defgv));
3110
3111     for(index = 1 ; index < items ; index++) {
3112         GvSV(PL_defgv) = args[index];
3113         MULTICALL;
3114     }
3115     POP_MULTICALL;
3116     XSRETURN_UNDEF;
3117 }
3118
3119 #ifdef USE_ITHREADS
3120
3121 void
3122 clone_with_stack()
3123 CODE:
3124 {
3125     PerlInterpreter *interp = aTHX; /* The original interpreter */
3126     PerlInterpreter *interp_dup;    /* The duplicate interpreter */
3127     int oldscope = 1; /* We are responsible for all scopes */
3128
3129     interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
3130
3131     /* destroy old perl */
3132     PERL_SET_CONTEXT(interp);
3133
3134     POPSTACK_TO(PL_mainstack);
3135     dounwind(-1);
3136     LEAVE_SCOPE(0);
3137
3138     while (interp->Iscopestack_ix > 1)
3139         LEAVE;
3140     FREETMPS;
3141
3142     perl_destruct(interp);
3143     perl_free(interp);
3144
3145     /* switch to new perl */
3146     PERL_SET_CONTEXT(interp_dup);
3147
3148     /* continue after 'clone_with_stack' */
3149     if (interp_dup->Iop)
3150         interp_dup->Iop = interp_dup->Iop->op_next;
3151
3152     /* run with new perl */
3153     Perl_runops_standard(interp_dup);
3154
3155     /* We may have additional unclosed scopes if fork() was called
3156      * from within a BEGIN block.  See perlfork.pod for more details.
3157      * We cannot clean up these other scopes because they belong to a
3158      * different interpreter, but we also cannot leave PL_scopestack_ix
3159      * dangling because that can trigger an assertion in perl_destruct().
3160      */
3161     if (PL_scopestack_ix > oldscope) {
3162         PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
3163         PL_scopestack_ix = oldscope;
3164     }
3165
3166     perl_destruct(interp_dup);
3167     perl_free(interp_dup);
3168
3169     /* call the real 'exit' not PerlProc_exit */
3170 #undef exit
3171     exit(0);
3172 }
3173
3174 #endif /* USE_ITHREDS */
3175
3176 SV*
3177 take_svref(SVREF sv)
3178 CODE:
3179     RETVAL = newRV_inc(sv);
3180 OUTPUT:
3181     RETVAL
3182
3183 SV*
3184 take_avref(AV* av)
3185 CODE:
3186     RETVAL = newRV_inc((SV*)av);
3187 OUTPUT:
3188     RETVAL
3189
3190 SV*
3191 take_hvref(HV* hv)
3192 CODE:
3193     RETVAL = newRV_inc((SV*)hv);
3194 OUTPUT:
3195     RETVAL
3196
3197
3198 SV*
3199 take_cvref(CV* cv)
3200 CODE:
3201     RETVAL = newRV_inc((SV*)cv);
3202 OUTPUT:
3203     RETVAL
3204
3205
3206 BOOT:
3207         {
3208         HV* stash;
3209         SV** meth = NULL;
3210         CV* cv;
3211         stash = gv_stashpv("XS::APItest::TempLv", 0);
3212         if (stash)
3213             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
3214         if (!meth)
3215             croak("lost method 'make_temp_mg_lv'");
3216         cv = GvCV(*meth);
3217         CvLVALUE_on(cv);
3218         }
3219
3220 BOOT:
3221 {
3222     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
3223     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
3224     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
3225     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
3226     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
3227     hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
3228     hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
3229     hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
3230     hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
3231     hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
3232     hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
3233     hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
3234     hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
3235     hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
3236     hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
3237     hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
3238     hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
3239     next_keyword_plugin = PL_keyword_plugin;
3240     PL_keyword_plugin = my_keyword_plugin;
3241 }
3242
3243 void
3244 establish_cleanup(...)
3245 PROTOTYPE: $
3246 CODE:
3247     PERL_UNUSED_VAR(items);
3248     croak("establish_cleanup called as a function");
3249
3250 BOOT:
3251 {
3252     CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
3253     cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
3254 }
3255
3256 void
3257 postinc(...)
3258 PROTOTYPE: $
3259 CODE:
3260     PERL_UNUSED_VAR(items);
3261     croak("postinc called as a function");
3262
3263 void
3264 filter()
3265 CODE:
3266     filter_add(filter_call, NULL);
3267
3268 BOOT:
3269 {
3270     CV *asscv = get_cv("XS::APItest::postinc", 0);
3271     cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
3272 }
3273
3274 SV *
3275 lv_temp_object()
3276 CODE:
3277     RETVAL =
3278           sv_bless(
3279             newRV_noinc(newSV(0)),
3280             gv_stashpvs("XS::APItest::TempObj",GV_ADD)
3281           );             /* Package defined in test script */
3282 OUTPUT:
3283     RETVAL
3284
3285 void
3286 fill_hash_with_nulls(HV *hv)
3287 PREINIT:
3288     UV i = 0;
3289 CODE:
3290     for(; i < 1000; ++i) {
3291         HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
3292         SvREFCNT_dec(HeVAL(entry));
3293         HeVAL(entry) = NULL;
3294     }
3295
3296 HV *
3297 newHVhv(HV *hv)
3298 CODE:
3299     RETVAL = newHVhv(hv);
3300 OUTPUT:
3301     RETVAL
3302
3303 U32
3304 SvIsCOW(SV *sv)
3305 CODE:
3306     RETVAL = SvIsCOW(sv);
3307 OUTPUT:
3308     RETVAL
3309
3310 void
3311 pad_scalar(...)
3312 PROTOTYPE: $$
3313 CODE:
3314     PERL_UNUSED_VAR(items);
3315     croak("pad_scalar called as a function");
3316
3317 BOOT:
3318 {
3319     CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
3320     cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
3321 }
3322
3323 SV*
3324 fetch_pad_names( cv )
3325 CV* cv
3326  PREINIT:
3327   I32 i;
3328   PADNAMELIST *pad_namelist;
3329   AV *retav = newAV();
3330  CODE:
3331   pad_namelist = PadlistNAMES(CvPADLIST(cv));
3332
3333   for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
3334     PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
3335
3336     if (PadnameLEN(name)) {
3337         av_push(retav, newSVpadname(name));
3338     }
3339   }
3340   RETVAL = newRV_noinc((SV*)retav);
3341  OUTPUT:
3342   RETVAL
3343
3344 STRLEN
3345 underscore_length()
3346 PROTOTYPE:
3347 PREINIT:
3348     SV *u;
3349     U8 *pv;
3350     STRLEN bytelen;
3351 CODE:
3352     u = find_rundefsv();
3353     pv = (U8*)SvPV(u, bytelen);
3354     RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
3355 OUTPUT:
3356     RETVAL
3357
3358 void
3359 stringify(SV *sv)
3360 PREINIT:
3361     const char *pv;
3362 CODE:
3363     pv = SvPV_nolen(sv);
3364
3365 SV *
3366 HvENAME(HV *hv)
3367 CODE:
3368     RETVAL = hv && HvENAME(hv)
3369               ? newSVpvn_flags(
3370                   HvENAME(hv),HvENAMELEN(hv),
3371                   (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
3372                 )
3373               : NULL;
3374 OUTPUT:
3375     RETVAL
3376
3377 int
3378 xs_cmp(int a, int b)
3379 CODE:
3380     /* Odd sorting (odd numbers first), to make sure we are actually
3381        being called */
3382     RETVAL = a % 2 != b % 2
3383                ? a % 2 ? -1 : 1
3384                : a < b ? -1 : a == b ? 0 : 1;
3385 OUTPUT:
3386     RETVAL
3387
3388 SV *
3389 xs_cmp_undef(SV *a, SV *b)
3390 CODE:
3391     RETVAL = &PL_sv_undef;
3392 OUTPUT:
3393     RETVAL
3394
3395 char *
3396 SvPVbyte(SV *sv)
3397 CODE:
3398     RETVAL = SvPVbyte_nolen(sv);
3399 OUTPUT:
3400     RETVAL
3401
3402 char *
3403 SvPVutf8(SV *sv)
3404 CODE:
3405     RETVAL = SvPVutf8_nolen(sv);
3406 OUTPUT:
3407     RETVAL
3408
3409 void
3410 setup_addissub()
3411 CODE:
3412     wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
3413
3414 void
3415 setup_rv2cv_addunderbar()
3416 CODE:
3417     wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv);
3418
3419 #ifdef USE_ITHREADS
3420
3421 bool
3422 test_alloccopstash()
3423 CODE:
3424     RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
3425 OUTPUT:
3426     RETVAL
3427
3428 #endif
3429
3430 bool
3431 test_newFOROP_without_slab()
3432 CODE:
3433     {
3434         const I32 floor = start_subparse(0,0);
3435         CV * const cv = PL_compcv;
3436         /* The slab allocator does not like CvROOT being set. */
3437         CvROOT(PL_compcv) = (OP *)1;
3438         op_free(newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0));
3439         CvROOT(PL_compcv) = NULL;
3440         SvREFCNT_dec(PL_compcv);
3441         LEAVE_SCOPE(floor);
3442         /* If we have not crashed yet, then the test passes. */
3443         RETVAL = TRUE;
3444     }
3445 OUTPUT:
3446     RETVAL
3447
3448  # provide access to CALLREGEXEC, except replace pointers within the
3449  # string with offsets from the start of the string
3450
3451 I32
3452 callregexec(SV *prog, STRLEN stringarg, STRLEN strend, I32 minend, SV *sv, U32 nosave)
3453 CODE:
3454     {
3455         STRLEN len;
3456         char *strbeg;
3457         if (SvROK(prog))
3458             prog = SvRV(prog);
3459         strbeg = SvPV_force(sv, len);
3460         RETVAL = CALLREGEXEC((REGEXP *)prog,
3461                             strbeg + stringarg,
3462                             strbeg + strend,
3463                             strbeg,
3464                             minend,
3465                             sv,
3466                             NULL, /* data */
3467                             nosave);
3468     }
3469 OUTPUT:
3470     RETVAL
3471
3472 void
3473 lexical_import(SV *name, CV *cv)
3474     CODE:
3475     {
3476         PADLIST *pl;
3477         PADOFFSET off;
3478         if (!PL_compcv)
3479             Perl_croak(aTHX_
3480                       "lexical_import can only be called at compile time");
3481         pl = CvPADLIST(PL_compcv);
3482         ENTER;
3483         SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl);
3484         SAVESPTR(PL_comppad);      PL_comppad      = PadlistARRAY(pl)[1];
3485         SAVESPTR(PL_curpad);       PL_curpad       = PadARRAY(PL_comppad);
3486         off = pad_add_name_sv(sv_2mortal(newSVpvf("&%"SVf,name)),
3487                               padadd_STATE, 0, 0);
3488         SvREFCNT_dec(PL_curpad[off]);
3489         PL_curpad[off] = SvREFCNT_inc(cv);
3490         LEAVE;
3491     }
3492
3493 SV *
3494 sv_mortalcopy(SV *sv)
3495     CODE:
3496         RETVAL = SvREFCNT_inc(sv_mortalcopy(sv));
3497     OUTPUT:
3498         RETVAL
3499
3500 SV *
3501 newRV(SV *sv)
3502
3503 void
3504 alias_av(AV *av, IV ix, SV *sv)
3505     CODE:
3506         av_store(av, ix, SvREFCNT_inc(sv));
3507
3508 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
3509
3510 int
3511 AUTOLOAD(...)
3512   INIT:
3513     SV* comms;
3514     SV* class_and_method;
3515   CODE:
3516     class_and_method = GvSV(CvGV(cv));
3517     comms = get_sv("main::the_method", 1);
3518     if (class_and_method == NULL) {
3519       RETVAL = 1;
3520     } else if (!SvOK(class_and_method)) {
3521       RETVAL = 2;
3522     } else if (!SvPOK(class_and_method)) {
3523       RETVAL = 3;
3524     } else {
3525       sv_setsv(comms, class_and_method);
3526       RETVAL = 0;
3527     }
3528   OUTPUT: RETVAL
3529
3530
3531 MODULE = XS::APItest            PACKAGE = XS::APItest::Magic
3532
3533 PROTOTYPES: DISABLE
3534
3535 void
3536 sv_magic_foo(SV *sv, SV *thingy)
3537 ALIAS:
3538     sv_magic_bar = 1
3539 CODE:
3540     sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
3541
3542 SV *
3543 mg_find_foo(SV *sv)
3544 ALIAS:
3545     mg_find_bar = 1
3546 CODE:
3547     MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
3548     RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef;
3549 OUTPUT:
3550     RETVAL
3551
3552 void
3553 sv_unmagic_foo(SV *sv)
3554 ALIAS:
3555     sv_unmagic_bar = 1
3556 CODE:
3557     sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
3558
3559 UV
3560 test_get_vtbl()
3561     PREINIT:
3562         MGVTBL *have;
3563         MGVTBL *want;
3564     CODE:
3565 #define test_get_this_vtable(name) \
3566         want = CAT2(&PL_vtbl_, name); \
3567         have = get_vtbl(CAT2(want_vtbl_, name)); \
3568         if (have != want) \
3569             croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
3570
3571         test_get_this_vtable(sv);
3572         test_get_this_vtable(env);
3573         test_get_this_vtable(envelem);
3574         test_get_this_vtable(sigelem);
3575         test_get_this_vtable(pack);
3576         test_get_this_vtable(packelem);
3577         test_get_this_vtable(dbline);
3578         test_get_this_vtable(isa);
3579         test_get_this_vtable(isaelem);
3580         test_get_this_vtable(arylen);
3581         test_get_this_vtable(mglob);
3582         test_get_this_vtable(nkeys);
3583         test_get_this_vtable(taint);
3584         test_get_this_vtable(substr);
3585         test_get_this_vtable(vec);
3586         test_get_this_vtable(pos);
3587         test_get_this_vtable(bm);
3588         test_get_this_vtable(fm);
3589         test_get_this_vtable(uvar);
3590         test_get_this_vtable(defelem);
3591         test_get_this_vtable(regexp);
3592         test_get_this_vtable(regdata);
3593         test_get_this_vtable(regdatum);
3594 #ifdef USE_LOCALE_COLLATE
3595         test_get_this_vtable(collxfrm);
3596 #endif
3597         test_get_this_vtable(backref);
3598         test_get_this_vtable(utf8);
3599
3600         RETVAL = PTR2UV(get_vtbl(-1));
3601     OUTPUT:
3602         RETVAL
3603
3604 bool
3605 test_isBLANK_uni(UV ord)
3606     CODE:
3607         RETVAL = isBLANK_uni(ord);
3608     OUTPUT:
3609         RETVAL
3610
3611 bool
3612 test_isBLANK_LC_uvchr(UV ord)
3613     CODE:
3614         RETVAL = isBLANK_LC_uvchr(ord);
3615     OUTPUT:
3616         RETVAL
3617
3618 bool
3619 test_isBLANK_A(UV ord)
3620     CODE:
3621         RETVAL = isBLANK_A(ord);
3622     OUTPUT:
3623         RETVAL
3624
3625 bool
3626 test_isBLANK_L1(UV ord)
3627     CODE:
3628         RETVAL = isBLANK_L1(ord);
3629     OUTPUT:
3630         RETVAL
3631
3632 bool
3633 test_isBLANK_LC(UV ord)
3634     CODE:
3635         RETVAL = isBLANK_LC(ord);
3636     OUTPUT:
3637         RETVAL
3638
3639 bool
3640 test_isBLANK_utf8(unsigned char * p)
3641     CODE:
3642         RETVAL = isBLANK_utf8(p);
3643     OUTPUT:
3644         RETVAL
3645
3646 bool
3647 test_isBLANK_LC_utf8(unsigned char * p)
3648     CODE:
3649         RETVAL = isBLANK_LC_utf8(p);
3650     OUTPUT:
3651         RETVAL
3652
3653 bool
3654 test_isVERTWS_uni(UV ord)
3655     CODE:
3656         RETVAL = isVERTWS_uni(ord);
3657     OUTPUT:
3658         RETVAL
3659
3660 bool
3661 test_isVERTWS_utf8(unsigned char * p)
3662     CODE:
3663         RETVAL = isVERTWS_utf8(p);
3664     OUTPUT:
3665         RETVAL
3666
3667 bool
3668 test_isUPPER_uni(UV ord)
3669     CODE:
3670         RETVAL = isUPPER_uni(ord);
3671     OUTPUT:
3672         RETVAL
3673
3674 bool
3675 test_isUPPER_LC_uvchr(UV ord)
3676     CODE:
3677         RETVAL = isUPPER_LC_uvchr(ord);
3678     OUTPUT:
3679         RETVAL
3680
3681 bool
3682 test_isUPPER_A(UV ord)
3683     CODE:
3684         RETVAL = isUPPER_A(ord);
3685     OUTPUT:
3686         RETVAL
3687
3688 bool
3689 test_isUPPER_L1(UV ord)
3690     CODE:
3691         RETVAL = isUPPER_L1(ord);
3692     OUTPUT:
3693         RETVAL
3694
3695 bool
3696 test_isUPPER_LC(UV ord)
3697     CODE:
3698         RETVAL = isUPPER_LC(ord);
3699     OUTPUT:
3700         RETVAL
3701
3702 bool
3703 test_isUPPER_utf8(unsigned char * p)
3704     CODE:
3705         RETVAL = isUPPER_utf8( p);
3706     OUTPUT:
3707         RETVAL
3708
3709 bool
3710 test_isUPPER_LC_utf8(unsigned char * p)
3711     CODE:
3712         RETVAL = isUPPER_LC_utf8( p);
3713     OUTPUT:
3714         RETVAL
3715
3716 bool
3717 test_isLOWER_uni(UV ord)
3718     CODE:
3719         RETVAL = isLOWER_uni(ord);
3720     OUTPUT:
3721         RETVAL
3722
3723 bool
3724 test_isLOWER_LC_uvchr(UV ord)
3725     CODE:
3726         RETVAL = isLOWER_LC_uvchr(ord);
3727     OUTPUT:
3728         RETVAL
3729
3730 bool
3731 test_isLOWER_A(UV ord)
3732     CODE:
3733         RETVAL = isLOWER_A(ord);
3734     OUTPUT:
3735         RETVAL
3736
3737 bool
3738 test_isLOWER_L1(UV ord)
3739     CODE:
3740         RETVAL = isLOWER_L1(ord);
3741     OUTPUT:
3742         RETVAL
3743
3744 bool
3745 test_isLOWER_LC(UV ord)
3746     CODE:
3747         RETVAL = isLOWER_LC(ord);
3748     OUTPUT:
3749         RETVAL
3750
3751 bool
3752 test_isLOWER_utf8(unsigned char * p)
3753     CODE:
3754         RETVAL = isLOWER_utf8( p);
3755     OUTPUT:
3756         RETVAL
3757
3758 bool
3759 test_isLOWER_LC_utf8(unsigned char * p)
3760     CODE:
3761         RETVAL = isLOWER_LC_utf8( p);
3762     OUTPUT:
3763         RETVAL
3764
3765 bool
3766 test_isALPHA_uni(UV ord)
3767     CODE:
3768         RETVAL = isALPHA_uni(ord);
3769     OUTPUT:
3770         RETVAL
3771
3772 bool
3773 test_isALPHA_LC_uvchr(UV ord)
3774     CODE:
3775         RETVAL = isALPHA_LC_uvchr(ord);
3776     OUTPUT:
3777         RETVAL
3778
3779 bool
3780 test_isALPHA_A(UV ord)
3781     CODE:
3782         RETVAL = isALPHA_A(ord);
3783     OUTPUT:
3784         RETVAL
3785
3786 bool
3787 test_isALPHA_L1(UV ord)
3788     CODE:
3789         RETVAL = isALPHA_L1(ord);
3790     OUTPUT:
3791         RETVAL
3792
3793 bool
3794 test_isALPHA_LC(UV ord)
3795     CODE:
3796         RETVAL = isALPHA_LC(ord);
3797     OUTPUT:
3798         RETVAL
3799
3800 bool
3801 test_isALPHA_utf8(unsigned char * p)
3802     CODE:
3803         RETVAL = isALPHA_utf8( p);
3804     OUTPUT:
3805         RETVAL
3806
3807 bool
3808 test_isALPHA_LC_utf8(unsigned char * p)
3809     CODE:
3810         RETVAL = isALPHA_LC_utf8( p);
3811     OUTPUT:
3812         RETVAL
3813
3814 bool
3815 test_isWORDCHAR_uni(UV ord)
3816     CODE:
3817         RETVAL = isWORDCHAR_uni(ord);
3818     OUTPUT:
3819         RETVAL
3820
3821 bool
3822 test_isWORDCHAR_LC_uvchr(UV ord)
3823     CODE:
3824         RETVAL = isWORDCHAR_LC_uvchr(ord);
3825     OUTPUT:
3826         RETVAL
3827
3828 bool
3829 test_isWORDCHAR_A(UV ord)
3830     CODE:
3831         RETVAL = isWORDCHAR_A(ord);
3832     OUTPUT:
3833         RETVAL
3834
3835 bool
3836 test_isWORDCHAR_L1(UV ord)
3837     CODE:
3838         RETVAL = isWORDCHAR_L1(ord);
3839     OUTPUT:
3840         RETVAL
3841
3842 bool
3843 test_isWORDCHAR_LC(UV ord)
3844     CODE:
3845         RETVAL = isWORDCHAR_LC(ord);
3846     OUTPUT:
3847         RETVAL
3848
3849 bool
3850 test_isWORDCHAR_utf8(unsigned char * p)
3851     CODE:
3852         RETVAL = isWORDCHAR_utf8( p);
3853     OUTPUT:
3854         RETVAL
3855
3856 bool
3857 test_isWORDCHAR_LC_utf8(unsigned char * p)
3858     CODE:
3859         RETVAL = isWORDCHAR_LC_utf8( p);
3860     OUTPUT:
3861         RETVAL
3862
3863 bool
3864 test_isALPHANUMERIC_uni(UV ord)
3865     CODE:
3866         RETVAL = isALPHANUMERIC_uni(ord);
3867     OUTPUT:
3868         RETVAL
3869
3870 bool
3871 test_isALPHANUMERIC_LC_uvchr(UV ord)
3872     CODE:
3873         RETVAL = isALPHANUMERIC_LC_uvchr(ord);
3874     OUTPUT:
3875         RETVAL
3876
3877 bool
3878 test_isALPHANUMERIC_A(UV ord)
3879     CODE:
3880         RETVAL = isALPHANUMERIC_A(ord);
3881     OUTPUT:
3882         RETVAL
3883
3884 bool
3885 test_isALPHANUMERIC_L1(UV ord)
3886     CODE:
3887         RETVAL = isALPHANUMERIC_L1(ord);
3888     OUTPUT:
3889         RETVAL
3890
3891 bool
3892 test_isALPHANUMERIC_LC(UV ord)
3893     CODE:
3894         RETVAL = isALPHANUMERIC_LC(ord);
3895     OUTPUT:
3896         RETVAL
3897
3898 bool
3899 test_isALPHANUMERIC_utf8(unsigned char * p)
3900     CODE:
3901         RETVAL = isALPHANUMERIC_utf8( p);
3902     OUTPUT:
3903         RETVAL
3904
3905 bool
3906 test_isALPHANUMERIC_LC_utf8(unsigned char * p)
3907     CODE:
3908         RETVAL = isALPHANUMERIC_LC_utf8( p);
3909     OUTPUT:
3910         RETVAL
3911
3912 bool
3913 test_isALNUM_uni(UV ord)
3914     CODE:
3915         RETVAL = isALNUM_uni(ord);
3916     OUTPUT:
3917         RETVAL
3918
3919 bool
3920 test_isALNUM_LC_uvchr(UV ord)
3921     CODE:
3922         RETVAL = isALNUM_LC_uvchr(ord);
3923     OUTPUT:
3924         RETVAL
3925
3926 bool
3927 test_isALNUM_LC(UV ord)
3928     CODE:
3929         RETVAL = isALNUM_LC(ord);
3930     OUTPUT:
3931         RETVAL
3932
3933 bool
3934 test_isALNUM_utf8(unsigned char * p)
3935     CODE:
3936         RETVAL = isALNUM_utf8( p);
3937     OUTPUT:
3938         RETVAL
3939
3940 bool
3941 test_isALNUM_LC_utf8(unsigned char * p)
3942     CODE:
3943         RETVAL = isALNUM_LC_utf8( p);
3944     OUTPUT:
3945         RETVAL
3946
3947 bool
3948 test_isDIGIT_uni(UV ord)
3949     CODE:
3950         RETVAL = isDIGIT_uni(ord);
3951     OUTPUT:
3952         RETVAL
3953
3954 bool
3955 test_isDIGIT_LC_uvchr(UV ord)
3956     CODE:
3957         RETVAL = isDIGIT_LC_uvchr(ord);
3958     OUTPUT:
3959         RETVAL
3960
3961 bool
3962 test_isDIGIT_utf8(unsigned char * p)
3963     CODE:
3964         RETVAL = isDIGIT_utf8( p);
3965     OUTPUT:
3966         RETVAL
3967
3968 bool
3969 test_isDIGIT_LC_utf8(unsigned char * p)
3970     CODE:
3971         RETVAL = isDIGIT_LC_utf8( p);
3972     OUTPUT:
3973         RETVAL
3974
3975 bool
3976 test_isDIGIT_A(UV ord)
3977     CODE:
3978         RETVAL = isDIGIT_A(ord);
3979     OUTPUT:
3980         RETVAL
3981
3982 bool
3983 test_isDIGIT_L1(UV ord)
3984     CODE:
3985         RETVAL = isDIGIT_L1(ord);
3986     OUTPUT:
3987         RETVAL
3988
3989 bool
3990 test_isDIGIT_LC(UV ord)
3991     CODE:
3992         RETVAL = isDIGIT_LC(ord);
3993     OUTPUT:
3994         RETVAL
3995
3996 bool
3997 test_isIDFIRST_uni(UV ord)
3998     CODE:
3999         RETVAL = isIDFIRST_uni(ord);
4000     OUTPUT:
4001         RETVAL
4002
4003 bool
4004 test_isIDFIRST_LC_uvchr(UV ord)
4005     CODE:
4006         RETVAL = isIDFIRST_LC_uvchr(ord);
4007     OUTPUT:
4008         RETVAL
4009
4010 bool
4011 test_isIDFIRST_A(UV ord)
4012     CODE:
4013         RETVAL = isIDFIRST_A(ord);
4014     OUTPUT:
4015         RETVAL
4016
4017 bool
4018 test_isIDFIRST_L1(UV ord)
4019     CODE:
4020         RETVAL = isIDFIRST_L1(ord);
4021     OUTPUT:
4022         RETVAL
4023
4024 bool
4025 test_isIDFIRST_LC(UV ord)
4026     CODE:
4027         RETVAL = isIDFIRST_LC(ord);
4028     OUTPUT:
4029         RETVAL
4030
4031 bool
4032 test_isIDFIRST_utf8(unsigned char * p)
4033     CODE:
4034         RETVAL = isIDFIRST_utf8( p);
4035     OUTPUT:
4036         RETVAL
4037
4038 bool
4039 test_isIDFIRST_LC_utf8(unsigned char * p)
4040     CODE:
4041         RETVAL = isIDFIRST_LC_utf8( p);
4042     OUTPUT:
4043         RETVAL
4044
4045 bool
4046 test_isIDCONT_uni(UV ord)
4047     CODE:
4048         RETVAL = isIDCONT_uni(ord);
4049     OUTPUT:
4050         RETVAL
4051
4052 bool
4053 test_isIDCONT_LC_uvchr(UV ord)
4054     CODE:
4055         RETVAL = isIDCONT_LC_uvchr(ord);
4056     OUTPUT:
4057         RETVAL
4058
4059 bool
4060 test_isIDCONT_A(UV ord)
4061     CODE:
4062         RETVAL = isIDCONT_A(ord);
4063     OUTPUT:
4064         RETVAL
4065
4066 bool
4067 test_isIDCONT_L1(UV ord)
4068     CODE:
4069         RETVAL = isIDCONT_L1(ord);
4070     OUTPUT:
4071         RETVAL
4072
4073 bool
4074 test_isIDCONT_LC(UV ord)
4075     CODE:
4076         RETVAL = isIDCONT_LC(ord);
4077     OUTPUT:
4078         RETVAL
4079
4080 bool
4081 test_isIDCONT_utf8(unsigned char * p)
4082     CODE:
4083         RETVAL = isIDCONT_utf8( p);
4084     OUTPUT:
4085         RETVAL
4086
4087 bool
4088 test_isIDCONT_LC_utf8(unsigned char * p)
4089     CODE:
4090         RETVAL = isIDCONT_LC_utf8( p);
4091     OUTPUT:
4092         RETVAL
4093
4094 bool
4095 test_isSPACE_uni(UV ord)
4096     CODE:
4097         RETVAL = isSPACE_uni(ord);
4098     OUTPUT:
4099         RETVAL
4100
4101 bool
4102 test_isSPACE_LC_uvchr(UV ord)
4103     CODE:
4104         RETVAL = isSPACE_LC_uvchr(ord);
4105     OUTPUT:
4106         RETVAL
4107
4108 bool
4109 test_isSPACE_A(UV ord)
4110     CODE:
4111         RETVAL = isSPACE_A(ord);
4112     OUTPUT:
4113         RETVAL
4114
4115 bool
4116 test_isSPACE_L1(UV ord)
4117     CODE:
4118         RETVAL = isSPACE_L1(ord);
4119     OUTPUT:
4120         RETVAL
4121
4122 bool
4123 test_isSPACE_LC(UV ord)
4124     CODE:
4125         RETVAL = isSPACE_LC(ord);
4126     OUTPUT:
4127         RETVAL
4128
4129 bool
4130 test_isSPACE_utf8(unsigned char * p)
4131     CODE:
4132         RETVAL = isSPACE_utf8( p);
4133     OUTPUT:
4134         RETVAL
4135
4136 bool
4137 test_isSPACE_LC_utf8(unsigned char * p)
4138     CODE:
4139         RETVAL = isSPACE_LC_utf8( p);
4140     OUTPUT:
4141         RETVAL
4142
4143 bool
4144 test_isASCII_uni(UV ord)
4145     CODE:
4146         RETVAL = isASCII_uni(ord);
4147     OUTPUT:
4148         RETVAL
4149
4150 bool
4151 test_isASCII_LC_uvchr(UV ord)
4152     CODE:
4153         RETVAL = isASCII_LC_uvchr(ord);
4154     OUTPUT:
4155         RETVAL
4156
4157 bool
4158 test_isASCII_A(UV ord)
4159     CODE:
4160         RETVAL = isASCII_A(ord);
4161     OUTPUT:
4162         RETVAL
4163
4164 bool
4165 test_isASCII_L1(UV ord)
4166     CODE:
4167         RETVAL = isASCII_L1(ord);
4168     OUTPUT:
4169         RETVAL
4170
4171 bool
4172 test_isASCII_LC(UV ord)
4173     CODE:
4174         RETVAL = isASCII_LC(ord);
4175     OUTPUT:
4176         RETVAL
4177
4178 bool
4179 test_isASCII_utf8(unsigned char * p)
4180     CODE:
4181         RETVAL = isASCII_utf8( p);
4182     OUTPUT:
4183         RETVAL
4184
4185 bool
4186 test_isASCII_LC_utf8(unsigned char * p)
4187     CODE:
4188         RETVAL = isASCII_LC_utf8( p);
4189     OUTPUT:
4190         RETVAL
4191
4192 bool
4193 test_isCNTRL_uni(UV ord)
4194     CODE:
4195         RETVAL = isCNTRL_uni(ord);
4196     OUTPUT:
4197         RETVAL
4198
4199 bool
4200 test_isCNTRL_LC_uvchr(UV ord)
4201     CODE:
4202         RETVAL = isCNTRL_LC_uvchr(ord);
4203     OUTPUT:
4204         RETVAL
4205
4206 bool
4207 test_isCNTRL_A(UV ord)
4208     CODE:
4209         RETVAL = isCNTRL_A(ord);
4210     OUTPUT:
4211         RETVAL
4212
4213 bool
4214 test_isCNTRL_L1(UV ord)
4215     CODE:
4216         RETVAL = isCNTRL_L1(ord);
4217     OUTPUT:
4218         RETVAL
4219
4220 bool
4221 test_isCNTRL_LC(UV ord)
4222     CODE:
4223         RETVAL = isCNTRL_LC(ord);
4224     OUTPUT:
4225         RETVAL
4226
4227 bool
4228 test_isCNTRL_utf8(unsigned char * p)
4229     CODE:
4230         RETVAL = isCNTRL_utf8( p);
4231     OUTPUT:
4232         RETVAL
4233
4234 bool
4235 test_isCNTRL_LC_utf8(unsigned char * p)
4236     CODE:
4237         RETVAL = isCNTRL_LC_utf8( p);
4238     OUTPUT:
4239         RETVAL
4240
4241 bool
4242 test_isPRINT_uni(UV ord)
4243     CODE:
4244         RETVAL = isPRINT_uni(ord);
4245     OUTPUT:
4246         RETVAL
4247
4248 bool
4249 test_isPRINT_LC_uvchr(UV ord)
4250     CODE:
4251         RETVAL = isPRINT_LC_uvchr(ord);
4252     OUTPUT:
4253         RETVAL
4254
4255 bool
4256 test_isPRINT_A(UV ord)
4257     CODE:
4258         RETVAL = isPRINT_A(ord);
4259     OUTPUT:
4260         RETVAL
4261
4262 bool
4263 test_isPRINT_L1(UV ord)
4264     CODE:
4265         RETVAL = isPRINT_L1(ord);
4266     OUTPUT:
4267         RETVAL
4268
4269 bool
4270 test_isPRINT_LC(UV ord)
4271     CODE:
4272         RETVAL = isPRINT_LC(ord);
4273     OUTPUT:
4274         RETVAL
4275
4276 bool
4277 test_isPRINT_utf8(unsigned char * p)
4278     CODE:
4279         RETVAL = isPRINT_utf8( p);
4280     OUTPUT:
4281         RETVAL
4282
4283 bool
4284 test_isPRINT_LC_utf8(unsigned char * p)
4285     CODE:
4286         RETVAL = isPRINT_LC_utf8( p);
4287     OUTPUT:
4288         RETVAL
4289
4290 bool
4291 test_isGRAPH_uni(UV ord)
4292     CODE:
4293         RETVAL = isGRAPH_uni(ord);
4294     OUTPUT:
4295         RETVAL
4296
4297 bool
4298 test_isGRAPH_LC_uvchr(UV ord)
4299     CODE:
4300         RETVAL = isGRAPH_LC_uvchr(ord);
4301     OUTPUT:
4302         RETVAL
4303
4304 bool
4305 test_isGRAPH_A(UV ord)
4306     CODE:
4307         RETVAL = isGRAPH_A(ord);
4308     OUTPUT:
4309         RETVAL
4310
4311 bool
4312 test_isGRAPH_L1(UV ord)
4313     CODE:
4314         RETVAL = isGRAPH_L1(ord);
4315     OUTPUT:
4316         RETVAL
4317
4318 bool
4319 test_isGRAPH_LC(UV ord)
4320     CODE:
4321         RETVAL = isGRAPH_LC(ord);
4322     OUTPUT:
4323         RETVAL
4324
4325 bool
4326 test_isGRAPH_utf8(unsigned char * p)
4327     CODE:
4328         RETVAL = isGRAPH_utf8( p);
4329     OUTPUT:
4330         RETVAL
4331
4332 bool
4333 test_isGRAPH_LC_utf8(unsigned char * p)
4334     CODE:
4335         RETVAL = isGRAPH_LC_utf8( p);
4336     OUTPUT:
4337         RETVAL
4338
4339 bool
4340 test_isPUNCT_uni(UV ord)
4341     CODE:
4342         RETVAL = isPUNCT_uni(ord);
4343     OUTPUT:
4344         RETVAL
4345
4346 bool
4347 test_isPUNCT_LC_uvchr(UV ord)
4348     CODE:
4349         RETVAL = isPUNCT_LC_uvchr(ord);
4350     OUTPUT:
4351         RETVAL
4352
4353 bool
4354 test_isPUNCT_A(UV ord)
4355     CODE:
4356         RETVAL = isPUNCT_A(ord);
4357     OUTPUT:
4358         RETVAL
4359
4360 bool
4361 test_isPUNCT_L1(UV ord)
4362     CODE:
4363         RETVAL = isPUNCT_L1(ord);
4364     OUTPUT:
4365         RETVAL
4366
4367 bool
4368 test_isPUNCT_LC(UV ord)
4369     CODE:
4370         RETVAL = isPUNCT_LC(ord);
4371     OUTPUT:
4372         RETVAL
4373
4374 bool
4375 test_isPUNCT_utf8(unsigned char * p)
4376     CODE:
4377         RETVAL = isPUNCT_utf8( p);
4378     OUTPUT:
4379         RETVAL
4380
4381 bool
4382 test_isPUNCT_LC_utf8(unsigned char * p)
4383     CODE:
4384         RETVAL = isPUNCT_LC_utf8( p);
4385     OUTPUT:
4386         RETVAL
4387
4388 bool
4389 test_isXDIGIT_uni(UV ord)
4390     CODE:
4391         RETVAL = isXDIGIT_uni(ord);
4392     OUTPUT:
4393         RETVAL
4394
4395 bool
4396 test_isXDIGIT_LC_uvchr(UV ord)
4397     CODE:
4398         RETVAL = isXDIGIT_LC_uvchr(ord);
4399     OUTPUT:
4400         RETVAL
4401
4402 bool
4403 test_isXDIGIT_A(UV ord)
4404     CODE:
4405         RETVAL = isXDIGIT_A(ord);
4406     OUTPUT:
4407         RETVAL
4408
4409 bool
4410 test_isXDIGIT_L1(UV ord)
4411     CODE:
4412         RETVAL = isXDIGIT_L1(ord);
4413     OUTPUT:
4414         RETVAL
4415
4416 bool
4417 test_isXDIGIT_LC(UV ord)
4418     CODE:
4419         RETVAL = isXDIGIT_LC(ord);
4420     OUTPUT:
4421         RETVAL
4422
4423 bool
4424 test_isXDIGIT_utf8(unsigned char * p)
4425     CODE:
4426         RETVAL = isXDIGIT_utf8( p);
4427     OUTPUT:
4428         RETVAL
4429
4430 bool
4431 test_isXDIGIT_LC_utf8(unsigned char * p)
4432     CODE:
4433         RETVAL = isXDIGIT_LC_utf8( p);
4434     OUTPUT:
4435         RETVAL
4436
4437 bool
4438 test_isPSXSPC_uni(UV ord)
4439     CODE:
4440         RETVAL = isPSXSPC_uni(ord);
4441     OUTPUT:
4442         RETVAL
4443
4444 bool
4445 test_isPSXSPC_LC_uvchr(UV ord)
4446     CODE:
4447         RETVAL = isPSXSPC_LC_uvchr(ord);
4448     OUTPUT:
4449         RETVAL
4450
4451 bool
4452 test_isPSXSPC_A(UV ord)
4453     CODE:
4454         RETVAL = isPSXSPC_A(ord);
4455     OUTPUT:
4456         RETVAL
4457
4458 bool
4459 test_isPSXSPC_L1(UV ord)
4460     CODE:
4461         RETVAL = isPSXSPC_L1(ord);
4462     OUTPUT:
4463         RETVAL
4464
4465 bool
4466 test_isPSXSPC_LC(UV ord)
4467     CODE:
4468         RETVAL = isPSXSPC_LC(ord);
4469     OUTPUT:
4470         RETVAL
4471
4472 bool
4473 test_isPSXSPC_utf8(unsigned char * p)
4474     CODE:
4475         RETVAL = isPSXSPC_utf8( p);
4476     OUTPUT:
4477         RETVAL
4478
4479 bool
4480 test_isPSXSPC_LC_utf8(unsigned char * p)
4481     CODE:
4482         RETVAL = isPSXSPC_LC_utf8( p);
4483     OUTPUT:
4484         RETVAL
4485
4486 bool
4487 test_isQUOTEMETA(UV ord)
4488     CODE:
4489         RETVAL = _isQUOTEMETA(ord);
4490     OUTPUT:
4491         RETVAL
4492
4493 UV
4494 test_toLOWER(UV ord)
4495     CODE:
4496         RETVAL = toLOWER(ord);
4497     OUTPUT:
4498         RETVAL
4499
4500 UV
4501 test_toLOWER_L1(UV ord)
4502     CODE:
4503         RETVAL = toLOWER_L1(ord);
4504     OUTPUT:
4505         RETVAL
4506
4507 UV
4508 test_toLOWER_LC(UV ord)
4509     CODE:
4510         RETVAL = toLOWER_LC(ord);
4511     OUTPUT:
4512         RETVAL
4513
4514 AV *
4515 test_toLOWER_uni(UV ord)
4516     PREINIT:
4517         U8 s[UTF8_MAXBYTES_CASE + 1];
4518         STRLEN len;
4519         AV *av;
4520         SV *utf8;
4521     CODE:
4522         av = newAV();
4523         av_push(av, newSVuv(toLOWER_uni(ord, s, &len)));
4524
4525         utf8 = newSVpvn((char *) s, len);
4526         SvUTF8_on(utf8);
4527         av_push(av, utf8);
4528
4529         av_push(av, newSVuv(len));
4530         RETVAL = av;
4531     OUTPUT:
4532         RETVAL
4533
4534 AV *
4535 test_toLOWER_utf8(SV * p)
4536     PREINIT:
4537         U8 *input;
4538         U8 s[UTF8_MAXBYTES_CASE + 1];
4539         STRLEN len;
4540         AV *av;
4541         SV *utf8;
4542     CODE:
4543         input = (U8 *) SvPV(p, len);
4544         av = newAV();
4545         av_push(av, newSVuv(toLOWER_utf8(input, s, &len)));
4546
4547         utf8 = newSVpvn((char *) s, len);
4548         SvUTF8_on(utf8);
4549         av_push(av, utf8);
4550
4551         av_push(av, newSVuv(len));
4552         RETVAL = av;
4553     OUTPUT:
4554         RETVAL
4555
4556 UV
4557 test_toFOLD(UV ord)
4558     CODE:
4559         RETVAL = toFOLD(ord);
4560     OUTPUT:
4561         RETVAL
4562
4563 UV
4564 test_toFOLD_LC(UV ord)
4565     CODE:
4566         RETVAL = toFOLD_LC(ord);
4567     OUTPUT:
4568         RETVAL
4569
4570 AV *
4571 test_toFOLD_uni(UV ord)
4572     PREINIT:
4573         U8 s[UTF8_MAXBYTES_CASE + 1];
4574         STRLEN len;
4575         AV *av;
4576         SV *utf8;
4577     CODE:
4578         av = newAV();
4579         av_push(av, newSVuv(toFOLD_uni(ord, s, &len)));
4580
4581         utf8 = newSVpvn((char *) s, len);
4582         SvUTF8_on(utf8);
4583         av_push(av, utf8);
4584
4585         av_push(av, newSVuv(len));
4586         RETVAL = av;
4587     OUTPUT:
4588         RETVAL
4589
4590 AV *
4591 test_toFOLD_utf8(SV * p)
4592     PREINIT:
4593         U8 *input;
4594         U8 s[UTF8_MAXBYTES_CASE + 1];
4595         STRLEN len;
4596         AV *av;
4597         SV *utf8;
4598     CODE:
4599         input = (U8 *) SvPV(p, len);
4600         av = newAV();
4601         av_push(av, newSVuv(toFOLD_utf8(input, s, &len)));
4602
4603         utf8 = newSVpvn((char *) s, len);
4604         SvUTF8_on(utf8);
4605         av_push(av, utf8);
4606
4607         av_push(av, newSVuv(len));
4608         RETVAL = av;
4609     OUTPUT:
4610         RETVAL
4611
4612 UV
4613 test_toUPPER(UV ord)
4614     CODE:
4615         RETVAL = toUPPER(ord);
4616     OUTPUT:
4617         RETVAL
4618
4619 UV
4620 test_toUPPER_LC(UV ord)
4621     CODE:
4622         RETVAL = toUPPER_LC(ord);
4623     OUTPUT:
4624         RETVAL
4625
4626 AV *
4627 test_toUPPER_uni(UV ord)
4628     PREINIT:
4629         U8 s[UTF8_MAXBYTES_CASE + 1];
4630         STRLEN len;
4631         AV *av;
4632         SV *utf8;
4633     CODE:
4634         av = newAV();
4635         av_push(av, newSVuv(toUPPER_uni(ord, s, &len)));
4636
4637         utf8 = newSVpvn((char *) s, len);
4638         SvUTF8_on(utf8);
4639         av_push(av, utf8);
4640
4641         av_push(av, newSVuv(len));
4642         RETVAL = av;
4643     OUTPUT:
4644         RETVAL
4645
4646 AV *
4647 test_toUPPER_utf8(SV * p)
4648     PREINIT:
4649         U8 *input;
4650         U8 s[UTF8_MAXBYTES_CASE + 1];
4651         STRLEN len;
4652         AV *av;
4653         SV *utf8;
4654     CODE:
4655         input = (U8 *) SvPV(p, len);
4656         av = newAV();
4657         av_push(av, newSVuv(toUPPER_utf8(input, s, &len)));
4658
4659         utf8 = newSVpvn((char *) s, len);
4660         SvUTF8_on(utf8);
4661         av_push(av, utf8);
4662
4663         av_push(av, newSVuv(len));
4664         RETVAL = av;
4665     OUTPUT:
4666         RETVAL
4667
4668 UV
4669 test_toTITLE(UV ord)
4670     CODE:
4671         RETVAL = toTITLE(ord);
4672     OUTPUT:
4673         RETVAL
4674
4675 AV *
4676 test_toTITLE_uni(UV ord)
4677     PREINIT:
4678         U8 s[UTF8_MAXBYTES_CASE + 1];
4679         STRLEN len;
4680         AV *av;
4681         SV *utf8;
4682     CODE:
4683         av = newAV();
4684         av_push(av, newSVuv(toTITLE_uni(ord, s, &len)));
4685
4686         utf8 = newSVpvn((char *) s, len);
4687         SvUTF8_on(utf8);
4688         av_push(av, utf8);
4689
4690         av_push(av, newSVuv(len));
4691         RETVAL = av;
4692     OUTPUT:
4693         RETVAL
4694
4695 AV *
4696 test_toTITLE_utf8(SV * p)
4697     PREINIT:
4698         U8 *input;
4699         U8 s[UTF8_MAXBYTES_CASE + 1];
4700         STRLEN len;
4701         AV *av;
4702         SV *utf8;
4703     CODE:
4704         input = (U8 *) SvPV(p, len);
4705         av = newAV();
4706         av_push(av, newSVuv(toTITLE_utf8(input, s, &len)));
4707
4708         utf8 = newSVpvn((char *) s, len);
4709         SvUTF8_on(utf8);
4710         av_push(av, utf8);
4711
4712         av_push(av, newSVuv(len));
4713         RETVAL = av;
4714     OUTPUT:
4715         RETVAL