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