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