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