ext/XS-APItest/APItest.xs

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