ext/XS-APItest/APItest.xs

   1 #define PERL_IN_XS_APITEST
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 typedef SV *SVREF;
   7 typedef PTR_TBL_t *XS__APItest__PtrTable;
   8
   9 #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
  10 #define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)
  11
  12 /* for my_cxt tests */
  13
  14 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
  15
  16 typedef struct {
  17     int i;
  18     SV *sv;
  19     GV *cscgv;
  20     AV *cscav;
  21     AV *bhkav;
  22     bool bhk_record;
  23     peep_t orig_peep;
  24     peep_t orig_rpeep;
  25     int peep_recording;
  26     AV *peep_recorder;
  27     AV *rpeep_recorder;
  28     AV *xop_record;
  29 } my_cxt_t;
  30
  31 START_MY_CXT
  32
  33 MGVTBL vtbl_foo, vtbl_bar;
  34
  35 /* indirect functions to test the [pa]MY_CXT macros */
  36
  37 int
  38 my_cxt_getint_p(pMY_CXT)
  39 {
  40     return MY_CXT.i;
  41 }
  42
  43 void
  44 my_cxt_setint_p(pMY_CXT_ int i)
  45 {
  46     MY_CXT.i = i;
  47 }
  48
  49 SV*
  50 my_cxt_getsv_interp_context(void)
  51 {
  52     dTHX;
  53     dMY_CXT_INTERP(my_perl);
  54     return MY_CXT.sv;
  55 }
  56
  57 SV*
  58 my_cxt_getsv_interp(void)
  59 {
  60     dMY_CXT;
  61     return MY_CXT.sv;
  62 }
  63
  64 void
  65 my_cxt_setsv_p(SV* sv _pMY_CXT)
  66 {
  67     MY_CXT.sv = sv;
  68 }
  69
  70
  71 /* from exception.c */
  72 int apitest_exception(int);
  73
  74 /* from core_or_not.inc */
  75 bool sv_setsv_cow_hashkey_core(void);
  76 bool sv_setsv_cow_hashkey_notcore(void);
  77
  78 /* A routine to test hv_delayfree_ent
  79    (which itself is tested by testing on hv_free_ent  */
  80
  81 typedef void (freeent_function)(pTHX_ HV *, register HE *);
  82
  83 void
  84 test_freeent(freeent_function *f) {
  85     dTHX;
  86     dSP;
  87     HV *test_hash = newHV();
  88     HE *victim;
  89     SV *test_scalar;
  90     U32 results[4];
  91     int i;
  92
  93 #ifdef PURIFY
  94     victim = (HE*)safemalloc(sizeof(HE));
  95 #else
  96     /* Storing then deleting something should ensure that a hash entry is
  97        available.  */
  98     (void) hv_store(test_hash, "", 0, &PL_sv_yes, 0);
  99     (void) hv_delete(test_hash, "", 0, 0);
 100
 101     /* We need to "inline" new_he here as it's static, and the functions we
 102        test expect to be able to call del_HE on the HE  */
 103     if (!PL_body_roots[HE_SVSLOT])
 104         croak("PL_he_root is 0");
 105     victim = (HE*) PL_body_roots[HE_SVSLOT];
 106     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
 107 #endif
 108
 109     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
 110
 111     test_scalar = newSV(0);
 112     SvREFCNT_inc(test_scalar);
 113     HeVAL(victim) = test_scalar;
 114
 115     /* Need this little game else we free the temps on the return stack.  */
 116     results[0] = SvREFCNT(test_scalar);
 117     SAVETMPS;
 118     results[1] = SvREFCNT(test_scalar);
 119     f(aTHX_ test_hash, victim);
 120     results[2] = SvREFCNT(test_scalar);
 121     FREETMPS;
 122     results[3] = SvREFCNT(test_scalar);
 123
 124     i = 0;
 125     do {
 126         mPUSHu(results[i]);
 127     } while (++i < (int)(sizeof(results)/sizeof(results[0])));
 128
 129     /* Goodbye to our extra reference.  */
 130     SvREFCNT_dec(test_scalar);
 131 }
 132
 133
 134 static I32
 135 bitflip_key(pTHX_ IV action, SV *field) {
 136     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 137     SV *keysv;
 138     PERL_UNUSED_ARG(action);
 139     if (mg && (keysv = mg->mg_obj)) {
 140         STRLEN len;
 141         const char *p = SvPV(keysv, len);
 142
 143         if (len) {
 144             SV *newkey = newSV(len);
 145             char *new_p = SvPVX(newkey);
 146
 147             if (SvUTF8(keysv)) {
 148                 const char *const end = p + len;
 149                 while (p < end) {
 150                     STRLEN len;
 151                     UV chr = utf8_to_uvuni((U8 *)p, &len);
 152                     new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
 153                     p += len;
 154                 }
 155                 SvUTF8_on(newkey);
 156             } else {
 157                 while (len--)
 158                     *new_p++ = *p++ ^ 32;
 159             }
 160             *new_p = '\0';
 161             SvCUR_set(newkey, SvCUR(keysv));
 162             SvPOK_on(newkey);
 163
 164             mg->mg_obj = newkey;
 165         }
 166     }
 167     return 0;
 168 }
 169
 170 static I32
 171 rot13_key(pTHX_ IV action, SV *field) {
 172     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 173     SV *keysv;
 174     PERL_UNUSED_ARG(action);
 175     if (mg && (keysv = mg->mg_obj)) {
 176         STRLEN len;
 177         const char *p = SvPV(keysv, len);
 178
 179         if (len) {
 180             SV *newkey = newSV(len);
 181             char *new_p = SvPVX(newkey);
 182
 183             /* There's a deliberate fencepost error here to loop len + 1 times
 184                to copy the trailing \0  */
 185             do {
 186                 char new_c = *p++;
 187                 /* Try doing this cleanly and clearly in EBCDIC another way: */
 188                 switch (new_c) {
 189                 case 'A': new_c = 'N'; break;
 190                 case 'B': new_c = 'O'; break;
 191                 case 'C': new_c = 'P'; break;
 192                 case 'D': new_c = 'Q'; break;
 193                 case 'E': new_c = 'R'; break;
 194                 case 'F': new_c = 'S'; break;
 195                 case 'G': new_c = 'T'; break;
 196                 case 'H': new_c = 'U'; break;
 197                 case 'I': new_c = 'V'; break;
 198                 case 'J': new_c = 'W'; break;
 199                 case 'K': new_c = 'X'; break;
 200                 case 'L': new_c = 'Y'; break;
 201                 case 'M': new_c = 'Z'; break;
 202                 case 'N': new_c = 'A'; break;
 203                 case 'O': new_c = 'B'; break;
 204                 case 'P': new_c = 'C'; break;
 205                 case 'Q': new_c = 'D'; break;
 206                 case 'R': new_c = 'E'; break;
 207                 case 'S': new_c = 'F'; break;
 208                 case 'T': new_c = 'G'; break;
 209                 case 'U': new_c = 'H'; break;
 210                 case 'V': new_c = 'I'; break;
 211                 case 'W': new_c = 'J'; break;
 212                 case 'X': new_c = 'K'; break;
 213                 case 'Y': new_c = 'L'; break;
 214                 case 'Z': new_c = 'M'; break;
 215                 case 'a': new_c = 'n'; break;
 216                 case 'b': new_c = 'o'; break;
 217                 case 'c': new_c = 'p'; break;
 218                 case 'd': new_c = 'q'; break;
 219                 case 'e': new_c = 'r'; break;
 220                 case 'f': new_c = 's'; break;
 221                 case 'g': new_c = 't'; break;
 222                 case 'h': new_c = 'u'; break;
 223                 case 'i': new_c = 'v'; break;
 224                 case 'j': new_c = 'w'; break;
 225                 case 'k': new_c = 'x'; break;
 226                 case 'l': new_c = 'y'; break;
 227                 case 'm': new_c = 'z'; break;
 228                 case 'n': new_c = 'a'; break;
 229                 case 'o': new_c = 'b'; break;
 230                 case 'p': new_c = 'c'; break;
 231                 case 'q': new_c = 'd'; break;
 232                 case 'r': new_c = 'e'; break;
 233                 case 's': new_c = 'f'; break;
 234                 case 't': new_c = 'g'; break;
 235                 case 'u': new_c = 'h'; break;
 236                 case 'v': new_c = 'i'; break;
 237                 case 'w': new_c = 'j'; break;
 238                 case 'x': new_c = 'k'; break;
 239                 case 'y': new_c = 'l'; break;
 240                 case 'z': new_c = 'm'; break;
 241                 }
 242                 *new_p++ = new_c;
 243             } while (len--);
 244             SvCUR_set(newkey, SvCUR(keysv));
 245             SvPOK_on(newkey);
 246             if (SvUTF8(keysv))
 247                 SvUTF8_on(newkey);
 248
 249             mg->mg_obj = newkey;
 250         }
 251     }
 252     return 0;
 253 }
 254
 255 STATIC I32
 256 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
 257     PERL_UNUSED_ARG(idx);
 258     PERL_UNUSED_ARG(sv);
 259     return 0;
 260 }
 261
 262 STATIC MGVTBL rmagical_b = { 0 };
 263
 264 STATIC void
 265 blockhook_csc_start(pTHX_ int full)
 266 {
 267     dMY_CXT;
 268     AV *const cur = GvAV(MY_CXT.cscgv);
 269
 270     PERL_UNUSED_ARG(full);
 271     SAVEGENERICSV(GvAV(MY_CXT.cscgv));
 272
 273     if (cur) {
 274         I32 i;
 275         AV *const new_av = newAV();
 276
 277         for (i = 0; i <= av_len(cur); i++) {
 278             av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
 279         }
 280
 281         GvAV(MY_CXT.cscgv) = new_av;
 282     }
 283 }
 284
 285 STATIC void
 286 blockhook_csc_pre_end(pTHX_ OP **o)
 287 {
 288     dMY_CXT;
 289
 290     PERL_UNUSED_ARG(o);
 291     /* if we hit the end of a scope we missed the start of, we need to
 292      * unconditionally clear @CSC */
 293     if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
 294         av_clear(MY_CXT.cscav);
 295     }
 296
 297 }
 298
 299 STATIC void
 300 blockhook_test_start(pTHX_ int full)
 301 {
 302     dMY_CXT;
 303     AV *av;
 304
 305     if (MY_CXT.bhk_record) {
 306         av = newAV();
 307         av_push(av, newSVpvs("start"));
 308         av_push(av, newSViv(full));
 309         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 310     }
 311 }
 312
 313 STATIC void
 314 blockhook_test_pre_end(pTHX_ OP **o)
 315 {
 316     dMY_CXT;
 317
 318     PERL_UNUSED_ARG(o);
 319     if (MY_CXT.bhk_record)
 320         av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
 321 }
 322
 323 STATIC void
 324 blockhook_test_post_end(pTHX_ OP **o)
 325 {
 326     dMY_CXT;
 327
 328     PERL_UNUSED_ARG(o);
 329     if (MY_CXT.bhk_record)
 330         av_push(MY_CXT.bhkav, newSVpvs("post_end"));
 331 }
 332
 333 STATIC void
 334 blockhook_test_eval(pTHX_ OP *const o)
 335 {
 336     dMY_CXT;
 337     AV *av;
 338
 339     if (MY_CXT.bhk_record) {
 340         av = newAV();
 341         av_push(av, newSVpvs("eval"));
 342         av_push(av, newSVpv(OP_NAME(o), 0));
 343         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 344     }
 345 }
 346
 347 STATIC BHK bhk_csc, bhk_test;
 348
 349 STATIC void
 350 my_peep (pTHX_ OP *o)
 351 {
 352     dMY_CXT;
 353
 354     if (!o)
 355         return;
 356
 357     MY_CXT.orig_peep(aTHX_ o);
 358
 359     if (!MY_CXT.peep_recording)
 360         return;
 361
 362     for (; o; o = o->op_next) {
 363         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
 364             av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
 365         }
 366     }
 367 }
 368
 369 STATIC void
 370 my_rpeep (pTHX_ OP *o)
 371 {
 372     dMY_CXT;
 373
 374     if (!o)
 375         return;
 376
 377     MY_CXT.orig_rpeep(aTHX_ o);
 378
 379     if (!MY_CXT.peep_recording)
 380         return;
 381
 382     for (; o; o = o->op_next) {
 383         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
 384             av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
 385         }
 386     }
 387 }
 388
 389 STATIC OP *
 390 THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 391 {
 392     PERL_UNUSED_ARG(namegv);
 393     PERL_UNUSED_ARG(ckobj);
 394     return ck_entersub_args_list(entersubop);
 395 }
 396
 397 STATIC OP *
 398 THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 399 {
 400     OP *aop = cUNOPx(entersubop)->op_first;
 401     PERL_UNUSED_ARG(namegv);
 402     PERL_UNUSED_ARG(ckobj);
 403     if (!aop->op_sibling)
 404         aop = cUNOPx(aop)->op_first;
 405     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
 406         op_contextualize(aop, G_SCALAR);
 407     }
 408     return entersubop;
 409 }
 410
 411 STATIC OP *
 412 THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 413 {
 414     OP *sumop = NULL;
 415     OP *pushop = cUNOPx(entersubop)->op_first;
 416     PERL_UNUSED_ARG(namegv);
 417     PERL_UNUSED_ARG(ckobj);
 418     if (!pushop->op_sibling)
 419         pushop = cUNOPx(pushop)->op_first;
 420     while (1) {
 421         OP *aop = pushop->op_sibling;
 422         if (!aop->op_sibling)
 423             break;
 424         pushop->op_sibling = aop->op_sibling;
 425         aop->op_sibling = NULL;
 426         op_contextualize(aop, G_SCALAR);
 427         if (sumop) {
 428             sumop = newBINOP(OP_ADD, 0, sumop, aop);
 429         } else {
 430             sumop = aop;
 431         }
 432     }
 433     if (!sumop)
 434         sumop = newSVOP(OP_CONST, 0, newSViv(0));
 435     op_free(entersubop);
 436     return sumop;
 437 }
 438
 439 STATIC void test_op_list_describe_part(SV *res, OP *o);
 440 STATIC void
 441 test_op_list_describe_part(SV *res, OP *o)
 442 {
 443     sv_catpv(res, PL_op_name[o->op_type]);
 444     switch (o->op_type) {
 445         case OP_CONST: {
 446             sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
 447         } break;
 448     }
 449     if (o->op_flags & OPf_KIDS) {
 450         OP *k;
 451         sv_catpvs(res, "[");
 452         for (k = cUNOPx(o)->op_first; k; k = k->op_sibling)
 453             test_op_list_describe_part(res, k);
 454         sv_catpvs(res, "]");
 455     } else {
 456         sv_catpvs(res, ".");
 457     }
 458 }
 459
 460 STATIC char *
 461 test_op_list_describe(OP *o)
 462 {
 463     SV *res = sv_2mortal(newSVpvs(""));
 464     if (o)
 465         test_op_list_describe_part(res, o);
 466     return SvPVX(res);
 467 }
 468
 469 /* the real new*OP functions have a tendency to call fold_constants, and
 470  * other such unhelpful things, so we need our own versions for testing */
 471
 472 #define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
 473 static OP *
 474 THX_mkUNOP(pTHX_ U32 type, OP *first)
 475 {
 476     UNOP *unop;
 477     NewOp(1103, unop, 1, UNOP);
 478     unop->op_type   = (OPCODE)type;
 479     unop->op_first  = first;
 480     unop->op_flags  = OPf_KIDS;
 481     return (OP *)unop;
 482 }
 483
 484 #define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
 485 static OP *
 486 THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
 487 {
 488     BINOP *binop;
 489     NewOp(1103, binop, 1, BINOP);
 490     binop->op_type      = (OPCODE)type;
 491     binop->op_first     = first;
 492     binop->op_flags     = OPf_KIDS;
 493     binop->op_last      = last;
 494     first->op_sibling   = last;
 495     return (OP *)binop;
 496 }
 497
 498 #define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
 499 static OP *
 500 THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
 501 {
 502     LISTOP *listop;
 503     NewOp(1103, listop, 1, LISTOP);
 504     listop->op_type     = (OPCODE)type;
 505     listop->op_flags    = OPf_KIDS;
 506     listop->op_first    = first;
 507     first->op_sibling   = sib;
 508     sib->op_sibling     = last;
 509     listop->op_last     = last;
 510     return (OP *)listop;
 511 }
 512
 513 static char *
 514 test_op_linklist_describe(OP *start)
 515 {
 516     SV *rv = sv_2mortal(newSVpvs(""));
 517     OP *o;
 518     o = start = LINKLIST(start);
 519     do {
 520         sv_catpvs(rv, ".");
 521         sv_catpv(rv, OP_NAME(o));
 522         if (o->op_type == OP_CONST)
 523             sv_catsv(rv, cSVOPo->op_sv);
 524         o = o->op_next;
 525     } while (o && o != start);
 526     return SvPVX(rv);
 527 }
 528
 529 /** establish_cleanup operator, ripped off from Scope::Cleanup **/
 530
 531 STATIC void
 532 THX_run_cleanup(pTHX_ void *cleanup_code_ref)
 533 {
 534     dSP;
 535     ENTER;
 536     SAVETMPS;
 537     PUSHMARK(SP);
 538     call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
 539     FREETMPS;
 540     LEAVE;
 541 }
 542
 543 STATIC OP *
 544 THX_pp_establish_cleanup(pTHX)
 545 {
 546     dSP;
 547     SV *cleanup_code_ref;
 548     cleanup_code_ref = newSVsv(POPs);
 549     SAVEFREESV(cleanup_code_ref);
 550     SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref);
 551     if(GIMME_V != G_VOID) PUSHs(&PL_sv_undef);
 552     RETURN;
 553 }
 554
 555 STATIC OP *
 556 THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 557 {
 558     OP *pushop, *argop, *estop;
 559     ck_entersub_args_proto(entersubop, namegv, ckobj);
 560     pushop = cUNOPx(entersubop)->op_first;
 561     if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
 562     argop = pushop->op_sibling;
 563     pushop->op_sibling = argop->op_sibling;
 564     argop->op_sibling = NULL;
 565     op_free(entersubop);
 566     NewOpSz(0, estop, sizeof(UNOP));
 567     estop->op_type = OP_RAND;
 568     estop->op_ppaddr = THX_pp_establish_cleanup;
 569     cUNOPx(estop)->op_flags = OPf_KIDS;
 570     cUNOPx(estop)->op_first = argop;
 571     PL_hints |= HINT_BLOCK_SCOPE;
 572     return estop;
 573 }
 574
 575 STATIC OP *
 576 THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 577 {
 578     OP *pushop, *argop;
 579     ck_entersub_args_proto(entersubop, namegv, ckobj);
 580     pushop = cUNOPx(entersubop)->op_first;
 581     if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
 582     argop = pushop->op_sibling;
 583     pushop->op_sibling = argop->op_sibling;
 584     argop->op_sibling = NULL;
 585     op_free(entersubop);
 586     return newUNOP(OP_POSTINC, 0,
 587         op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
 588 }
 589
 590 STATIC OP *
 591 THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 592 {
 593     OP *pushop, *argop;
 594     PADOFFSET padoff = NOT_IN_PAD;
 595     SV *a0, *a1;
 596     ck_entersub_args_proto(entersubop, namegv, ckobj);
 597     pushop = cUNOPx(entersubop)->op_first;
 598     if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
 599     argop = pushop->op_sibling;
 600     if(argop->op_type != OP_CONST || argop->op_sibling->op_type != OP_CONST)
 601         croak("bad argument expression type for pad_scalar()");
 602     a0 = cSVOPx_sv(argop);
 603     a1 = cSVOPx_sv(argop->op_sibling);
 604     switch(SvIV(a0)) {
 605         case 1: {
 606             SV *namesv = sv_2mortal(newSVpvs("$"));
 607             sv_catsv(namesv, a1);
 608             padoff = pad_findmy_sv(namesv, 0);
 609         } break;
 610         case 2: {
 611             char *namepv;
 612             STRLEN namelen;
 613             SV *namesv = sv_2mortal(newSVpvs("$"));
 614             sv_catsv(namesv, a1);
 615             namepv = SvPV(namesv, namelen);
 616             padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv));
 617         } break;
 618         case 3: {
 619             char *namepv;
 620             SV *namesv = sv_2mortal(newSVpvs("$"));
 621             sv_catsv(namesv, a1);
 622             namepv = SvPV_nolen(namesv);
 623             padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
 624         } break;
 625         case 4: {
 626             padoff = pad_findmy_pvs("$foo", 0);
 627         } break;
 628         default: croak("bad type value for pad_scalar()");
 629     }
 630     op_free(entersubop);
 631     if(padoff == NOT_IN_PAD) {
 632         return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
 633     } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
 634         return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
 635     } else {
 636         OP *padop = newOP(OP_PADSV, 0);
 637         padop->op_targ = padoff;
 638         return padop;
 639     }
 640 }
 641
 642 /** RPN keyword parser **/
 643
 644 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
 645 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
 646 #define sv_is_string(sv) \
 647     (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
 648      (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
 649
 650 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
 651 static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
 652 static SV *hintkey_scopelessblock_sv;
 653 static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
 654 static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
 655 static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv;
 656 static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
 657 static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
 658 static SV *hintkey_arrayexprflags_sv;
 659 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
 660
 661 /* low-level parser helpers */
 662
 663 #define PL_bufptr (PL_parser->bufptr)
 664 #define PL_bufend (PL_parser->bufend)
 665
 666 /* RPN parser */
 667
 668 #define parse_var() THX_parse_var(aTHX)
 669 static OP *THX_parse_var(pTHX)
 670 {
 671     char *s = PL_bufptr;
 672     char *start = s;
 673     PADOFFSET varpos;
 674     OP *padop;
 675     if(*s != '$') croak("RPN syntax error");
 676     while(1) {
 677         char c = *++s;
 678         if(!isALNUM(c)) break;
 679     }
 680     if(s-start < 2) croak("RPN syntax error");
 681     lex_read_to(s);
 682     varpos = pad_findmy_pvn(start, s-start, 0);
 683     if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
 684         croak("RPN only supports \"my\" variables");
 685     padop = newOP(OP_PADSV, 0);
 686     padop->op_targ = varpos;
 687     return padop;
 688 }
 689
 690 #define push_rpn_item(o) \
 691     (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
 692 #define pop_rpn_item() \
 693     (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
 694      (tmpop = stack, stack = stack->op_sibling, \
 695       tmpop->op_sibling = NULL, tmpop))
 696
 697 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
 698 static OP *THX_parse_rpn_expr(pTHX)
 699 {
 700     OP *stack = NULL, *tmpop;
 701     while(1) {
 702         I32 c;
 703         lex_read_space(0);
 704         c = lex_peek_unichar(0);
 705         switch(c) {
 706             case /*(*/')': case /*{*/'}': {
 707                 OP *result = pop_rpn_item();
 708                 if(stack) croak("RPN expression must return a single value");
 709                 return result;
 710             } break;
 711             case '0': case '1': case '2': case '3': case '4':
 712             case '5': case '6': case '7': case '8': case '9': {
 713                 UV val = 0;
 714                 do {
 715                     lex_read_unichar(0);
 716                     val = 10*val + (c - '0');
 717                     c = lex_peek_unichar(0);
 718                 } while(c >= '0' && c <= '9');
 719                 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
 720             } break;
 721             case '$': {
 722                 push_rpn_item(parse_var());
 723             } break;
 724             case '+': {
 725                 OP *b = pop_rpn_item();
 726                 OP *a = pop_rpn_item();
 727                 lex_read_unichar(0);
 728                 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
 729             } break;
 730             case '-': {
 731                 OP *b = pop_rpn_item();
 732                 OP *a = pop_rpn_item();
 733                 lex_read_unichar(0);
 734                 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
 735             } break;
 736             case '*': {
 737                 OP *b = pop_rpn_item();
 738                 OP *a = pop_rpn_item();
 739                 lex_read_unichar(0);
 740                 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
 741             } break;
 742             case '/': {
 743                 OP *b = pop_rpn_item();
 744                 OP *a = pop_rpn_item();
 745                 lex_read_unichar(0);
 746                 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
 747             } break;
 748             case '%': {
 749                 OP *b = pop_rpn_item();
 750                 OP *a = pop_rpn_item();
 751                 lex_read_unichar(0);
 752                 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
 753             } break;
 754             default: {
 755                 croak("RPN syntax error");
 756             } break;
 757         }
 758     }
 759 }
 760
 761 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
 762 static OP *THX_parse_keyword_rpn(pTHX)
 763 {
 764     OP *op;
 765     lex_read_space(0);
 766     if(lex_peek_unichar(0) != '('/*)*/)
 767         croak("RPN expression must be parenthesised");
 768     lex_read_unichar(0);
 769     op = parse_rpn_expr();
 770     if(lex_peek_unichar(0) != /*(*/')')
 771         croak("RPN expression must be parenthesised");
 772     lex_read_unichar(0);
 773     return op;
 774 }
 775
 776 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
 777 static OP *THX_parse_keyword_calcrpn(pTHX)
 778 {
 779     OP *varop, *exprop;
 780     lex_read_space(0);
 781     varop = parse_var();
 782     lex_read_space(0);
 783     if(lex_peek_unichar(0) != '{'/*}*/)
 784         croak("RPN expression must be braced");
 785     lex_read_unichar(0);
 786     exprop = parse_rpn_expr();
 787     if(lex_peek_unichar(0) != /*{*/'}')
 788         croak("RPN expression must be braced");
 789     lex_read_unichar(0);
 790     return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
 791 }
 792
 793 #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
 794 static OP *THX_parse_keyword_stufftest(pTHX)
 795 {
 796     I32 c;
 797     bool do_stuff;
 798     lex_read_space(0);
 799     do_stuff = lex_peek_unichar(0) == '+';
 800     if(do_stuff) {
 801         lex_read_unichar(0);
 802         lex_read_space(0);
 803     }
 804     c = lex_peek_unichar(0);
 805     if(c == ';') {
 806         lex_read_unichar(0);
 807     } else if(c != /*{*/'}') {
 808         croak("syntax error");
 809     }
 810     if(do_stuff) lex_stuff_pvs(" ", 0);
 811     return newOP(OP_NULL, 0);
 812 }
 813
 814 #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
 815 static OP *THX_parse_keyword_swaptwostmts(pTHX)
 816 {
 817     OP *a, *b;
 818     a = parse_fullstmt(0);
 819     b = parse_fullstmt(0);
 820     if(a && b)
 821         PL_hints |= HINT_BLOCK_SCOPE;
 822     return op_append_list(OP_LINESEQ, b, a);
 823 }
 824
 825 #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
 826 static OP *THX_parse_keyword_looprest(pTHX)
 827 {
 828     return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
 829                         parse_stmtseq(0), NULL, 1);
 830 }
 831
 832 #define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
 833 static OP *THX_parse_keyword_scopelessblock(pTHX)
 834 {
 835     I32 c;
 836     OP *body;
 837     lex_read_space(0);
 838     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
 839     lex_read_unichar(0);
 840     body = parse_stmtseq(0);
 841     c = lex_peek_unichar(0);
 842     if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error");
 843     lex_read_unichar(0);
 844     return body;
 845 }
 846
 847 #define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
 848 static OP *THX_parse_keyword_stmtasexpr(pTHX)
 849 {
 850     OP *o = parse_barestmt(0);
 851     if (!o) o = newOP(OP_STUB, 0);
 852     if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
 853     return op_scope(o);
 854 }
 855
 856 #define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
 857 static OP *THX_parse_keyword_stmtsasexpr(pTHX)
 858 {
 859     OP *o;
 860     lex_read_space(0);
 861     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
 862     lex_read_unichar(0);
 863     o = parse_stmtseq(0);
 864     lex_read_space(0);
 865     if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
 866     lex_read_unichar(0);
 867     if (!o) o = newOP(OP_STUB, 0);
 868     if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
 869     return op_scope(o);
 870 }
 871
 872 #define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX)
 873 static OP *THX_parse_keyword_loopblock(pTHX)
 874 {
 875     return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
 876                         parse_block(0), NULL, 1);
 877 }
 878
 879 #define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX)
 880 static OP *THX_parse_keyword_blockasexpr(pTHX)
 881 {
 882     OP *o = parse_block(0);
 883     if (!o) o = newOP(OP_STUB, 0);
 884     if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
 885     return op_scope(o);
 886 }
 887
 888 #define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX)
 889 static OP *THX_parse_keyword_swaplabel(pTHX)
 890 {
 891     OP *sop = parse_barestmt(0);
 892     SV *label = parse_label(PARSE_OPTIONAL);
 893     if (label) sv_2mortal(label);
 894     return newSTATEOP(0, label ? savepv(SvPVX(label)) : NULL, sop);
 895 }
 896
 897 #define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
 898 static OP *THX_parse_keyword_labelconst(pTHX)
 899 {
 900     return newSVOP(OP_CONST, 0, parse_label(0));
 901 }
 902
 903 #define parse_keyword_arrayfullexpr() THX_parse_keyword_arrayfullexpr(aTHX)
 904 static OP *THX_parse_keyword_arrayfullexpr(pTHX)
 905 {
 906     return newANONLIST(parse_fullexpr(0));
 907 }
 908
 909 #define parse_keyword_arraylistexpr() THX_parse_keyword_arraylistexpr(aTHX)
 910 static OP *THX_parse_keyword_arraylistexpr(pTHX)
 911 {
 912     return newANONLIST(parse_listexpr(0));
 913 }
 914
 915 #define parse_keyword_arraytermexpr() THX_parse_keyword_arraytermexpr(aTHX)
 916 static OP *THX_parse_keyword_arraytermexpr(pTHX)
 917 {
 918     return newANONLIST(parse_termexpr(0));
 919 }
 920
 921 #define parse_keyword_arrayarithexpr() THX_parse_keyword_arrayarithexpr(aTHX)
 922 static OP *THX_parse_keyword_arrayarithexpr(pTHX)
 923 {
 924     return newANONLIST(parse_arithexpr(0));
 925 }
 926
 927 #define parse_keyword_arrayexprflags() THX_parse_keyword_arrayexprflags(aTHX)
 928 static OP *THX_parse_keyword_arrayexprflags(pTHX)
 929 {
 930     U32 flags = 0;
 931     I32 c;
 932     OP *o;
 933     lex_read_space(0);
 934     c = lex_peek_unichar(0);
 935     if (c != '!' && c != '?') croak("syntax error");
 936     lex_read_unichar(0);
 937     if (c == '?') flags |= PARSE_OPTIONAL;
 938     o = parse_listexpr(flags);
 939     return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
 940 }
 941
 942 /* plugin glue */
 943
 944 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
 945 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
 946 {
 947     HE *he;
 948     if(!GvHV(PL_hintgv)) return 0;
 949     he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
 950                 SvSHARED_HASH(hintkey_sv));
 951     return he && SvTRUE(HeVAL(he));
 952 }
 953
 954 static int my_keyword_plugin(pTHX_
 955     char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
 956 {
 957     if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
 958                     keyword_active(hintkey_rpn_sv)) {
 959         *op_ptr = parse_keyword_rpn();
 960         return KEYWORD_PLUGIN_EXPR;
 961     } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
 962                     keyword_active(hintkey_calcrpn_sv)) {
 963         *op_ptr = parse_keyword_calcrpn();
 964         return KEYWORD_PLUGIN_STMT;
 965     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
 966                     keyword_active(hintkey_stufftest_sv)) {
 967         *op_ptr = parse_keyword_stufftest();
 968         return KEYWORD_PLUGIN_STMT;
 969     } else if(keyword_len == 12 &&
 970                     strnEQ(keyword_ptr, "swaptwostmts", 12) &&
 971                     keyword_active(hintkey_swaptwostmts_sv)) {
 972         *op_ptr = parse_keyword_swaptwostmts();
 973         return KEYWORD_PLUGIN_STMT;
 974     } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
 975                     keyword_active(hintkey_looprest_sv)) {
 976         *op_ptr = parse_keyword_looprest();
 977         return KEYWORD_PLUGIN_STMT;
 978     } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) &&
 979                     keyword_active(hintkey_scopelessblock_sv)) {
 980         *op_ptr = parse_keyword_scopelessblock();
 981         return KEYWORD_PLUGIN_STMT;
 982     } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) &&
 983                     keyword_active(hintkey_stmtasexpr_sv)) {
 984         *op_ptr = parse_keyword_stmtasexpr();
 985         return KEYWORD_PLUGIN_EXPR;
 986     } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) &&
 987                     keyword_active(hintkey_stmtsasexpr_sv)) {
 988         *op_ptr = parse_keyword_stmtsasexpr();
 989         return KEYWORD_PLUGIN_EXPR;
 990     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "loopblock", 9) &&
 991                     keyword_active(hintkey_loopblock_sv)) {
 992         *op_ptr = parse_keyword_loopblock();
 993         return KEYWORD_PLUGIN_STMT;
 994     } else if(keyword_len == 11 && strnEQ(keyword_ptr, "blockasexpr", 11) &&
 995                     keyword_active(hintkey_blockasexpr_sv)) {
 996         *op_ptr = parse_keyword_blockasexpr();
 997         return KEYWORD_PLUGIN_EXPR;
 998     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) &&
 999                     keyword_active(hintkey_swaplabel_sv)) {
1000         *op_ptr = parse_keyword_swaplabel();
1001         return KEYWORD_PLUGIN_STMT;
1002     } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) &&
1003                     keyword_active(hintkey_labelconst_sv)) {
1004         *op_ptr = parse_keyword_labelconst();
1005         return KEYWORD_PLUGIN_EXPR;
1006     } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arrayfullexpr", 13) &&
1007                     keyword_active(hintkey_arrayfullexpr_sv)) {
1008         *op_ptr = parse_keyword_arrayfullexpr();
1009         return KEYWORD_PLUGIN_EXPR;
1010     } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraylistexpr", 13) &&
1011                     keyword_active(hintkey_arraylistexpr_sv)) {
1012         *op_ptr = parse_keyword_arraylistexpr();
1013         return KEYWORD_PLUGIN_EXPR;
1014     } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraytermexpr", 13) &&
1015                     keyword_active(hintkey_arraytermexpr_sv)) {
1016         *op_ptr = parse_keyword_arraytermexpr();
1017         return KEYWORD_PLUGIN_EXPR;
1018     } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayarithexpr", 14) &&
1019                     keyword_active(hintkey_arrayarithexpr_sv)) {
1020         *op_ptr = parse_keyword_arrayarithexpr();
1021         return KEYWORD_PLUGIN_EXPR;
1022     } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayexprflags", 14) &&
1023                     keyword_active(hintkey_arrayexprflags_sv)) {
1024         *op_ptr = parse_keyword_arrayexprflags();
1025         return KEYWORD_PLUGIN_EXPR;
1026     } else {
1027         return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
1028     }
1029 }
1030
1031 static XOP my_xop;
1032
1033 static OP *
1034 pp_xop(pTHX)
1035 {
1036     return PL_op->op_next;
1037 }
1038
1039 static void
1040 peep_xop(pTHX_ OP *o, OP *oldop)
1041 {
1042     dMY_CXT;
1043     av_push(MY_CXT.xop_record, newSVpvf("peep:%"UVxf, PTR2UV(o)));
1044     av_push(MY_CXT.xop_record, newSVpvf("oldop:%"UVxf, PTR2UV(oldop)));
1045 }
1046
1047 static I32
1048 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
1049 {
1050     SV   *my_sv = FILTER_DATA(idx);
1051     char *p;
1052     char *end;
1053     int n = FILTER_READ(idx + 1, buf_sv, maxlen);
1054
1055     if (n<=0) return n;
1056
1057     p = SvPV_force_nolen(buf_sv);
1058     end = p + SvCUR(buf_sv);
1059     while (p < end) {
1060         if (*p == 'o') *p = 'e';
1061         p++;
1062     }
1063     return SvCUR(buf_sv);
1064 }
1065
1066
1067 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
1068 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
1069 XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
1070
1071 #include "const-c.inc"
1072
1073 MODULE = XS::APItest            PACKAGE = XS::APItest
1074
1075 INCLUDE: const-xs.inc
1076
1077 INCLUDE: numeric.xs
1078
1079 MODULE = XS::APItest::utf8      PACKAGE = XS::APItest::utf8
1080
1081 int
1082 bytes_cmp_utf8(bytes, utf8)
1083         SV *bytes
1084         SV *utf8
1085     PREINIT:
1086         const U8 *b;
1087         STRLEN blen;
1088         const U8 *u;
1089         STRLEN ulen;
1090     CODE:
1091         b = (const U8 *)SvPVbyte(bytes, blen);
1092         u = (const U8 *)SvPVbyte(utf8, ulen);
1093         RETVAL = bytes_cmp_utf8(b, blen, u, ulen);
1094     OUTPUT:
1095         RETVAL
1096
1097 MODULE = XS::APItest:Overload   PACKAGE = XS::APItest::Overload
1098
1099 void
1100 amagic_deref_call(sv, what)
1101         SV *sv
1102         int what
1103     PPCODE:
1104         /* The reference is owned by something else.  */
1105         PUSHs(amagic_deref_call(sv, what));
1106
1107 # I'd certainly like to discourage the use of this macro, given that we now
1108 # have amagic_deref_call
1109
1110 void
1111 tryAMAGICunDEREF_var(sv, what)
1112         SV *sv
1113         int what
1114     PPCODE:
1115         {
1116             SV **sp = &sv;
1117             switch(what) {
1118             case to_av_amg:
1119                 tryAMAGICunDEREF(to_av);
1120                 break;
1121             case to_cv_amg:
1122                 tryAMAGICunDEREF(to_cv);
1123                 break;
1124             case to_gv_amg:
1125                 tryAMAGICunDEREF(to_gv);
1126                 break;
1127             case to_hv_amg:
1128                 tryAMAGICunDEREF(to_hv);
1129                 break;
1130             case to_sv_amg:
1131                 tryAMAGICunDEREF(to_sv);
1132                 break;
1133             default:
1134                 croak("Invalid value %d passed to tryAMAGICunDEREF_var", what);
1135             }
1136         }
1137         /* The reference is owned by something else.  */
1138         PUSHs(sv);
1139
1140 MODULE = XS::APItest            PACKAGE = XS::APItest::XSUB
1141
1142 BOOT:
1143     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
1144     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
1145     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
1146
1147 void
1148 XS_VERSION_defined(...)
1149     PPCODE:
1150         XS_VERSION_BOOTCHECK;
1151         XSRETURN_EMPTY;
1152
1153 void
1154 XS_APIVERSION_valid(...)
1155     PPCODE:
1156         XS_APIVERSION_BOOTCHECK;
1157         XSRETURN_EMPTY;
1158
1159 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
1160
1161 void
1162 rot13_hash(hash)
1163         HV *hash
1164         CODE:
1165         {
1166             struct ufuncs uf;
1167             uf.uf_val = rot13_key;
1168             uf.uf_set = 0;
1169             uf.uf_index = 0;
1170
1171             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1172         }
1173
1174 void
1175 bitflip_hash(hash)
1176         HV *hash
1177         CODE:
1178         {
1179             struct ufuncs uf;
1180             uf.uf_val = bitflip_key;
1181             uf.uf_set = 0;
1182             uf.uf_index = 0;
1183
1184             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
1185         }
1186
1187 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
1188
1189 bool
1190 exists(hash, key_sv)
1191         PREINIT:
1192         STRLEN len;
1193         const char *key;
1194         INPUT:
1195         HV *hash
1196         SV *key_sv
1197         CODE:
1198         key = SvPV(key_sv, len);
1199         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
1200         OUTPUT:
1201         RETVAL
1202
1203 bool
1204 exists_ent(hash, key_sv)
1205         PREINIT:
1206         INPUT:
1207         HV *hash
1208         SV *key_sv
1209         CODE:
1210         RETVAL = hv_exists_ent(hash, key_sv, 0);
1211         OUTPUT:
1212         RETVAL
1213
1214 SV *
1215 delete(hash, key_sv, flags = 0)
1216         PREINIT:
1217         STRLEN len;
1218         const char *key;
1219         INPUT:
1220         HV *hash
1221         SV *key_sv
1222         I32 flags;
1223         CODE:
1224         key = SvPV(key_sv, len);
1225         /* It's already mortal, so need to increase reference count.  */
1226         RETVAL
1227             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
1228         OUTPUT:
1229         RETVAL
1230
1231 SV *
1232 delete_ent(hash, key_sv, flags = 0)
1233         INPUT:
1234         HV *hash
1235         SV *key_sv
1236         I32 flags;
1237         CODE:
1238         /* It's already mortal, so need to increase reference count.  */
1239         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
1240         OUTPUT:
1241         RETVAL
1242
1243 SV *
1244 store_ent(hash, key, value)
1245         PREINIT:
1246         SV *copy;
1247         HE *result;
1248         INPUT:
1249         HV *hash
1250         SV *key
1251         SV *value
1252         CODE:
1253         copy = newSV(0);
1254         result = hv_store_ent(hash, key, copy, 0);
1255         SvSetMagicSV(copy, value);
1256         if (!result) {
1257             SvREFCNT_dec(copy);
1258             XSRETURN_EMPTY;
1259         }
1260         /* It's about to become mortal, so need to increase reference count.
1261          */
1262         RETVAL = SvREFCNT_inc(HeVAL(result));
1263         OUTPUT:
1264         RETVAL
1265
1266 SV *
1267 store(hash, key_sv, value)
1268         PREINIT:
1269         STRLEN len;
1270         const char *key;
1271         SV *copy;
1272         SV **result;
1273         INPUT:
1274         HV *hash
1275         SV *key_sv
1276         SV *value
1277         CODE:
1278         key = SvPV(key_sv, len);
1279         copy = newSV(0);
1280         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
1281         SvSetMagicSV(copy, value);
1282         if (!result) {
1283             SvREFCNT_dec(copy);
1284             XSRETURN_EMPTY;
1285         }
1286         /* It's about to become mortal, so need to increase reference count.
1287          */
1288         RETVAL = SvREFCNT_inc(*result);
1289         OUTPUT:
1290         RETVAL
1291
1292 SV *
1293 fetch_ent(hash, key_sv)
1294         PREINIT:
1295         HE *result;
1296         INPUT:
1297         HV *hash
1298         SV *key_sv
1299         CODE:
1300         result = hv_fetch_ent(hash, key_sv, 0, 0);
1301         if (!result) {
1302             XSRETURN_EMPTY;
1303         }
1304         /* Force mg_get  */
1305         RETVAL = newSVsv(HeVAL(result));
1306         OUTPUT:
1307         RETVAL
1308
1309 SV *
1310 fetch(hash, key_sv)
1311         PREINIT:
1312         STRLEN len;
1313         const char *key;
1314         SV **result;
1315         INPUT:
1316         HV *hash
1317         SV *key_sv
1318         CODE:
1319         key = SvPV(key_sv, len);
1320         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
1321         if (!result) {
1322             XSRETURN_EMPTY;
1323         }
1324         /* Force mg_get  */
1325         RETVAL = newSVsv(*result);
1326         OUTPUT:
1327         RETVAL
1328
1329 #if defined (hv_common)
1330
1331 SV *
1332 common(params)
1333         INPUT:
1334         HV *params
1335         PREINIT:
1336         HE *result;
1337         HV *hv = NULL;
1338         SV *keysv = NULL;
1339         const char *key = NULL;
1340         STRLEN klen = 0;
1341         int flags = 0;
1342         int action = 0;
1343         SV *val = NULL;
1344         U32 hash = 0;
1345         SV **svp;
1346         CODE:
1347         if ((svp = hv_fetchs(params, "hv", 0))) {
1348             SV *const rv = *svp;
1349             if (!SvROK(rv))
1350                 croak("common passed a non-reference for parameter hv");
1351             hv = (HV *)SvRV(rv);
1352         }
1353         if ((svp = hv_fetchs(params, "keysv", 0)))
1354             keysv = *svp;
1355         if ((svp = hv_fetchs(params, "keypv", 0))) {
1356             key = SvPV_const(*svp, klen);
1357             if (SvUTF8(*svp))
1358                 flags = HVhek_UTF8;
1359         }
1360         if ((svp = hv_fetchs(params, "action", 0)))
1361             action = SvIV(*svp);
1362         if ((svp = hv_fetchs(params, "val", 0)))
1363             val = newSVsv(*svp);
1364         if ((svp = hv_fetchs(params, "hash", 0)))
1365             hash = SvUV(*svp);
1366
1367         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
1368             PERL_HASH(hash, key, klen);
1369         }
1370         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
1371             STRLEN len;
1372             const char *const p = SvPV(keysv, len);
1373             PERL_HASH(hash, p, len);
1374         }
1375
1376         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
1377         if (!result) {
1378             XSRETURN_EMPTY;
1379         }
1380         /* Force mg_get  */
1381         RETVAL = newSVsv(HeVAL(result));
1382         OUTPUT:
1383         RETVAL
1384
1385 #endif
1386
1387 void
1388 test_hv_free_ent()
1389         PPCODE:
1390         test_freeent(&Perl_hv_free_ent);
1391         XSRETURN(4);
1392
1393 void
1394 test_hv_delayfree_ent()
1395         PPCODE:
1396         test_freeent(&Perl_hv_delayfree_ent);
1397         XSRETURN(4);
1398
1399 SV *
1400 test_share_unshare_pvn(input)
1401         PREINIT:
1402         STRLEN len;
1403         U32 hash;
1404         char *pvx;
1405         char *p;
1406         INPUT:
1407         SV *input
1408         CODE:
1409         pvx = SvPV(input, len);
1410         PERL_HASH(hash, pvx, len);
1411         p = sharepvn(pvx, len, hash);
1412         RETVAL = newSVpvn(p, len);
1413         unsharepvn(p, len, hash);
1414         OUTPUT:
1415         RETVAL
1416
1417 #if PERL_VERSION >= 9
1418
1419 bool
1420 refcounted_he_exists(key, level=0)
1421         SV *key
1422         IV level
1423         CODE:
1424         if (level) {
1425             croak("level must be zero, not %"IVdf, level);
1426         }
1427         RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder);
1428         OUTPUT:
1429         RETVAL
1430
1431 SV *
1432 refcounted_he_fetch(key, level=0)
1433         SV *key
1434         IV level
1435         CODE:
1436         if (level) {
1437             croak("level must be zero, not %"IVdf, level);
1438         }
1439         RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0);
1440         SvREFCNT_inc(RETVAL);
1441         OUTPUT:
1442         RETVAL
1443
1444 #endif
1445
1446 =pod
1447
1448 sub TIEHASH  { bless {}, $_[0] }
1449 sub STORE    { $_[0]->{$_[1]} = $_[2] }
1450 sub FETCH    { $_[0]->{$_[1]} }
1451 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1452 sub NEXTKEY  { each %{$_[0]} }
1453 sub EXISTS   { exists $_[0]->{$_[1]} }
1454 sub DELETE   { delete $_[0]->{$_[1]} }
1455 sub CLEAR    { %{$_[0]} = () }
1456
1457 =cut
1458
1459 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
1460
1461 void
1462 make_temp_mg_lv(sv)
1463 SV* sv
1464     PREINIT:
1465         SV * const lv = newSV_type(SVt_PVLV);
1466         STRLEN len;
1467     PPCODE:
1468         SvPV(sv, len);
1469
1470         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1471         LvTYPE(lv) = 'x';
1472         LvTARG(lv) = SvREFCNT_inc_simple(sv);
1473         LvTARGOFF(lv) = len == 0 ? 0 : 1;
1474         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1475
1476         EXTEND(SP, 1);
1477         ST(0) = sv_2mortal(lv);
1478         XSRETURN(1);
1479
1480
1481 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1482
1483 void
1484 ptr_table_new(classname)
1485 const char * classname
1486     PPCODE:
1487     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1488
1489 void
1490 DESTROY(table)
1491 XS::APItest::PtrTable table
1492     CODE:
1493     ptr_table_free(table);
1494
1495 void
1496 ptr_table_store(table, from, to)
1497 XS::APItest::PtrTable table
1498 SVREF from
1499 SVREF to
1500    CODE:
1501    ptr_table_store(table, from, to);
1502
1503 UV
1504 ptr_table_fetch(table, from)
1505 XS::APItest::PtrTable table
1506 SVREF from
1507    CODE:
1508    RETVAL = PTR2UV(ptr_table_fetch(table, from));
1509    OUTPUT:
1510    RETVAL
1511
1512 void
1513 ptr_table_split(table)
1514 XS::APItest::PtrTable table
1515
1516 void
1517 ptr_table_clear(table)
1518 XS::APItest::PtrTable table
1519
1520 MODULE = XS::APItest::AutoLoader        PACKAGE = XS::APItest::AutoLoader
1521
1522 SV *
1523 AUTOLOAD()
1524     CODE:
1525         RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
1526     OUTPUT:
1527         RETVAL
1528
1529
1530 MODULE = XS::APItest            PACKAGE = XS::APItest
1531
1532 PROTOTYPES: DISABLE
1533
1534 HV *
1535 xop_custom_ops ()
1536     CODE:
1537         RETVAL = PL_custom_ops;
1538     OUTPUT:
1539         RETVAL
1540
1541 HV *
1542 xop_custom_op_names ()
1543     CODE:
1544         PL_custom_op_names = newHV();
1545         RETVAL = PL_custom_op_names;
1546     OUTPUT:
1547         RETVAL
1548
1549 HV *
1550 xop_custom_op_descs ()
1551     CODE:
1552         PL_custom_op_descs = newHV();
1553         RETVAL = PL_custom_op_descs;
1554     OUTPUT:
1555         RETVAL
1556
1557 void
1558 xop_register ()
1559     CODE:
1560         XopENTRY_set(&my_xop, xop_name, "my_xop");
1561         XopENTRY_set(&my_xop, xop_desc, "XOP for testing");
1562         XopENTRY_set(&my_xop, xop_class, OA_UNOP);
1563         XopENTRY_set(&my_xop, xop_peep, peep_xop);
1564         Perl_custom_op_register(aTHX_ pp_xop, &my_xop);
1565
1566 void
1567 xop_clear ()
1568     CODE:
1569         XopDISABLE(&my_xop, xop_name);
1570         XopDISABLE(&my_xop, xop_desc);
1571         XopDISABLE(&my_xop, xop_class);
1572         XopDISABLE(&my_xop, xop_peep);
1573
1574 IV
1575 xop_my_xop ()
1576     CODE:
1577         RETVAL = PTR2IV(&my_xop);
1578     OUTPUT:
1579         RETVAL
1580
1581 IV
1582 xop_ppaddr ()
1583     CODE:
1584         RETVAL = PTR2IV(pp_xop);
1585     OUTPUT:
1586         RETVAL
1587
1588 IV
1589 xop_OA_UNOP ()
1590     CODE:
1591         RETVAL = OA_UNOP;
1592     OUTPUT:
1593         RETVAL
1594
1595 AV *
1596 xop_build_optree ()
1597     CODE:
1598         dMY_CXT;
1599         UNOP *unop;
1600         OP *kid;
1601
1602         MY_CXT.xop_record = newAV();
1603
1604         kid = newSVOP(OP_CONST, 0, newSViv(42));
1605
1606         NewOp(1102, unop, 1, UNOP);
1607         unop->op_type       = OP_CUSTOM;
1608         unop->op_ppaddr     = pp_xop;
1609         unop->op_flags      = OPf_KIDS;
1610         unop->op_private    = 0;
1611         unop->op_first      = kid;
1612         unop->op_next       = NULL;
1613         kid->op_next        = (OP*)unop;
1614
1615         av_push(MY_CXT.xop_record, newSVpvf("unop:%"UVxf, PTR2UV(unop)));
1616         av_push(MY_CXT.xop_record, newSVpvf("kid:%"UVxf, PTR2UV(kid)));
1617
1618         av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop)));
1619         av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop)));
1620         av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop)));
1621
1622         PL_rpeepp(aTHX_ kid);
1623
1624         FreeOp(kid);
1625         FreeOp(unop);
1626
1627         RETVAL = MY_CXT.xop_record;
1628         MY_CXT.xop_record = NULL;
1629     OUTPUT:
1630         RETVAL
1631
1632 BOOT:
1633 {
1634     MY_CXT_INIT;
1635
1636     MY_CXT.i  = 99;
1637     MY_CXT.sv = newSVpv("initial",0);
1638
1639     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1640     MY_CXT.bhk_record = 0;
1641
1642     BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
1643     BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
1644     BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
1645     BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
1646     Perl_blockhook_register(aTHX_ &bhk_test);
1647
1648     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1649         GV_ADDMULTI, SVt_PVAV);
1650     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1651
1652     BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
1653     BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
1654     Perl_blockhook_register(aTHX_ &bhk_csc);
1655
1656     MY_CXT.peep_recorder = newAV();
1657     MY_CXT.rpeep_recorder = newAV();
1658
1659     MY_CXT.orig_peep = PL_peepp;
1660     MY_CXT.orig_rpeep = PL_rpeepp;
1661     PL_peepp = my_peep;
1662     PL_rpeepp = my_rpeep;
1663 }
1664
1665 void
1666 CLONE(...)
1667     CODE:
1668     MY_CXT_CLONE;
1669     PERL_UNUSED_VAR(items);
1670     MY_CXT.sv = newSVpv("initial_clone",0);
1671     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1672         GV_ADDMULTI, SVt_PVAV);
1673     MY_CXT.cscav = NULL;
1674     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1675     MY_CXT.bhk_record = 0;
1676     MY_CXT.peep_recorder = newAV();
1677     MY_CXT.rpeep_recorder = newAV();
1678
1679 void
1680 print_double(val)
1681         double val
1682         CODE:
1683         printf("%5.3f\n",val);
1684
1685 int
1686 have_long_double()
1687         CODE:
1688 #ifdef HAS_LONG_DOUBLE
1689         RETVAL = 1;
1690 #else
1691         RETVAL = 0;
1692 #endif
1693         OUTPUT:
1694         RETVAL
1695
1696 void
1697 print_long_double()
1698         CODE:
1699 #ifdef HAS_LONG_DOUBLE
1700 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
1701         long double val = 7.0;
1702         printf("%5.3" PERL_PRIfldbl "\n",val);
1703 #   else
1704         double val = 7.0;
1705         printf("%5.3f\n",val);
1706 #   endif
1707 #endif
1708
1709 void
1710 print_int(val)
1711         int val
1712         CODE:
1713         printf("%d\n",val);
1714
1715 void
1716 print_long(val)
1717         long val
1718         CODE:
1719         printf("%ld\n",val);
1720
1721 void
1722 print_float(val)
1723         float val
1724         CODE:
1725         printf("%5.3f\n",val);
1726
1727 void
1728 print_flush()
1729         CODE:
1730         fflush(stdout);
1731
1732 void
1733 mpushp()
1734         PPCODE:
1735         EXTEND(SP, 3);
1736         mPUSHp("one", 3);
1737         mPUSHp("two", 3);
1738         mPUSHp("three", 5);
1739         XSRETURN(3);
1740
1741 void
1742 mpushn()
1743         PPCODE:
1744         EXTEND(SP, 3);
1745         mPUSHn(0.5);
1746         mPUSHn(-0.25);
1747         mPUSHn(0.125);
1748         XSRETURN(3);
1749
1750 void
1751 mpushi()
1752         PPCODE:
1753         EXTEND(SP, 3);
1754         mPUSHi(-1);
1755         mPUSHi(2);
1756         mPUSHi(-3);
1757         XSRETURN(3);
1758
1759 void
1760 mpushu()
1761         PPCODE:
1762         EXTEND(SP, 3);
1763         mPUSHu(1);
1764         mPUSHu(2);
1765         mPUSHu(3);
1766         XSRETURN(3);
1767
1768 void
1769 mxpushp()
1770         PPCODE:
1771         mXPUSHp("one", 3);
1772         mXPUSHp("two", 3);
1773         mXPUSHp("three", 5);
1774         XSRETURN(3);
1775
1776 void
1777 mxpushn()
1778         PPCODE:
1779         mXPUSHn(0.5);
1780         mXPUSHn(-0.25);
1781         mXPUSHn(0.125);
1782         XSRETURN(3);
1783
1784 void
1785 mxpushi()
1786         PPCODE:
1787         mXPUSHi(-1);
1788         mXPUSHi(2);
1789         mXPUSHi(-3);
1790         XSRETURN(3);
1791
1792 void
1793 mxpushu()
1794         PPCODE:
1795         mXPUSHu(1);
1796         mXPUSHu(2);
1797         mXPUSHu(3);
1798         XSRETURN(3);
1799
1800
1801 void
1802 call_sv(sv, flags, ...)
1803     SV* sv
1804     I32 flags
1805     PREINIT:
1806         I32 i;
1807     PPCODE:
1808         for (i=0; i<items-2; i++)
1809             ST(i) = ST(i+2); /* pop first two args */
1810         PUSHMARK(SP);
1811         SP += items - 2;
1812         PUTBACK;
1813         i = call_sv(sv, flags);
1814         SPAGAIN;
1815         EXTEND(SP, 1);
1816         PUSHs(sv_2mortal(newSViv(i)));
1817
1818 void
1819 call_pv(subname, flags, ...)
1820     char* subname
1821     I32 flags
1822     PREINIT:
1823         I32 i;
1824     PPCODE:
1825         for (i=0; i<items-2; i++)
1826             ST(i) = ST(i+2); /* pop first two args */
1827         PUSHMARK(SP);
1828         SP += items - 2;
1829         PUTBACK;
1830         i = call_pv(subname, flags);
1831         SPAGAIN;
1832         EXTEND(SP, 1);
1833         PUSHs(sv_2mortal(newSViv(i)));
1834
1835 void
1836 call_method(methname, flags, ...)
1837     char* methname
1838     I32 flags
1839     PREINIT:
1840         I32 i;
1841     PPCODE:
1842         for (i=0; i<items-2; i++)
1843             ST(i) = ST(i+2); /* pop first two args */
1844         PUSHMARK(SP);
1845         SP += items - 2;
1846         PUTBACK;
1847         i = call_method(methname, flags);
1848         SPAGAIN;
1849         EXTEND(SP, 1);
1850         PUSHs(sv_2mortal(newSViv(i)));
1851
1852 void
1853 newCONSTSUB_type(stash, name, flags, type)
1854     HV* stash
1855     SV* name
1856     I32 flags
1857     int type
1858     PREINIT:
1859         CV* cv;
1860     PPCODE:
1861         switch (type) {
1862            case 0:
1863                cv = newCONSTSUB(stash, SvPV_nolen(name), NULL);
1864                break;
1865            case 1:
1866                cv = newCONSTSUB_flags(stash, SvPV_nolen(name), flags | SvUTF8(name), NULL);
1867                break;
1868         }
1869         EXTEND(SP, 2);
1870         PUSHs( CvCONST(cv) ? &PL_sv_yes : &PL_sv_no );
1871         PUSHs((SV*)CvGV(cv));
1872
1873 void
1874 gv_init_type(namesv, multi, flags, type)
1875     SV* namesv
1876     int multi
1877     I32 flags
1878     int type
1879     PREINIT:
1880         STRLEN len;
1881         const char * const name = SvPV_const(namesv, len);
1882         GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
1883     PPCODE:
1884         if (SvTYPE(gv) == SVt_PVGV)
1885             Perl_croak(aTHX_ "GV is already a PVGV");
1886         if (multi) flags |= GV_ADDMULTI;
1887         switch (type) {
1888            case 0:
1889                gv_init(gv, PL_defstash, name, len, multi);
1890                break;
1891            case 1:
1892                gv_init_sv(gv, PL_defstash, namesv, flags);
1893                break;
1894            case 2:
1895                gv_init_pv(gv, PL_defstash, name, flags | SvUTF8(namesv));
1896                break;
1897            case 3:
1898                gv_init_pvn(gv, PL_defstash, name, len, flags | SvUTF8(namesv));
1899                break;
1900         }
1901         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
1902
1903 void
1904 gv_fetchmeth_type(stash, methname, type, level, flags)
1905     HV* stash
1906     SV* methname
1907     int type
1908     I32 level
1909     I32 flags
1910     PREINIT:
1911         STRLEN len;
1912         const char * const name = SvPV_const(methname, len);
1913         GV* gv;
1914     PPCODE:
1915         switch (type) {
1916            case 0:
1917                gv = gv_fetchmeth(stash, name, len, level);
1918                break;
1919            case 1:
1920                gv = gv_fetchmeth_sv(stash, methname, level, flags);
1921                break;
1922            case 2:
1923                gv = gv_fetchmeth_pv(stash, name, level, flags | SvUTF8(methname));
1924                break;
1925            case 3:
1926                gv = gv_fetchmeth_pvn(stash, name, len, level, flags | SvUTF8(methname));
1927                break;
1928         }
1929         XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
1930
1931 void
1932 gv_fetchmeth_autoload_type(stash, methname, type, level, flags)
1933     HV* stash
1934     SV* methname
1935     int type
1936     I32 level
1937     I32 flags
1938     PREINIT:
1939         STRLEN len;
1940         const char * const name = SvPV_const(methname, len);
1941         GV* gv;
1942     PPCODE:
1943         switch (type) {
1944            case 0:
1945                gv = gv_fetchmeth_autoload(stash, name, len, level);
1946                break;
1947            case 1:
1948                gv = gv_fetchmeth_sv_autoload(stash, methname, level, flags);
1949                break;
1950            case 2:
1951                gv = gv_fetchmeth_pv_autoload(stash, name, level, flags | SvUTF8(methname));
1952                break;
1953            case 3:
1954                gv = gv_fetchmeth_pvn_autoload(stash, name, len, level, flags | SvUTF8(methname));
1955                break;
1956         }
1957         XPUSHs( gv ? MUTABLE_SV(gv) : &PL_sv_undef );
1958
1959 void
1960 gv_fetchmethod_flags_type(stash, methname, type, flags)
1961     HV* stash
1962     SV* methname
1963     int type
1964     I32 flags
1965     PREINIT:
1966         GV* gv;
1967     PPCODE:
1968         switch (type) {
1969            case 0:
1970                gv = gv_fetchmethod_flags(stash, SvPVX_const(methname), flags);
1971                break;
1972            case 1:
1973                gv = gv_fetchmethod_sv_flags(stash, methname, flags);
1974                break;
1975            case 2:
1976                gv = gv_fetchmethod_pv_flags(stash, SvPV_nolen(methname), flags | SvUTF8(methname));
1977                break;
1978            case 3: {
1979                STRLEN len;
1980                const char * const name = SvPV_const(methname, len);
1981                gv = gv_fetchmethod_pvn_flags(stash, name, len, flags | SvUTF8(methname));
1982                break;
1983             }
1984         }
1985         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
1986
1987 void
1988 gv_autoload_type(stash, methname, type, method)
1989     HV* stash
1990     SV* methname
1991     int type
1992     I32 method
1993     PREINIT:
1994         STRLEN len;
1995         const char * const name = SvPV_const(methname, len);
1996         GV* gv;
1997         I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
1998     PPCODE:
1999         switch (type) {
2000            case 0:
2001                gv = gv_autoload4(stash, name, len, method);
2002                break;
2003            case 1:
2004                gv = gv_autoload_sv(stash, methname, flags);
2005                break;
2006            case 2:
2007                gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
2008                break;
2009            case 3:
2010                gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
2011                break;
2012         }
2013         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2014
2015 void
2016 whichsig_type(namesv, type)
2017     SV* namesv
2018     int type
2019     PREINIT:
2020         STRLEN len;
2021         const char * const name = SvPV_const(namesv, len);
2022         I32 i;
2023     PPCODE:
2024         switch (type) {
2025            case 0:
2026               i = whichsig(name);
2027                break;
2028            case 1:
2029                i = whichsig_sv(namesv);
2030                break;
2031            case 2:
2032                i = whichsig_pv(name);
2033                break;
2034            case 3:
2035                i = whichsig_pvn(name, len);
2036                break;
2037         }
2038         XPUSHs(sv_2mortal(newSViv(i)));
2039
2040 void
2041 eval_sv(sv, flags)
2042     SV* sv
2043     I32 flags
2044     PREINIT:
2045         I32 i;
2046     PPCODE:
2047         PUTBACK;
2048         i = eval_sv(sv, flags);
2049         SPAGAIN;
2050         EXTEND(SP, 1);
2051         PUSHs(sv_2mortal(newSViv(i)));
2052
2053 void
2054 eval_pv(p, croak_on_error)
2055     const char* p
2056     I32 croak_on_error
2057     PPCODE:
2058         PUTBACK;
2059         EXTEND(SP, 1);
2060         PUSHs(eval_pv(p, croak_on_error));
2061
2062 void
2063 require_pv(pv)
2064     const char* pv
2065     PPCODE:
2066         PUTBACK;
2067         require_pv(pv);
2068
2069 int
2070 apitest_exception(throw_e)
2071     int throw_e
2072     OUTPUT:
2073         RETVAL
2074
2075 void
2076 mycroak(sv)
2077     SV* sv
2078     CODE:
2079     if (SvOK(sv)) {
2080         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
2081     }
2082     else {
2083         Perl_croak(aTHX_ NULL);
2084     }
2085
2086 SV*
2087 strtab()
2088    CODE:
2089    RETVAL = newRV_inc((SV*)PL_strtab);
2090    OUTPUT:
2091    RETVAL
2092
2093 int
2094 my_cxt_getint()
2095     CODE:
2096         dMY_CXT;
2097         RETVAL = my_cxt_getint_p(aMY_CXT);
2098     OUTPUT:
2099         RETVAL
2100
2101 void
2102 my_cxt_setint(i)
2103     int i;
2104     CODE:
2105         dMY_CXT;
2106         my_cxt_setint_p(aMY_CXT_ i);
2107
2108 void
2109 my_cxt_getsv(how)
2110     bool how;
2111     PPCODE:
2112         EXTEND(SP, 1);
2113         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
2114         XSRETURN(1);
2115
2116 void
2117 my_cxt_setsv(sv)
2118     SV *sv;
2119     CODE:
2120         dMY_CXT;
2121         SvREFCNT_dec(MY_CXT.sv);
2122         my_cxt_setsv_p(sv _aMY_CXT);
2123         SvREFCNT_inc(sv);
2124
2125 bool
2126 sv_setsv_cow_hashkey_core()
2127
2128 bool
2129 sv_setsv_cow_hashkey_notcore()
2130
2131 void
2132 rmagical_cast(sv, type)
2133     SV *sv;
2134     SV *type;
2135     PREINIT:
2136         struct ufuncs uf;
2137     PPCODE:
2138         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
2139         sv = SvRV(sv);
2140         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
2141         uf.uf_val = rmagical_a_dummy;
2142         uf.uf_set = NULL;
2143         uf.uf_index = 0;
2144         if (SvTRUE(type)) { /* b */
2145             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
2146         } else { /* a */
2147             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
2148         }
2149         XSRETURN_YES;
2150
2151 void
2152 rmagical_flags(sv)
2153     SV *sv;
2154     PPCODE:
2155         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
2156         sv = SvRV(sv);
2157         EXTEND(SP, 3);
2158         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
2159         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
2160         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
2161         XSRETURN(3);
2162
2163 void
2164 my_caller(level)
2165         I32 level
2166     PREINIT:
2167         const PERL_CONTEXT *cx, *dbcx;
2168         const char *pv;
2169         const GV *gv;
2170         HV *hv;
2171     PPCODE:
2172         cx = caller_cx(level, &dbcx);
2173         EXTEND(SP, 8);
2174
2175         pv = CopSTASHPV(cx->blk_oldcop);
2176         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2177         gv = CvGV(cx->blk_sub.cv);
2178         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2179
2180         pv = CopSTASHPV(dbcx->blk_oldcop);
2181         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2182         gv = CvGV(dbcx->blk_sub.cv);
2183         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2184
2185         ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
2186         ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
2187         ST(6) = cop_hints_fetch_sv(cx->blk_oldcop,
2188                 sv_2mortal(newSVpvn("foo", 3)), 0, 0);
2189
2190         hv = cop_hints_2hv(cx->blk_oldcop, 0);
2191         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
2192
2193         XSRETURN(8);
2194
2195 void
2196 DPeek (sv)
2197     SV   *sv
2198
2199   PPCODE:
2200     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
2201     XSRETURN (1);
2202
2203 void
2204 BEGIN()
2205     CODE:
2206         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
2207
2208 void
2209 CHECK()
2210     CODE:
2211         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
2212
2213 void
2214 UNITCHECK()
2215     CODE:
2216         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
2217
2218 void
2219 INIT()
2220     CODE:
2221         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
2222
2223 void
2224 END()
2225     CODE:
2226         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
2227
2228 void
2229 utf16_to_utf8 (sv, ...)
2230     SV* sv
2231         ALIAS:
2232             utf16_to_utf8_reversed = 1
2233     PREINIT:
2234         STRLEN len;
2235         U8 *source;
2236         SV *dest;
2237         I32 got; /* Gah, badly thought out APIs */
2238     CODE:
2239         source = (U8 *)SvPVbyte(sv, len);
2240         /* Optionally only convert part of the buffer.  */
2241         if (items > 1) {
2242             len = SvUV(ST(1));
2243         }
2244         /* Mortalise this right now, as we'll be testing croak()s  */
2245         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
2246         if (ix) {
2247             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
2248         } else {
2249             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
2250         }
2251         SvCUR_set(dest, got);
2252         SvPVX(dest)[got] = '\0';
2253         SvPOK_on(dest);
2254         ST(0) = dest;
2255         XSRETURN(1);
2256
2257 void
2258 my_exit(int exitcode)
2259         PPCODE:
2260         my_exit(exitcode);
2261
2262 U8
2263 first_byte(sv)
2264         SV *sv
2265    CODE:
2266     char *s;
2267     STRLEN len;
2268         s = SvPVbyte(sv, len);
2269         RETVAL = s[0];
2270    OUTPUT:
2271     RETVAL
2272
2273 I32
2274 sv_count()
2275         CODE:
2276             RETVAL = PL_sv_count;
2277         OUTPUT:
2278             RETVAL
2279
2280 void
2281 bhk_record(bool on)
2282     CODE:
2283         dMY_CXT;
2284         MY_CXT.bhk_record = on;
2285         if (on)
2286             av_clear(MY_CXT.bhkav);
2287
2288 void
2289 test_magic_chain()
2290     PREINIT:
2291         SV *sv;
2292         MAGIC *callmg, *uvarmg;
2293     CODE:
2294         sv = sv_2mortal(newSV(0));
2295         if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
2296         if (SvMAGICAL(sv)) croak_fail();
2297         sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
2298         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2299         if (!SvMAGICAL(sv)) croak_fail();
2300         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2301         callmg = mg_find(sv, PERL_MAGIC_checkcall);
2302         if (!callmg) croak_fail();
2303         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2304             croak_fail();
2305         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2306         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2307         if (!SvMAGICAL(sv)) croak_fail();
2308         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2309         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2310         if (!uvarmg) croak_fail();
2311         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2312             croak_fail();
2313         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2314             croak_fail();
2315         mg_free_type(sv, PERL_MAGIC_vec);
2316         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2317         if (!SvMAGICAL(sv)) croak_fail();
2318         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2319         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2320         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2321             croak_fail();
2322         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2323             croak_fail();
2324         mg_free_type(sv, PERL_MAGIC_uvar);
2325         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2326         if (!SvMAGICAL(sv)) croak_fail();
2327         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2328         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2329         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2330             croak_fail();
2331         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2332         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2333         if (!SvMAGICAL(sv)) croak_fail();
2334         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2335         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2336         if (!uvarmg) croak_fail();
2337         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2338             croak_fail();
2339         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2340             croak_fail();
2341         mg_free_type(sv, PERL_MAGIC_checkcall);
2342         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2343         if (!SvMAGICAL(sv)) croak_fail();
2344         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2345         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2346         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2347             croak_fail();
2348         mg_free_type(sv, PERL_MAGIC_uvar);
2349         if (SvMAGICAL(sv)) croak_fail();
2350         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2351         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2352
2353 void
2354 test_op_contextualize()
2355     PREINIT:
2356         OP *o;
2357     CODE:
2358         o = newSVOP(OP_CONST, 0, newSViv(0));
2359         o->op_flags &= ~OPf_WANT;
2360         o = op_contextualize(o, G_SCALAR);
2361         if (o->op_type != OP_CONST ||
2362                 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2363             croak_fail();
2364         op_free(o);
2365         o = newSVOP(OP_CONST, 0, newSViv(0));
2366         o->op_flags &= ~OPf_WANT;
2367         o = op_contextualize(o, G_ARRAY);
2368         if (o->op_type != OP_CONST ||
2369                 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
2370             croak_fail();
2371         op_free(o);
2372         o = newSVOP(OP_CONST, 0, newSViv(0));
2373         o->op_flags &= ~OPf_WANT;
2374         o = op_contextualize(o, G_VOID);
2375         if (o->op_type != OP_NULL) croak_fail();
2376         op_free(o);
2377
2378 void
2379 test_rv2cv_op_cv()
2380     PROTOTYPE:
2381     PREINIT:
2382         GV *troc_gv, *wibble_gv;
2383         CV *troc_cv;
2384         OP *o;
2385     CODE:
2386         troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
2387         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
2388         wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
2389         o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
2390         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
2391         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
2392             croak_fail();
2393         o->op_private |= OPpENTERSUB_AMPER;
2394         if (rv2cv_op_cv(o, 0)) croak_fail();
2395         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2396         o->op_private &= ~OPpENTERSUB_AMPER;
2397         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2398         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
2399         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2400         op_free(o);
2401         o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
2402         o->op_private = OPpCONST_BARE;
2403         o = newCVREF(0, o);
2404         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
2405         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
2406             croak_fail();
2407         o->op_private |= OPpENTERSUB_AMPER;
2408         if (rv2cv_op_cv(o, 0)) croak_fail();
2409         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2410         op_free(o);
2411         o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
2412         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
2413         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
2414             croak_fail();
2415         o->op_private |= OPpENTERSUB_AMPER;
2416         if (rv2cv_op_cv(o, 0)) croak_fail();
2417         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2418         o->op_private &= ~OPpENTERSUB_AMPER;
2419         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2420         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
2421         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2422         op_free(o);
2423         o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
2424         if (rv2cv_op_cv(o, 0)) croak_fail();
2425         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2426         o->op_private |= OPpENTERSUB_AMPER;
2427         if (rv2cv_op_cv(o, 0)) croak_fail();
2428         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2429         o->op_private &= ~OPpENTERSUB_AMPER;
2430         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2431         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
2432         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
2433         op_free(o);
2434         o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
2435         if (rv2cv_op_cv(o, 0)) croak_fail();
2436         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
2437         op_free(o);
2438
2439 void
2440 test_cv_getset_call_checker()
2441     PREINIT:
2442         CV *troc_cv, *tsh_cv;
2443         Perl_call_checker ckfun;
2444         SV *ckobj;
2445     CODE:
2446 #define check_cc(cv, xckfun, xckobj) \
2447     do { \
2448         cv_get_call_checker((cv), &ckfun, &ckobj); \
2449         if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \
2450         if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \
2451     } while(0)
2452         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
2453         tsh_cv = get_cv("XS::APItest::test_savehints", 0);
2454         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2455         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2456         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
2457                                     &PL_sv_yes);
2458         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2459         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
2460         cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2461         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2462         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
2463         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
2464                                     (SV*)tsh_cv);
2465         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
2466         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2467         cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
2468                                     (SV*)troc_cv);
2469         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
2470         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
2471         if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
2472         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
2473 #undef check_cc
2474
2475 void
2476 cv_set_call_checker_lists(CV *cv)
2477     CODE:
2478         cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
2479
2480 void
2481 cv_set_call_checker_scalars(CV *cv)
2482     CODE:
2483         cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
2484
2485 void
2486 cv_set_call_checker_proto(CV *cv, SV *proto)
2487     CODE:
2488         if (SvROK(proto))
2489             proto = SvRV(proto);
2490         cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
2491
2492 void
2493 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
2494     CODE:
2495         if (SvROK(proto))
2496             proto = SvRV(proto);
2497         cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
2498
2499 void
2500 cv_set_call_checker_multi_sum(CV *cv)
2501     CODE:
2502         cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
2503
2504 void
2505 test_cophh()
2506     PREINIT:
2507         COPHH *a, *b;
2508     CODE:
2509 #define check_ph(EXPR) \
2510             do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
2511 #define check_iv(EXPR, EXPECT) \
2512             do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
2513 #define msvpvs(STR) sv_2mortal(newSVpvs(STR))
2514 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
2515         a = cophh_new_empty();
2516         check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
2517         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
2518         check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
2519         check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
2520         a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
2521         a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
2522         a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
2523         a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
2524         check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
2525         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
2526         check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
2527         check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
2528         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
2529         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2530         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2531         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2532         b = cophh_copy(a);
2533         b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
2534         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
2535         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
2536         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2537         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2538         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2539         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
2540         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
2541         check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
2542         check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
2543         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
2544         a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
2545         a = cophh_delete_pvs(a, "foo_2", 0);
2546         b = cophh_delete_pv(b, "foo_3", 0, 0);
2547         b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
2548         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
2549         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
2550         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2551         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2552         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2553         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
2554         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
2555         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
2556         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
2557         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
2558         b = cophh_delete_pvs(b, "foo_3", 0);
2559         b = cophh_delete_pvs(b, "foo_5", 0);
2560         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
2561         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
2562         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
2563         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
2564         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
2565         cophh_free(b);
2566         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
2567         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
2568         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
2569         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
2570         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
2571         a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
2572         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
2573         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
2574         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
2575         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
2576         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
2577         check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
2578         check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
2579         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
2580         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
2581         check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
2582         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
2583         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
2584         check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
2585         check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
2586         check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
2587         check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
2588         check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
2589         ENTER;
2590         SAVEFREECOPHH(a);
2591         LEAVE;
2592 #undef check_ph
2593 #undef check_iv
2594 #undef msvpvs
2595 #undef msviv
2596
2597 void
2598 test_coplabel()
2599     PREINIT:
2600         COP *cop;
2601         const char *label;
2602         STRLEN len;
2603         U32 utf8;
2604     CODE:
2605         cop = &PL_compiling;
2606         Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
2607         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
2608         if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
2609         if (len != 3) croak("fail # cop_fetch_label len");
2610         if (utf8) croak("fail # cop_fetch_label utf8");
2611         /* SMALL GERMAN UMLAUT A */
2612         Perl_cop_store_label(aTHX_ cop, "foä", 4, SVf_UTF8);
2613         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
2614         if (strcmp(label,"foä")) croak("fail # cop_fetch_label label");
2615         if (len != 4) croak("fail # cop_fetch_label len");
2616         if (!utf8) croak("fail # cop_fetch_label utf8");
2617
2618
2619 HV *
2620 example_cophh_2hv()
2621     PREINIT:
2622         COPHH *a;
2623     CODE:
2624 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
2625         a = cophh_new_empty();
2626         a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
2627         a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
2628         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
2629         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
2630         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
2631         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
2632         a = cophh_delete_pvs(a, "foo_0", 0);
2633         a = cophh_delete_pvs(a, "foo_2", 0);
2634         RETVAL = cophh_2hv(a, 0);
2635         cophh_free(a);
2636 #undef msviv
2637     OUTPUT:
2638         RETVAL
2639
2640 void
2641 test_savehints()
2642     PREINIT:
2643         SV **svp, *sv;
2644     CODE:
2645 #define store_hint(KEY, VALUE) \
2646                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
2647 #define hint_ok(KEY, EXPECT) \
2648                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
2649                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
2650                     (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
2651                     SvIV(sv) == (EXPECT))
2652 #define check_hint(KEY, EXPECT) \
2653                 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
2654         PL_hints |= HINT_LOCALIZE_HH;
2655         ENTER;
2656         SAVEHINTS();
2657         PL_hints &= HINT_INTEGER;
2658         store_hint("t0", 123);
2659         store_hint("t1", 456);
2660         if (PL_hints & HINT_INTEGER) croak_fail();
2661         check_hint("t0", 123); check_hint("t1", 456);
2662         ENTER;
2663         SAVEHINTS();
2664         if (PL_hints & HINT_INTEGER) croak_fail();
2665         check_hint("t0", 123); check_hint("t1", 456);
2666         PL_hints |= HINT_INTEGER;
2667         store_hint("t0", 321);
2668         if (!(PL_hints & HINT_INTEGER)) croak_fail();
2669         check_hint("t0", 321); check_hint("t1", 456);
2670         LEAVE;
2671         if (PL_hints & HINT_INTEGER) croak_fail();
2672         check_hint("t0", 123); check_hint("t1", 456);
2673         ENTER;
2674         SAVEHINTS();
2675         if (PL_hints & HINT_INTEGER) croak_fail();
2676         check_hint("t0", 123); check_hint("t1", 456);
2677         store_hint("t1", 654);
2678         if (PL_hints & HINT_INTEGER) croak_fail();
2679         check_hint("t0", 123); check_hint("t1", 654);
2680         LEAVE;
2681         if (PL_hints & HINT_INTEGER) croak_fail();
2682         check_hint("t0", 123); check_hint("t1", 456);
2683         LEAVE;
2684 #undef store_hint
2685 #undef hint_ok
2686 #undef check_hint
2687
2688 void
2689 test_copyhints()
2690     PREINIT:
2691         HV *a, *b;
2692     CODE:
2693         PL_hints |= HINT_LOCALIZE_HH;
2694         ENTER;
2695         SAVEHINTS();
2696         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
2697         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
2698             croak_fail();
2699         a = newHVhv(GvHV(PL_hintgv));
2700         sv_2mortal((SV*)a);
2701         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
2702         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
2703             croak_fail();
2704         b = hv_copy_hints_hv(a);
2705         sv_2mortal((SV*)b);
2706         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
2707         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
2708             croak_fail();
2709         LEAVE;
2710
2711 void
2712 test_op_list()
2713     PREINIT:
2714         OP *a;
2715     CODE:
2716 #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
2717 #define check_op(o, expect) \
2718     do { \
2719         if (strcmp(test_op_list_describe(o), (expect))) \
2720             croak("fail %s %s", test_op_list_describe(o), (expect)); \
2721     } while(0)
2722         a = op_append_elem(OP_LIST, NULL, NULL);
2723         check_op(a, "");
2724         a = op_append_elem(OP_LIST, iv_op(1), a);
2725         check_op(a, "const(1).");
2726         a = op_append_elem(OP_LIST, NULL, a);
2727         check_op(a, "const(1).");
2728         a = op_append_elem(OP_LIST, a, iv_op(2));
2729         check_op(a, "list[pushmark.const(1).const(2).]");
2730         a = op_append_elem(OP_LIST, a, iv_op(3));
2731         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2732         a = op_append_elem(OP_LIST, a, NULL);
2733         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2734         a = op_append_elem(OP_LIST, NULL, a);
2735         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2736         a = op_append_elem(OP_LIST, iv_op(4), a);
2737         check_op(a, "list[pushmark.const(4)."
2738                 "list[pushmark.const(1).const(2).const(3).]]");
2739         a = op_append_elem(OP_LIST, a, iv_op(5));
2740         check_op(a, "list[pushmark.const(4)."
2741                 "list[pushmark.const(1).const(2).const(3).]const(5).]");
2742         a = op_append_elem(OP_LIST, a,
2743                 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
2744         check_op(a, "list[pushmark.const(4)."
2745                 "list[pushmark.const(1).const(2).const(3).]const(5)."
2746                 "list[pushmark.const(7).const(6).]]");
2747         op_free(a);
2748         a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
2749         check_op(a, "lineseq[const(1).const(2).]");
2750         a = op_append_elem(OP_LINESEQ, a, iv_op(3));
2751         check_op(a, "lineseq[const(1).const(2).const(3).]");
2752         op_free(a);
2753         a = op_append_elem(OP_LINESEQ,
2754                 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
2755                 iv_op(3));
2756         check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
2757         op_free(a);
2758         a = op_prepend_elem(OP_LIST, NULL, NULL);
2759         check_op(a, "");
2760         a = op_prepend_elem(OP_LIST, a, iv_op(1));
2761         check_op(a, "const(1).");
2762         a = op_prepend_elem(OP_LIST, a, NULL);
2763         check_op(a, "const(1).");
2764         a = op_prepend_elem(OP_LIST, iv_op(2), a);
2765         check_op(a, "list[pushmark.const(2).const(1).]");
2766         a = op_prepend_elem(OP_LIST, iv_op(3), a);
2767         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2768         a = op_prepend_elem(OP_LIST, NULL, a);
2769         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2770         a = op_prepend_elem(OP_LIST, a, NULL);
2771         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2772         a = op_prepend_elem(OP_LIST, a, iv_op(4));
2773         check_op(a, "list[pushmark."
2774                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2775         a = op_prepend_elem(OP_LIST, iv_op(5), a);
2776         check_op(a, "list[pushmark.const(5)."
2777                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2778         a = op_prepend_elem(OP_LIST,
2779                 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
2780         check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
2781                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2782         op_free(a);
2783         a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
2784         check_op(a, "lineseq[const(2).const(1).]");
2785         a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
2786         check_op(a, "lineseq[const(3).const(2).const(1).]");
2787         op_free(a);
2788         a = op_prepend_elem(OP_LINESEQ, iv_op(3),
2789                 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
2790         check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
2791         op_free(a);
2792         a = op_append_list(OP_LINESEQ, NULL, NULL);
2793         check_op(a, "");
2794         a = op_append_list(OP_LINESEQ, iv_op(1), a);
2795         check_op(a, "const(1).");
2796         a = op_append_list(OP_LINESEQ, NULL, a);
2797         check_op(a, "const(1).");
2798         a = op_append_list(OP_LINESEQ, a, iv_op(2));
2799         check_op(a, "lineseq[const(1).const(2).]");
2800         a = op_append_list(OP_LINESEQ, a, iv_op(3));
2801         check_op(a, "lineseq[const(1).const(2).const(3).]");
2802         a = op_append_list(OP_LINESEQ, iv_op(4), a);
2803         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2804         a = op_append_list(OP_LINESEQ, a, NULL);
2805         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2806         a = op_append_list(OP_LINESEQ, NULL, a);
2807         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2808         a = op_append_list(OP_LINESEQ, a,
2809                 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
2810         check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
2811                 "const(5).const(6).]");
2812         op_free(a);
2813         a = op_append_list(OP_LINESEQ,
2814                 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
2815                 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
2816         check_op(a, "lineseq[const(1).const(2)."
2817                 "list[pushmark.const(3).const(4).]]");
2818         op_free(a);
2819         a = op_append_list(OP_LINESEQ,
2820                 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
2821                 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
2822         check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
2823                 "const(3).const(4).]");
2824         op_free(a);
2825 #undef check_op
2826
2827 void
2828 test_op_linklist ()
2829     PREINIT:
2830         OP *o;
2831     CODE:
2832 #define check_ll(o, expect) \
2833     STMT_START { \
2834         if (strNE(test_op_linklist_describe(o), (expect))) \
2835             croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
2836     } STMT_END
2837         o = iv_op(1);
2838         check_ll(o, ".const1");
2839         op_free(o);
2840
2841         o = mkUNOP(OP_NOT, iv_op(1));
2842         check_ll(o, ".const1.not");
2843         op_free(o);
2844
2845         o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
2846         check_ll(o, ".const1.negate.not");
2847         op_free(o);
2848
2849         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2850         check_ll(o, ".const1.const2.add");
2851         op_free(o);
2852
2853         o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
2854         check_ll(o, ".const1.not.const2.add");
2855         op_free(o);
2856
2857         o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
2858         check_ll(o, ".const1.const2.add.not");
2859         op_free(o);
2860
2861         o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
2862         check_ll(o, ".const1.const2.const3.lineseq");
2863         op_free(o);
2864
2865         o = mkLISTOP(OP_LINESEQ,
2866                 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
2867                 mkUNOP(OP_NOT, iv_op(3)),
2868                 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
2869         check_ll(o, ".const1.const2.add.const3.not"
2870                     ".const4.const5.const6.substr.lineseq");
2871         op_free(o);
2872
2873         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2874         LINKLIST(o);
2875         o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
2876         check_ll(o, ".const1.const2.add.const3.subtract");
2877         op_free(o);
2878 #undef check_ll
2879 #undef iv_op
2880
2881 void
2882 peep_enable ()
2883     PREINIT:
2884         dMY_CXT;
2885     CODE:
2886         av_clear(MY_CXT.peep_recorder);
2887         av_clear(MY_CXT.rpeep_recorder);
2888         MY_CXT.peep_recording = 1;
2889
2890 void
2891 peep_disable ()
2892     PREINIT:
2893         dMY_CXT;
2894     CODE:
2895         MY_CXT.peep_recording = 0;
2896
2897 SV *
2898 peep_record ()
2899     PREINIT:
2900         dMY_CXT;
2901     CODE:
2902         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
2903     OUTPUT:
2904         RETVAL
2905
2906 SV *
2907 rpeep_record ()
2908     PREINIT:
2909         dMY_CXT;
2910     CODE:
2911         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
2912     OUTPUT:
2913         RETVAL
2914
2915 =pod
2916
2917 multicall_each: call a sub for each item in the list. Used to test MULTICALL
2918
2919 =cut
2920
2921 void
2922 multicall_each(block,...)
2923     SV * block
2924 PROTOTYPE: &@
2925 CODE:
2926 {
2927     dMULTICALL;
2928     int index;
2929     GV *gv;
2930     HV *stash;
2931     I32 gimme = G_SCALAR;
2932     SV **args = &PL_stack_base[ax];
2933     CV *cv;
2934
2935     if(items <= 1) {
2936         XSRETURN_UNDEF;
2937     }
2938     cv = sv_2cv(block, &stash, &gv, 0);
2939     if (cv == Nullcv) {
2940        croak("multicall_each: not a subroutine reference");
2941     }
2942     PUSH_MULTICALL(cv);
2943     SAVESPTR(GvSV(PL_defgv));
2944
2945     for(index = 1 ; index < items ; index++) {
2946         GvSV(PL_defgv) = args[index];
2947         MULTICALL;
2948     }
2949     POP_MULTICALL;
2950     XSRETURN_UNDEF;
2951 }
2952
2953 #ifdef USE_ITHREADS
2954
2955 void
2956 clone_with_stack()
2957 CODE:
2958 {
2959     PerlInterpreter *interp = aTHX; /* The original interpreter */
2960     PerlInterpreter *interp_dup;    /* The duplicate interpreter */
2961     int oldscope = 1; /* We are responsible for all scopes */
2962
2963     interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
2964
2965     /* destroy old perl */
2966     PERL_SET_CONTEXT(interp);
2967
2968     POPSTACK_TO(PL_mainstack);
2969     dounwind(-1);
2970     LEAVE_SCOPE(0);
2971
2972     while (interp->Iscopestack_ix > 1)
2973         LEAVE;
2974     FREETMPS;
2975
2976     perl_destruct(interp);
2977     perl_free(interp);
2978
2979     /* switch to new perl */
2980     PERL_SET_CONTEXT(interp_dup);
2981
2982     /* continue after 'clone_with_stack' */
2983     interp_dup->Iop = interp_dup->Iop->op_next;
2984
2985     /* run with new perl */
2986     Perl_runops_standard(interp_dup);
2987
2988     /* We may have additional unclosed scopes if fork() was called
2989      * from within a BEGIN block.  See perlfork.pod for more details.
2990      * We cannot clean up these other scopes because they belong to a
2991      * different interpreter, but we also cannot leave PL_scopestack_ix
2992      * dangling because that can trigger an assertion in perl_destruct().
2993      */
2994     if (PL_scopestack_ix > oldscope) {
2995         PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
2996         PL_scopestack_ix = oldscope;
2997     }
2998
2999     perl_destruct(interp_dup);
3000     perl_free(interp_dup);
3001
3002     /* call the real 'exit' not PerlProc_exit */
3003 #undef exit
3004     exit(0);
3005 }
3006
3007 #endif /* USE_ITHREDS */
3008
3009 SV*
3010 take_svref(SVREF sv)
3011 CODE:
3012     RETVAL = newRV_inc(sv);
3013 OUTPUT:
3014     RETVAL
3015
3016 SV*
3017 take_avref(AV* av)
3018 CODE:
3019     RETVAL = newRV_inc((SV*)av);
3020 OUTPUT:
3021     RETVAL
3022
3023 SV*
3024 take_hvref(HV* hv)
3025 CODE:
3026     RETVAL = newRV_inc((SV*)hv);
3027 OUTPUT:
3028     RETVAL
3029
3030
3031 SV*
3032 take_cvref(CV* cv)
3033 CODE:
3034     RETVAL = newRV_inc((SV*)cv);
3035 OUTPUT:
3036     RETVAL
3037
3038
3039 BOOT:
3040         {
3041         HV* stash;
3042         SV** meth = NULL;
3043         CV* cv;
3044         stash = gv_stashpv("XS::APItest::TempLv", 0);
3045         if (stash)
3046             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
3047         if (!meth)
3048             croak("lost method 'make_temp_mg_lv'");
3049         cv = GvCV(*meth);
3050         CvLVALUE_on(cv);
3051         }
3052
3053 BOOT:
3054 {
3055     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
3056     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
3057     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
3058     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
3059     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
3060     hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
3061     hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
3062     hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
3063     hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
3064     hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
3065     hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
3066     hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
3067     hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
3068     hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
3069     hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
3070     hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
3071     hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
3072     next_keyword_plugin = PL_keyword_plugin;
3073     PL_keyword_plugin = my_keyword_plugin;
3074 }
3075
3076 void
3077 establish_cleanup(...)
3078 PROTOTYPE: $
3079 CODE:
3080     PERL_UNUSED_VAR(items);
3081     croak("establish_cleanup called as a function");
3082
3083 BOOT:
3084 {
3085     CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
3086     cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
3087 }
3088
3089 void
3090 postinc(...)
3091 PROTOTYPE: $
3092 CODE:
3093     PERL_UNUSED_VAR(items);
3094     croak("postinc called as a function");
3095
3096 void
3097 filter()
3098 CODE:
3099     filter_add(filter_call, NULL);
3100
3101 BOOT:
3102 {
3103     CV *asscv = get_cv("XS::APItest::postinc", 0);
3104     cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
3105 }
3106
3107 SV *
3108 lv_temp_object()
3109 CODE:
3110     RETVAL =
3111           sv_bless(
3112             newRV_noinc(newSV(0)),
3113             gv_stashpvs("XS::APItest::TempObj",GV_ADD)
3114           );             /* Package defined in test script */
3115 OUTPUT:
3116     RETVAL
3117
3118 void
3119 fill_hash_with_nulls(HV *hv)
3120 PREINIT:
3121     UV i = 0;
3122 CODE:
3123     for(; i < 1000; ++i) {
3124         HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
3125         SvREFCNT_dec(HeVAL(entry));
3126         HeVAL(entry) = NULL;
3127     }
3128
3129 bool
3130 SvIsCOW(SV *sv)
3131 CODE:
3132     RETVAL = SvIsCOW(sv);
3133 OUTPUT:
3134     RETVAL
3135
3136 void
3137 pad_scalar(...)
3138 PROTOTYPE: $$
3139 CODE:
3140     PERL_UNUSED_VAR(items);
3141     croak("pad_scalar called as a function");
3142
3143 BOOT:
3144 {
3145     CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
3146     cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
3147 }
3148
3149 SV*
3150 fetch_pad_names( cv )
3151 CV* cv
3152  PREINIT:
3153   I32 i;
3154   AV *pad_namelist;
3155   AV *retav = newAV();
3156  CODE:
3157   pad_namelist = (AV*) *av_fetch(CvPADLIST(cv), 0, FALSE);
3158
3159   for ( i = av_len(pad_namelist); i >= 0; i-- ) {
3160     SV** name_ptr = av_fetch(pad_namelist, i, 0);
3161
3162     if (name_ptr && SvPOKp(*name_ptr)) {
3163         av_push(retav, newSVsv(*name_ptr));
3164     }
3165   }
3166   RETVAL = newRV_noinc((SV*)retav);
3167  OUTPUT:
3168   RETVAL
3169
3170 STRLEN
3171 underscore_length()
3172 PROTOTYPE:
3173 PREINIT:
3174     SV *u;
3175     U8 *pv;
3176     STRLEN bytelen;
3177 CODE:
3178     u = find_rundefsv();
3179     pv = (U8*)SvPV(u, bytelen);
3180     RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
3181 OUTPUT:
3182     RETVAL
3183
3184 void
3185 stringify(SV *sv)
3186 PREINIT:
3187     const char *pv;
3188 CODE:
3189     pv = SvPV_nolen(sv);
3190
3191 SV *
3192 HvENAME(HV *hv)
3193 CODE:
3194     RETVAL = hv && HvENAME(hv)
3195               ? newSVpvn_flags(
3196                   HvENAME(hv),HvENAMELEN(hv),
3197                   (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
3198                 )
3199               : NULL;
3200 OUTPUT:
3201     RETVAL
3202
3203
3204 MODULE = XS::APItest            PACKAGE = XS::APItest::Magic
3205
3206 PROTOTYPES: DISABLE
3207
3208 void
3209 sv_magic_foo(SV *sv, SV *thingy)
3210 ALIAS:
3211     sv_magic_bar = 1
3212 CODE:
3213     sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
3214
3215 SV *
3216 mg_find_foo(SV *sv)
3217 ALIAS:
3218     mg_find_bar = 1
3219 CODE:
3220     MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
3221     RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef;
3222 OUTPUT:
3223     RETVAL
3224
3225 void
3226 sv_unmagic_foo(SV *sv)
3227 ALIAS:
3228     sv_unmagic_bar = 1
3229 CODE:
3230     sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
3231
3232 UV
3233 test_get_vtbl()
3234     PREINIT:
3235         MGVTBL *have;
3236         MGVTBL *want;
3237     CODE:
3238 #define test_get_this_vtable(name) \
3239         want = CAT2(&PL_vtbl_, name); \
3240         have = get_vtbl(CAT2(want_vtbl_, name)); \
3241         if (have != want) \
3242             croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
3243
3244         test_get_this_vtable(sv);
3245         test_get_this_vtable(env);
3246         test_get_this_vtable(envelem);
3247         test_get_this_vtable(sigelem);
3248         test_get_this_vtable(pack);
3249         test_get_this_vtable(packelem);
3250         test_get_this_vtable(dbline);
3251         test_get_this_vtable(isa);
3252         test_get_this_vtable(isaelem);
3253         test_get_this_vtable(arylen);
3254         test_get_this_vtable(mglob);
3255         test_get_this_vtable(nkeys);
3256         test_get_this_vtable(taint);
3257         test_get_this_vtable(substr);
3258         test_get_this_vtable(vec);
3259         test_get_this_vtable(pos);
3260         test_get_this_vtable(bm);
3261         test_get_this_vtable(fm);
3262         test_get_this_vtable(uvar);
3263         test_get_this_vtable(defelem);
3264         test_get_this_vtable(regexp);
3265         test_get_this_vtable(regdata);
3266         test_get_this_vtable(regdatum);
3267 #ifdef USE_LOCALE_COLLATE
3268         test_get_this_vtable(collxfrm);
3269 #endif
3270         test_get_this_vtable(amagic);
3271         test_get_this_vtable(amagicelem);
3272         test_get_this_vtable(backref);
3273         test_get_this_vtable(utf8);
3274
3275         RETVAL = PTR2UV(get_vtbl(-1));
3276     OUTPUT:
3277         RETVAL