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