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         }
2575         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2576
2577 void
2578 gv_autoload_type(stash, methname, type, method)
2579     HV* stash
2580     SV* methname
2581     int type
2582     I32 method
2583     PREINIT:
2584         STRLEN len;
2585         const char * const name = SvPV_const(methname, len);
2586         GV* gv = NULL;
2587         I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
2588     PPCODE:
2589         switch (type) {
2590            case 0:
2591                gv = gv_autoload4(stash, name, len, method);
2592                break;
2593            case 1:
2594                gv = gv_autoload_sv(stash, methname, flags);
2595                break;
2596            case 2:
2597                gv = gv_autoload_pv(stash, name, flags | SvUTF8(methname));
2598                break;
2599            case 3:
2600                gv = gv_autoload_pvn(stash, name, len, flags | SvUTF8(methname));
2601                break;
2602         }
2603         XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
2604
2605 SV *
2606 gv_const_sv(SV *name)
2607     PREINIT:
2608         GV *gv;
2609     CODE:
2610         if (SvPOK(name)) {
2611             HV *stash = gv_stashpv("main",0);
2612             HE *he = hv_fetch_ent(stash, name, 0, 0);
2613             gv = (GV *)HeVAL(he);
2614         }
2615         else {
2616             gv = (GV *)name;
2617         }
2618         RETVAL = gv_const_sv(gv);
2619         if (!RETVAL)
2620             XSRETURN_EMPTY;
2621         RETVAL = newSVsv(RETVAL);
2622     OUTPUT:
2623         RETVAL
2624
2625 void
2626 whichsig_type(namesv, type)
2627     SV* namesv
2628     int type
2629     PREINIT:
2630         STRLEN len;
2631         const char * const name = SvPV_const(namesv, len);
2632         I32 i = 0;
2633     PPCODE:
2634         switch (type) {
2635            case 0:
2636               i = whichsig(name);
2637                break;
2638            case 1:
2639                i = whichsig_sv(namesv);
2640                break;
2641            case 2:
2642                i = whichsig_pv(name);
2643                break;
2644            case 3:
2645                i = whichsig_pvn(name, len);
2646                break;
2647         }
2648         XPUSHs(sv_2mortal(newSViv(i)));
2649
2650 void
2651 eval_sv(sv, flags)
2652     SV* sv
2653     I32 flags
2654     PREINIT:
2655         I32 i;
2656     PPCODE:
2657         PUTBACK;
2658         i = eval_sv(sv, flags);
2659         SPAGAIN;
2660         EXTEND(SP, 1);
2661         PUSHs(sv_2mortal(newSViv(i)));
2662
2663 void
2664 eval_pv(p, croak_on_error)
2665     const char* p
2666     I32 croak_on_error
2667     PPCODE:
2668         PUTBACK;
2669         EXTEND(SP, 1);
2670         PUSHs(eval_pv(p, croak_on_error));
2671
2672 void
2673 require_pv(pv)
2674     const char* pv
2675     PPCODE:
2676         PUTBACK;
2677         require_pv(pv);
2678
2679 int
2680 apitest_exception(throw_e)
2681     int throw_e
2682     OUTPUT:
2683         RETVAL
2684
2685 void
2686 mycroak(sv)
2687     SV* sv
2688     CODE:
2689     if (SvOK(sv)) {
2690         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
2691     }
2692     else {
2693         Perl_croak(aTHX_ NULL);
2694     }
2695
2696 SV*
2697 strtab()
2698    CODE:
2699    RETVAL = newRV_inc((SV*)PL_strtab);
2700    OUTPUT:
2701    RETVAL
2702
2703 int
2704 my_cxt_getint()
2705     CODE:
2706         dMY_CXT;
2707         RETVAL = my_cxt_getint_p(aMY_CXT);
2708     OUTPUT:
2709         RETVAL
2710
2711 void
2712 my_cxt_setint(i)
2713     int i;
2714     CODE:
2715         dMY_CXT;
2716         my_cxt_setint_p(aMY_CXT_ i);
2717
2718 void
2719 my_cxt_getsv(how)
2720     bool how;
2721     PPCODE:
2722         EXTEND(SP, 1);
2723         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
2724         XSRETURN(1);
2725
2726 void
2727 my_cxt_setsv(sv)
2728     SV *sv;
2729     CODE:
2730         dMY_CXT;
2731         SvREFCNT_dec(MY_CXT.sv);
2732         my_cxt_setsv_p(sv _aMY_CXT);
2733         SvREFCNT_inc(sv);
2734
2735 bool
2736 sv_setsv_cow_hashkey_core()
2737
2738 bool
2739 sv_setsv_cow_hashkey_notcore()
2740
2741 void
2742 sv_set_deref(SV *sv, SV *sv2, int which)
2743     CODE:
2744     {
2745         STRLEN len;
2746         const char *pv = SvPV(sv2,len);
2747         if (!SvROK(sv)) croak("Not a ref");
2748         sv = SvRV(sv);
2749         switch (which) {
2750             case 0: sv_setsv(sv,sv2); break;
2751             case 1: sv_setpv(sv,pv); break;
2752             case 2: sv_setpvn(sv,pv,len); break;
2753         }
2754     }
2755
2756 void
2757 rmagical_cast(sv, type)
2758     SV *sv;
2759     SV *type;
2760     PREINIT:
2761         struct ufuncs uf;
2762     PPCODE:
2763         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
2764         sv = SvRV(sv);
2765         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
2766         uf.uf_val = rmagical_a_dummy;
2767         uf.uf_set = NULL;
2768         uf.uf_index = 0;
2769         if (SvTRUE(type)) { /* b */
2770             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
2771         } else { /* a */
2772             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
2773         }
2774         XSRETURN_YES;
2775
2776 void
2777 rmagical_flags(sv)
2778     SV *sv;
2779     PPCODE:
2780         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
2781         sv = SvRV(sv);
2782         EXTEND(SP, 3);
2783         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
2784         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
2785         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
2786         XSRETURN(3);
2787
2788 void
2789 my_caller(level)
2790         I32 level
2791     PREINIT:
2792         const PERL_CONTEXT *cx, *dbcx;
2793         const char *pv;
2794         const GV *gv;
2795         HV *hv;
2796     PPCODE:
2797         cx = caller_cx(level, &dbcx);
2798         EXTEND(SP, 8);
2799
2800         pv = CopSTASHPV(cx->blk_oldcop);
2801         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2802         gv = CvGV(cx->blk_sub.cv);
2803         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2804
2805         pv = CopSTASHPV(dbcx->blk_oldcop);
2806         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
2807         gv = CvGV(dbcx->blk_sub.cv);
2808         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
2809
2810         ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
2811         ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
2812         ST(6) = cop_hints_fetch_sv(cx->blk_oldcop,
2813                 sv_2mortal(newSVpvs("foo")), 0, 0);
2814
2815         hv = cop_hints_2hv(cx->blk_oldcop, 0);
2816         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
2817
2818         XSRETURN(8);
2819
2820 void
2821 DPeek (sv)
2822     SV   *sv
2823
2824   PPCODE:
2825     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
2826     XSRETURN (1);
2827
2828 void
2829 BEGIN()
2830     CODE:
2831         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
2832
2833 void
2834 CHECK()
2835     CODE:
2836         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
2837
2838 void
2839 UNITCHECK()
2840     CODE:
2841         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
2842
2843 void
2844 INIT()
2845     CODE:
2846         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
2847
2848 void
2849 END()
2850     CODE:
2851         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
2852
2853 void
2854 utf16_to_utf8 (sv, ...)
2855     SV* sv
2856         ALIAS:
2857             utf16_to_utf8_reversed = 1
2858     PREINIT:
2859         STRLEN len;
2860         U8 *source;
2861         SV *dest;
2862         I32 got; /* Gah, badly thought out APIs */
2863     CODE:
2864         if (ix) (void)SvPV_force_nolen(sv);
2865         source = (U8 *)SvPVbyte(sv, len);
2866         /* Optionally only convert part of the buffer.  */
2867         if (items > 1) {
2868             len = SvUV(ST(1));
2869         }
2870         /* Mortalise this right now, as we'll be testing croak()s  */
2871         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
2872         if (ix) {
2873             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
2874         } else {
2875             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
2876         }
2877         SvCUR_set(dest, got);
2878         SvPVX(dest)[got] = '\0';
2879         SvPOK_on(dest);
2880         ST(0) = dest;
2881         XSRETURN(1);
2882
2883 void
2884 my_exit(int exitcode)
2885         PPCODE:
2886         my_exit(exitcode);
2887
2888 U8
2889 first_byte(sv)
2890         SV *sv
2891    CODE:
2892     char *s;
2893     STRLEN len;
2894         s = SvPVbyte(sv, len);
2895         RETVAL = s[0];
2896    OUTPUT:
2897     RETVAL
2898
2899 I32
2900 sv_count()
2901         CODE:
2902             RETVAL = PL_sv_count;
2903         OUTPUT:
2904             RETVAL
2905
2906 void
2907 bhk_record(bool on)
2908     CODE:
2909         dMY_CXT;
2910         MY_CXT.bhk_record = on;
2911         if (on)
2912             av_clear(MY_CXT.bhkav);
2913
2914 void
2915 test_magic_chain()
2916     PREINIT:
2917         SV *sv;
2918         MAGIC *callmg, *uvarmg;
2919     CODE:
2920         sv = sv_2mortal(newSV(0));
2921         if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
2922         if (SvMAGICAL(sv)) croak_fail();
2923         sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
2924         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2925         if (!SvMAGICAL(sv)) croak_fail();
2926         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2927         callmg = mg_find(sv, PERL_MAGIC_checkcall);
2928         if (!callmg) croak_fail();
2929         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2930             croak_fail();
2931         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2932         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2933         if (!SvMAGICAL(sv)) croak_fail();
2934         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2935         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2936         if (!uvarmg) croak_fail();
2937         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2938             croak_fail();
2939         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2940             croak_fail();
2941         mg_free_type(sv, PERL_MAGIC_vec);
2942         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2943         if (!SvMAGICAL(sv)) croak_fail();
2944         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2945         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2946         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2947             croak_fail();
2948         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2949             croak_fail();
2950         mg_free_type(sv, PERL_MAGIC_uvar);
2951         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2952         if (!SvMAGICAL(sv)) croak_fail();
2953         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2954         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2955         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2956             croak_fail();
2957         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
2958         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2959         if (!SvMAGICAL(sv)) croak_fail();
2960         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
2961         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
2962         if (!uvarmg) croak_fail();
2963         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
2964             croak_fail();
2965         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2966             croak_fail();
2967         mg_free_type(sv, PERL_MAGIC_checkcall);
2968         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
2969         if (!SvMAGICAL(sv)) croak_fail();
2970         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
2971         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2972         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
2973             croak_fail();
2974         mg_free_type(sv, PERL_MAGIC_uvar);
2975         if (SvMAGICAL(sv)) croak_fail();
2976         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
2977         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
2978
2979 void
2980 test_op_contextualize()
2981     PREINIT:
2982         OP *o;
2983     CODE:
2984         o = newSVOP(OP_CONST, 0, newSViv(0));
2985         o->op_flags &= ~OPf_WANT;
2986         o = op_contextualize(o, G_SCALAR);
2987         if (o->op_type != OP_CONST ||
2988                 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
2989             croak_fail();
2990         op_free(o);
2991         o = newSVOP(OP_CONST, 0, newSViv(0));
2992         o->op_flags &= ~OPf_WANT;
2993         o = op_contextualize(o, G_ARRAY);
2994         if (o->op_type != OP_CONST ||
2995                 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
2996             croak_fail();
2997         op_free(o);
2998         o = newSVOP(OP_CONST, 0, newSViv(0));
2999         o->op_flags &= ~OPf_WANT;
3000         o = op_contextualize(o, G_VOID);
3001         if (o->op_type != OP_NULL) croak_fail();
3002         op_free(o);
3003
3004 void
3005 test_rv2cv_op_cv()
3006     PROTOTYPE:
3007     PREINIT:
3008         GV *troc_gv;
3009         CV *troc_cv;
3010         OP *o;
3011     CODE:
3012         troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
3013         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
3014         o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
3015         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3016         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3017             croak_fail();
3018         o->op_private |= OPpENTERSUB_AMPER;
3019         if (rv2cv_op_cv(o, 0)) croak_fail();
3020         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3021         o->op_private &= ~OPpENTERSUB_AMPER;
3022         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3023         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3024         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3025         op_free(o);
3026         o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
3027         o->op_private = OPpCONST_BARE;
3028         o = newCVREF(0, o);
3029         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3030         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3031             croak_fail();
3032         o->op_private |= OPpENTERSUB_AMPER;
3033         if (rv2cv_op_cv(o, 0)) croak_fail();
3034         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3035         op_free(o);
3036         o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
3037         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
3038         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
3039             croak_fail();
3040         o->op_private |= OPpENTERSUB_AMPER;
3041         if (rv2cv_op_cv(o, 0)) croak_fail();
3042         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3043         o->op_private &= ~OPpENTERSUB_AMPER;
3044         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3045         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
3046         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3047         op_free(o);
3048         o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
3049         if (rv2cv_op_cv(o, 0)) croak_fail();
3050         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3051         o->op_private |= OPpENTERSUB_AMPER;
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 (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3056         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
3057         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
3058         op_free(o);
3059         o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
3060         if (rv2cv_op_cv(o, 0)) croak_fail();
3061         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
3062         op_free(o);
3063
3064 void
3065 test_cv_getset_call_checker()
3066     PREINIT:
3067         CV *troc_cv, *tsh_cv;
3068         Perl_call_checker ckfun;
3069         SV *ckobj;
3070     CODE:
3071 #define check_cc(cv, xckfun, xckobj) \
3072     do { \
3073         cv_get_call_checker((cv), &ckfun, &ckobj); \
3074         if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \
3075         if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \
3076     } while(0)
3077         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
3078         tsh_cv = get_cv("XS::APItest::test_savehints", 0);
3079         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
3080         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
3081         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3082                                     &PL_sv_yes);
3083         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
3084         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
3085         cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3086         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3087         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
3088         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
3089                                     (SV*)tsh_cv);
3090         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
3091         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
3092         cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
3093                                     (SV*)troc_cv);
3094         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
3095         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
3096         if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
3097         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
3098 #undef check_cc
3099
3100 void
3101 cv_set_call_checker_lists(CV *cv)
3102     CODE:
3103         cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
3104
3105 void
3106 cv_set_call_checker_scalars(CV *cv)
3107     CODE:
3108         cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
3109
3110 void
3111 cv_set_call_checker_proto(CV *cv, SV *proto)
3112     CODE:
3113         if (SvROK(proto))
3114             proto = SvRV(proto);
3115         cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
3116
3117 void
3118 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
3119     CODE:
3120         if (SvROK(proto))
3121             proto = SvRV(proto);
3122         cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
3123
3124 void
3125 cv_set_call_checker_multi_sum(CV *cv)
3126     CODE:
3127         cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
3128
3129 void
3130 test_cophh()
3131     PREINIT:
3132         COPHH *a, *b;
3133 #ifdef EBCDIC
3134         SV* key_sv;
3135         char * key_name;
3136         STRLEN key_len;
3137 #endif
3138     CODE:
3139 #define check_ph(EXPR) \
3140             do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
3141 #define check_iv(EXPR, EXPECT) \
3142             do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
3143 #define msvpvs(STR) sv_2mortal(newSVpvs(STR))
3144 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3145         a = cophh_new_empty();
3146         check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
3147         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3148         check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
3149         check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
3150         a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
3151         a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
3152         a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
3153         a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
3154         check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
3155         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3156         check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
3157         check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
3158         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3159         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3160         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3161         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3162         b = cophh_copy(a);
3163         b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
3164         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
3165         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
3166         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3167         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3168         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3169         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3170         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3171         check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
3172         check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
3173         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3174         a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
3175         a = cophh_delete_pvs(a, "foo_2", 0);
3176         b = cophh_delete_pv(b, "foo_3", 0, 0);
3177         b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
3178         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3179         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3180         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3181         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3182         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3183         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3184         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3185         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3186         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3187         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3188         b = cophh_delete_pvs(b, "foo_3", 0);
3189         b = cophh_delete_pvs(b, "foo_5", 0);
3190         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
3191         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
3192         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
3193         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
3194         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
3195         cophh_free(b);
3196         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
3197         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
3198         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
3199         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
3200         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
3201         a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
3202         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
3203 #ifndef EBCDIC
3204         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
3205 #else
3206         /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the
3207          * equivalent UTF-EBCDIC for the code page.  This is done at runtime
3208          * (with the helper function in this file).  Therefore we can't use
3209          * cophhh_store_pvs(), as we don't have literal string */
3210         key_sv = sv_2mortal(newSVpvs("foo_"));
3211         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3212         key_name = SvPV(key_sv, key_len);
3213         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3214 #endif
3215 #ifndef EBCDIC
3216         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
3217 #else
3218         sv_setpvs(key_sv, "foo_");
3219         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3220         key_name = SvPV(key_sv, key_len);
3221         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3222 #endif
3223 #ifndef EBCDIC
3224         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
3225 #else
3226         sv_setpvs(key_sv, "foo_");
3227         cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3228         key_name = SvPV(key_sv, key_len);
3229         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3230 #endif
3231         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
3232         check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
3233         check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
3234 #ifndef EBCDIC
3235         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
3236         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
3237 #else
3238         sv_setpvs(key_sv, "foo_");
3239         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa"));
3240         key_name = SvPV(key_sv, key_len);
3241         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123);
3242         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3243 #endif
3244         check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
3245 #ifndef EBCDIC
3246         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
3247         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
3248 #else
3249         sv_setpvs(key_sv, "foo_");
3250         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3251         key_name = SvPV(key_sv, key_len);
3252         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456);
3253         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3254 #endif
3255         check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
3256 #ifndef EBCDIC
3257         check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
3258         check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
3259 #else
3260         sv_setpvs(key_sv, "foo_");
3261         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3262         key_name = SvPV(key_sv, key_len);
3263         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789);
3264         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3265 #endif
3266 #ifndef EBCDIC
3267         check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
3268         check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
3269 #else
3270         sv_setpvs(key_sv, "foo_");
3271         cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3272         key_name = SvPV(key_sv, key_len);
3273         check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666);
3274         check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0));
3275 #endif
3276         ENTER;
3277         SAVEFREECOPHH(a);
3278         LEAVE;
3279 #undef check_ph
3280 #undef check_iv
3281 #undef msvpvs
3282 #undef msviv
3283
3284 void
3285 test_coplabel()
3286     PREINIT:
3287         COP *cop;
3288         const char *label;
3289         STRLEN len;
3290         U32 utf8;
3291     CODE:
3292         cop = &PL_compiling;
3293         Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
3294         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3295         if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
3296         if (len != 3) croak("fail # cop_fetch_label len");
3297         if (utf8) croak("fail # cop_fetch_label utf8");
3298         /* SMALL GERMAN UMLAUT A */
3299         Perl_cop_store_label(aTHX_ cop, "fo\xc3\xa4", 4, SVf_UTF8);
3300         label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
3301         if (strcmp(label,"fo\xc3\xa4")) croak("fail # cop_fetch_label label");
3302         if (len != 4) croak("fail # cop_fetch_label len");
3303         if (!utf8) croak("fail # cop_fetch_label utf8");
3304
3305
3306 HV *
3307 example_cophh_2hv()
3308     PREINIT:
3309         COPHH *a;
3310 #ifdef EBCDIC
3311         SV* key_sv;
3312         char * key_name;
3313         STRLEN key_len;
3314 #endif
3315     CODE:
3316 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
3317         a = cophh_new_empty();
3318         a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
3319         a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
3320         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
3321 #ifndef EBCDIC
3322         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
3323 #else
3324         key_sv = sv_2mortal(newSVpvs("foo_"));
3325         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb"));
3326         key_name = SvPV(key_sv, key_len);
3327         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8);
3328 #endif
3329 #ifndef EBCDIC
3330         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
3331 #else
3332         sv_setpvs(key_sv, "foo_");
3333         cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c"));
3334         key_name = SvPV(key_sv, key_len);
3335         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8);
3336 #endif
3337 #ifndef EBCDIC
3338         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
3339 #else
3340         sv_setpvs(key_sv, "foo_");
3341         cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6"));
3342         key_name = SvPV(key_sv, key_len);
3343         a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8);
3344 #endif
3345         a = cophh_delete_pvs(a, "foo_0", 0);
3346         a = cophh_delete_pvs(a, "foo_2", 0);
3347         RETVAL = cophh_2hv(a, 0);
3348         cophh_free(a);
3349 #undef msviv
3350     OUTPUT:
3351         RETVAL
3352
3353 void
3354 test_savehints()
3355     PREINIT:
3356         SV **svp, *sv;
3357     CODE:
3358 #define store_hint(KEY, VALUE) \
3359                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
3360 #define hint_ok(KEY, EXPECT) \
3361                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
3362                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
3363                     (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
3364                     SvIV(sv) == (EXPECT))
3365 #define check_hint(KEY, EXPECT) \
3366                 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
3367         PL_hints |= HINT_LOCALIZE_HH;
3368         ENTER;
3369         SAVEHINTS();
3370         PL_hints &= HINT_INTEGER;
3371         store_hint("t0", 123);
3372         store_hint("t1", 456);
3373         if (PL_hints & HINT_INTEGER) croak_fail();
3374         check_hint("t0", 123); check_hint("t1", 456);
3375         ENTER;
3376         SAVEHINTS();
3377         if (PL_hints & HINT_INTEGER) croak_fail();
3378         check_hint("t0", 123); check_hint("t1", 456);
3379         PL_hints |= HINT_INTEGER;
3380         store_hint("t0", 321);
3381         if (!(PL_hints & HINT_INTEGER)) croak_fail();
3382         check_hint("t0", 321); check_hint("t1", 456);
3383         LEAVE;
3384         if (PL_hints & HINT_INTEGER) croak_fail();
3385         check_hint("t0", 123); check_hint("t1", 456);
3386         ENTER;
3387         SAVEHINTS();
3388         if (PL_hints & HINT_INTEGER) croak_fail();
3389         check_hint("t0", 123); check_hint("t1", 456);
3390         store_hint("t1", 654);
3391         if (PL_hints & HINT_INTEGER) croak_fail();
3392         check_hint("t0", 123); check_hint("t1", 654);
3393         LEAVE;
3394         if (PL_hints & HINT_INTEGER) croak_fail();
3395         check_hint("t0", 123); check_hint("t1", 456);
3396         LEAVE;
3397 #undef store_hint
3398 #undef hint_ok
3399 #undef check_hint
3400
3401 void
3402 test_copyhints()
3403     PREINIT:
3404         HV *a, *b;
3405     CODE:
3406         PL_hints |= HINT_LOCALIZE_HH;
3407         ENTER;
3408         SAVEHINTS();
3409         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
3410         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3411             croak_fail();
3412         a = newHVhv(GvHV(PL_hintgv));
3413         sv_2mortal((SV*)a);
3414         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
3415         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
3416             croak_fail();
3417         b = hv_copy_hints_hv(a);
3418         sv_2mortal((SV*)b);
3419         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
3420         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
3421             croak_fail();
3422         LEAVE;
3423
3424 void
3425 test_op_list()
3426     PREINIT:
3427         OP *a;
3428     CODE:
3429 #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
3430 #define check_op(o, expect) \
3431     do { \
3432         if (strcmp(test_op_list_describe(o), (expect))) \
3433             croak("fail %s %s", test_op_list_describe(o), (expect)); \
3434     } while(0)
3435         a = op_append_elem(OP_LIST, NULL, NULL);
3436         check_op(a, "");
3437         a = op_append_elem(OP_LIST, iv_op(1), a);
3438         check_op(a, "const(1).");
3439         a = op_append_elem(OP_LIST, NULL, a);
3440         check_op(a, "const(1).");
3441         a = op_append_elem(OP_LIST, a, iv_op(2));
3442         check_op(a, "list[pushmark.const(1).const(2).]");
3443         a = op_append_elem(OP_LIST, a, iv_op(3));
3444         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3445         a = op_append_elem(OP_LIST, a, NULL);
3446         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3447         a = op_append_elem(OP_LIST, NULL, a);
3448         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
3449         a = op_append_elem(OP_LIST, iv_op(4), a);
3450         check_op(a, "list[pushmark.const(4)."
3451                 "list[pushmark.const(1).const(2).const(3).]]");
3452         a = op_append_elem(OP_LIST, a, iv_op(5));
3453         check_op(a, "list[pushmark.const(4)."
3454                 "list[pushmark.const(1).const(2).const(3).]const(5).]");
3455         a = op_append_elem(OP_LIST, a,
3456                 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
3457         check_op(a, "list[pushmark.const(4)."
3458                 "list[pushmark.const(1).const(2).const(3).]const(5)."
3459                 "list[pushmark.const(7).const(6).]]");
3460         op_free(a);
3461         a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
3462         check_op(a, "lineseq[const(1).const(2).]");
3463         a = op_append_elem(OP_LINESEQ, a, iv_op(3));
3464         check_op(a, "lineseq[const(1).const(2).const(3).]");
3465         op_free(a);
3466         a = op_append_elem(OP_LINESEQ,
3467                 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
3468                 iv_op(3));
3469         check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
3470         op_free(a);
3471         a = op_prepend_elem(OP_LIST, NULL, NULL);
3472         check_op(a, "");
3473         a = op_prepend_elem(OP_LIST, a, iv_op(1));
3474         check_op(a, "const(1).");
3475         a = op_prepend_elem(OP_LIST, a, NULL);
3476         check_op(a, "const(1).");
3477         a = op_prepend_elem(OP_LIST, iv_op(2), a);
3478         check_op(a, "list[pushmark.const(2).const(1).]");
3479         a = op_prepend_elem(OP_LIST, iv_op(3), a);
3480         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3481         a = op_prepend_elem(OP_LIST, NULL, a);
3482         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3483         a = op_prepend_elem(OP_LIST, a, NULL);
3484         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
3485         a = op_prepend_elem(OP_LIST, a, iv_op(4));
3486         check_op(a, "list[pushmark."
3487                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3488         a = op_prepend_elem(OP_LIST, iv_op(5), a);
3489         check_op(a, "list[pushmark.const(5)."
3490                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3491         a = op_prepend_elem(OP_LIST,
3492                 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
3493         check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
3494                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
3495         op_free(a);
3496         a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
3497         check_op(a, "lineseq[const(2).const(1).]");
3498         a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
3499         check_op(a, "lineseq[const(3).const(2).const(1).]");
3500         op_free(a);
3501         a = op_prepend_elem(OP_LINESEQ, iv_op(3),
3502                 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
3503         check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
3504         op_free(a);
3505         a = op_append_list(OP_LINESEQ, NULL, NULL);
3506         check_op(a, "");
3507         a = op_append_list(OP_LINESEQ, iv_op(1), a);
3508         check_op(a, "const(1).");
3509         a = op_append_list(OP_LINESEQ, NULL, a);
3510         check_op(a, "const(1).");
3511         a = op_append_list(OP_LINESEQ, a, iv_op(2));
3512         check_op(a, "lineseq[const(1).const(2).]");
3513         a = op_append_list(OP_LINESEQ, a, iv_op(3));
3514         check_op(a, "lineseq[const(1).const(2).const(3).]");
3515         a = op_append_list(OP_LINESEQ, iv_op(4), a);
3516         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3517         a = op_append_list(OP_LINESEQ, a, NULL);
3518         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3519         a = op_append_list(OP_LINESEQ, NULL, a);
3520         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
3521         a = op_append_list(OP_LINESEQ, a,
3522                 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
3523         check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
3524                 "const(5).const(6).]");
3525         op_free(a);
3526         a = op_append_list(OP_LINESEQ,
3527                 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
3528                 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
3529         check_op(a, "lineseq[const(1).const(2)."
3530                 "list[pushmark.const(3).const(4).]]");
3531         op_free(a);
3532         a = op_append_list(OP_LINESEQ,
3533                 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
3534                 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
3535         check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
3536                 "const(3).const(4).]");
3537         op_free(a);
3538 #undef check_op
3539
3540 void
3541 test_op_linklist ()
3542     PREINIT:
3543         OP *o;
3544     CODE:
3545 #define check_ll(o, expect) \
3546     STMT_START { \
3547         if (strNE(test_op_linklist_describe(o), (expect))) \
3548             croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
3549     } STMT_END
3550         o = iv_op(1);
3551         check_ll(o, ".const1");
3552         op_free(o);
3553
3554         o = mkUNOP(OP_NOT, iv_op(1));
3555         check_ll(o, ".const1.not");
3556         op_free(o);
3557
3558         o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
3559         check_ll(o, ".const1.negate.not");
3560         op_free(o);
3561
3562         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3563         check_ll(o, ".const1.const2.add");
3564         op_free(o);
3565
3566         o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
3567         check_ll(o, ".const1.not.const2.add");
3568         op_free(o);
3569
3570         o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
3571         check_ll(o, ".const1.const2.add.not");
3572         op_free(o);
3573
3574         o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
3575         check_ll(o, ".const1.const2.const3.lineseq");
3576         op_free(o);
3577
3578         o = mkLISTOP(OP_LINESEQ,
3579                 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
3580                 mkUNOP(OP_NOT, iv_op(3)),
3581                 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
3582         check_ll(o, ".const1.const2.add.const3.not"
3583                     ".const4.const5.const6.substr.lineseq");
3584         op_free(o);
3585
3586         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
3587         LINKLIST(o);
3588         o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
3589         check_ll(o, ".const1.const2.add.const3.subtract");
3590         op_free(o);
3591 #undef check_ll
3592 #undef iv_op
3593
3594 void
3595 peep_enable ()
3596     PREINIT:
3597         dMY_CXT;
3598     CODE:
3599         av_clear(MY_CXT.peep_recorder);
3600         av_clear(MY_CXT.rpeep_recorder);
3601         MY_CXT.peep_recording = 1;
3602
3603 void
3604 peep_disable ()
3605     PREINIT:
3606         dMY_CXT;
3607     CODE:
3608         MY_CXT.peep_recording = 0;
3609
3610 SV *
3611 peep_record ()
3612     PREINIT:
3613         dMY_CXT;
3614     CODE:
3615         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
3616     OUTPUT:
3617         RETVAL
3618
3619 SV *
3620 rpeep_record ()
3621     PREINIT:
3622         dMY_CXT;
3623     CODE:
3624         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
3625     OUTPUT:
3626         RETVAL
3627
3628 =pod
3629
3630 multicall_each: call a sub for each item in the list. Used to test MULTICALL
3631
3632 =cut
3633
3634 void
3635 multicall_each(block,...)
3636     SV * block
3637 PROTOTYPE: &@
3638 CODE:
3639 {
3640     dMULTICALL;
3641     int index;
3642     GV *gv;
3643     HV *stash;
3644     I32 gimme = G_SCALAR;
3645     SV **args = &PL_stack_base[ax];
3646     CV *cv;
3647
3648     if(items <= 1) {
3649         XSRETURN_UNDEF;
3650     }
3651     cv = sv_2cv(block, &stash, &gv, 0);
3652     if (cv == Nullcv) {
3653        croak("multicall_each: not a subroutine reference");
3654     }
3655     PUSH_MULTICALL(cv);
3656     SAVESPTR(GvSV(PL_defgv));
3657
3658     for(index = 1 ; index < items ; index++) {
3659         GvSV(PL_defgv) = args[index];
3660         MULTICALL;
3661     }
3662     POP_MULTICALL;
3663     XSRETURN_UNDEF;
3664 }
3665
3666 =pod
3667
3668 multicall_return(): call the passed sub once in the specificed context
3669 and return whatever it returns
3670
3671 =cut
3672
3673 void
3674 multicall_return(block, context)
3675     SV *block
3676     I32 context
3677 PROTOTYPE: &$
3678 CODE:
3679 {
3680     dSP;
3681     dMULTICALL;
3682     GV *gv;
3683     HV *stash;
3684     I32 gimme = context;
3685     CV *cv;
3686     AV *av;
3687     SV **p;
3688     SSize_t i, size;
3689
3690     cv = sv_2cv(block, &stash, &gv, 0);
3691     if (cv == Nullcv) {
3692        croak("multicall_return not a subroutine reference");
3693     }
3694     PUSH_MULTICALL(cv);
3695
3696     MULTICALL;
3697
3698     /* copy returned values into an array so they're not freed during
3699      * POP_MULTICALL */
3700
3701     av = newAV();
3702     SPAGAIN;
3703
3704     switch (context) {
3705     case G_VOID:
3706         break;
3707
3708     case G_SCALAR:
3709         av_push(av, SvREFCNT_inc(TOPs));
3710         break;
3711
3712     case G_ARRAY:
3713         for (p = PL_stack_base + 1; p <= SP; p++)
3714             av_push(av, SvREFCNT_inc(*p));
3715         break;
3716     }
3717
3718     POP_MULTICALL;
3719
3720     size = AvFILLp(av) + 1;
3721     EXTEND(SP, size);
3722     for (i = 0; i < size; i++)
3723         ST(i) = *av_fetch(av, i, FALSE);
3724     sv_2mortal((SV*)av);
3725     XSRETURN(size);
3726 }
3727
3728
3729 #ifdef USE_ITHREADS
3730
3731 void
3732 clone_with_stack()
3733 CODE:
3734 {
3735     PerlInterpreter *interp = aTHX; /* The original interpreter */
3736     PerlInterpreter *interp_dup;    /* The duplicate interpreter */
3737     int oldscope = 1; /* We are responsible for all scopes */
3738
3739     interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
3740
3741     /* destroy old perl */
3742     PERL_SET_CONTEXT(interp);
3743
3744     POPSTACK_TO(PL_mainstack);
3745     if (cxstack_ix >= 0) {
3746         dounwind(-1);
3747         cx_popblock(cxstack);
3748     }
3749     LEAVE_SCOPE(0);
3750     PL_scopestack_ix = oldscope;
3751     FREETMPS;
3752
3753     perl_destruct(interp);
3754     perl_free(interp);
3755
3756     /* switch to new perl */
3757     PERL_SET_CONTEXT(interp_dup);
3758
3759     /* continue after 'clone_with_stack' */
3760     if (interp_dup->Iop)
3761         interp_dup->Iop = interp_dup->Iop->op_next;
3762
3763     /* run with new perl */
3764     Perl_runops_standard(interp_dup);
3765
3766     /* We may have additional unclosed scopes if fork() was called
3767      * from within a BEGIN block.  See perlfork.pod for more details.
3768      * We cannot clean up these other scopes because they belong to a
3769      * different interpreter, but we also cannot leave PL_scopestack_ix
3770      * dangling because that can trigger an assertion in perl_destruct().
3771      */
3772     if (PL_scopestack_ix > oldscope) {
3773         PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
3774         PL_scopestack_ix = oldscope;
3775     }
3776
3777     perl_destruct(interp_dup);
3778     perl_free(interp_dup);
3779
3780     /* call the real 'exit' not PerlProc_exit */
3781 #undef exit
3782     exit(0);
3783 }
3784
3785 #endif /* USE_ITHREDS */
3786
3787 SV*
3788 take_svref(SVREF sv)
3789 CODE:
3790     RETVAL = newRV_inc(sv);
3791 OUTPUT:
3792     RETVAL
3793
3794 SV*
3795 take_avref(AV* av)
3796 CODE:
3797     RETVAL = newRV_inc((SV*)av);
3798 OUTPUT:
3799     RETVAL
3800
3801 SV*
3802 take_hvref(HV* hv)
3803 CODE:
3804     RETVAL = newRV_inc((SV*)hv);
3805 OUTPUT:
3806     RETVAL
3807
3808
3809 SV*
3810 take_cvref(CV* cv)
3811 CODE:
3812     RETVAL = newRV_inc((SV*)cv);
3813 OUTPUT:
3814     RETVAL
3815
3816
3817 BOOT:
3818         {
3819         HV* stash;
3820         SV** meth = NULL;
3821         CV* cv;
3822         stash = gv_stashpv("XS::APItest::TempLv", 0);
3823         if (stash)
3824             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
3825         if (!meth)
3826             croak("lost method 'make_temp_mg_lv'");
3827         cv = GvCV(*meth);
3828         CvLVALUE_on(cv);
3829         }
3830
3831 BOOT:
3832 {
3833     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
3834     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
3835     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
3836     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
3837     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
3838     hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
3839     hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
3840     hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
3841     hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
3842     hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
3843     hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
3844     hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
3845     hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
3846     hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
3847     hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
3848     hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
3849     hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
3850     hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
3851     hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
3852     hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
3853     next_keyword_plugin = PL_keyword_plugin;
3854     PL_keyword_plugin = my_keyword_plugin;
3855 }
3856
3857 void
3858 establish_cleanup(...)
3859 PROTOTYPE: $
3860 CODE:
3861     PERL_UNUSED_VAR(items);
3862     croak("establish_cleanup called as a function");
3863
3864 BOOT:
3865 {
3866     CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
3867     cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
3868 }
3869
3870 void
3871 postinc(...)
3872 PROTOTYPE: $
3873 CODE:
3874     PERL_UNUSED_VAR(items);
3875     croak("postinc called as a function");
3876
3877 void
3878 filter()
3879 CODE:
3880     filter_add(filter_call, NULL);
3881
3882 BOOT:
3883 {
3884     CV *asscv = get_cv("XS::APItest::postinc", 0);
3885     cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
3886 }
3887
3888 SV *
3889 lv_temp_object()
3890 CODE:
3891     RETVAL =
3892           sv_bless(
3893             newRV_noinc(newSV(0)),
3894             gv_stashpvs("XS::APItest::TempObj",GV_ADD)
3895           );             /* Package defined in test script */
3896 OUTPUT:
3897     RETVAL
3898
3899 void
3900 fill_hash_with_nulls(HV *hv)
3901 PREINIT:
3902     UV i = 0;
3903 CODE:
3904     for(; i < 1000; ++i) {
3905         HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
3906         SvREFCNT_dec(HeVAL(entry));
3907         HeVAL(entry) = NULL;
3908     }
3909
3910 HV *
3911 newHVhv(HV *hv)
3912 CODE:
3913     RETVAL = newHVhv(hv);
3914 OUTPUT:
3915     RETVAL
3916
3917 U32
3918 SvIsCOW(SV *sv)
3919 CODE:
3920     RETVAL = SvIsCOW(sv);
3921 OUTPUT:
3922     RETVAL
3923
3924 void
3925 pad_scalar(...)
3926 PROTOTYPE: $$
3927 CODE:
3928     PERL_UNUSED_VAR(items);
3929     croak("pad_scalar called as a function");
3930
3931 BOOT:
3932 {
3933     CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
3934     cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
3935 }
3936
3937 SV*
3938 fetch_pad_names( cv )
3939 CV* cv
3940  PREINIT:
3941   I32 i;
3942   PADNAMELIST *pad_namelist;
3943   AV *retav = newAV();
3944  CODE:
3945   pad_namelist = PadlistNAMES(CvPADLIST(cv));
3946
3947   for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
3948     PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
3949
3950     if (PadnameLEN(name)) {
3951         av_push(retav, newSVpadname(name));
3952     }
3953   }
3954   RETVAL = newRV_noinc((SV*)retav);
3955  OUTPUT:
3956   RETVAL
3957
3958 STRLEN
3959 underscore_length()
3960 PROTOTYPE:
3961 PREINIT:
3962     SV *u;
3963     U8 *pv;
3964     STRLEN bytelen;
3965 CODE:
3966     u = find_rundefsv();
3967     pv = (U8*)SvPV(u, bytelen);
3968     RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
3969 OUTPUT:
3970     RETVAL
3971
3972 void
3973 stringify(SV *sv)
3974 CODE:
3975     (void)SvPV_nolen(sv);
3976
3977 SV *
3978 HvENAME(HV *hv)
3979 CODE:
3980     RETVAL = hv && HvENAME(hv)
3981               ? newSVpvn_flags(
3982                   HvENAME(hv),HvENAMELEN(hv),
3983                   (HvENAMEUTF8(hv) ? SVf_UTF8 : 0)
3984                 )
3985               : NULL;
3986 OUTPUT:
3987     RETVAL
3988
3989 int
3990 xs_cmp(int a, int b)
3991 CODE:
3992     /* Odd sorting (odd numbers first), to make sure we are actually
3993        being called */
3994     RETVAL = a % 2 != b % 2
3995                ? a % 2 ? -1 : 1
3996                : a < b ? -1 : a == b ? 0 : 1;
3997 OUTPUT:
3998     RETVAL
3999
4000 SV *
4001 xs_cmp_undef(SV *a, SV *b)
4002 CODE:
4003     PERL_UNUSED_ARG(a);
4004     PERL_UNUSED_ARG(b);
4005     RETVAL = &PL_sv_undef;
4006 OUTPUT:
4007     RETVAL
4008
4009 char *
4010 SvPVbyte(SV *sv)
4011 CODE:
4012     RETVAL = SvPVbyte_nolen(sv);
4013 OUTPUT:
4014     RETVAL
4015
4016 char *
4017 SvPVutf8(SV *sv)
4018 CODE:
4019     RETVAL = SvPVutf8_nolen(sv);
4020 OUTPUT:
4021     RETVAL
4022
4023 void
4024 setup_addissub()
4025 CODE:
4026     wrap_op_checker(OP_ADD, addissub_myck_add, &addissub_nxck_add);
4027
4028 void
4029 setup_rv2cv_addunderbar()
4030 CODE:
4031     wrap_op_checker(OP_RV2CV, my_ck_rv2cv, &old_ck_rv2cv);
4032
4033 #ifdef USE_ITHREADS
4034
4035 bool
4036 test_alloccopstash()
4037 CODE:
4038     RETVAL = PL_stashpad[alloccopstash(PL_defstash)] == PL_defstash;
4039 OUTPUT:
4040     RETVAL
4041
4042 #endif
4043
4044 bool
4045 test_newFOROP_without_slab()
4046 CODE:
4047     {
4048         const I32 floor = start_subparse(0,0);
4049         OP *o;
4050         /* The slab allocator does not like CvROOT being set. */
4051         CvROOT(PL_compcv) = (OP *)1;
4052         o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0);
4053 #ifdef PERL_OP_PARENT
4054         if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent
4055                 != cUNOPo->op_first)
4056         {
4057             Perl_warn(aTHX_ "Op parent pointer is stale");
4058             RETVAL = FALSE;
4059         }
4060         else
4061 #endif
4062             /* If we do not crash before returning, the test passes. */
4063             RETVAL = TRUE;
4064         op_free(o);
4065         CvROOT(PL_compcv) = NULL;
4066         SvREFCNT_dec(PL_compcv);
4067         LEAVE_SCOPE(floor);
4068     }
4069 OUTPUT:
4070     RETVAL
4071
4072  # provide access to CALLREGEXEC, except replace pointers within the
4073  # string with offsets from the start of the string
4074
4075 I32
4076 callregexec(SV *prog, STRLEN stringarg, STRLEN strend, I32 minend, SV *sv, U32 nosave)
4077 CODE:
4078     {
4079         STRLEN len;
4080         char *strbeg;
4081         if (SvROK(prog))
4082             prog = SvRV(prog);
4083         strbeg = SvPV_force(sv, len);
4084         RETVAL = CALLREGEXEC((REGEXP *)prog,
4085                             strbeg + stringarg,
4086                             strbeg + strend,
4087                             strbeg,
4088                             minend,
4089                             sv,
4090                             NULL, /* data */
4091                             nosave);
4092     }
4093 OUTPUT:
4094     RETVAL
4095
4096 void
4097 lexical_import(SV *name, CV *cv)
4098     CODE:
4099     {
4100         PADLIST *pl;
4101         PADOFFSET off;
4102         if (!PL_compcv)
4103             Perl_croak(aTHX_
4104                       "lexical_import can only be called at compile time");
4105         pl = CvPADLIST(PL_compcv);
4106         ENTER;
4107         SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl);
4108         SAVESPTR(PL_comppad);      PL_comppad      = PadlistARRAY(pl)[1];
4109         SAVESPTR(PL_curpad);       PL_curpad       = PadARRAY(PL_comppad);
4110         off = pad_add_name_sv(sv_2mortal(newSVpvf("&%"SVf,name)),
4111                               padadd_STATE, 0, 0);
4112         SvREFCNT_dec(PL_curpad[off]);
4113         PL_curpad[off] = SvREFCNT_inc(cv);
4114         intro_my();
4115         LEAVE;
4116     }
4117
4118 SV *
4119 sv_mortalcopy(SV *sv)
4120     CODE:
4121         RETVAL = SvREFCNT_inc(sv_mortalcopy(sv));
4122     OUTPUT:
4123         RETVAL
4124
4125 SV *
4126 newRV(SV *sv)
4127
4128 void
4129 alias_av(AV *av, IV ix, SV *sv)
4130     CODE:
4131         av_store(av, ix, SvREFCNT_inc(sv));
4132
4133 SV *
4134 cv_name(SVREF ref, ...)
4135     CODE:
4136         RETVAL = SvREFCNT_inc(cv_name((CV *)ref,
4137                                       items>1 && ST(1) != &PL_sv_undef
4138                                         ? ST(1)
4139                                         : NULL,
4140                                       items>2 ? SvUV(ST(2)) : 0));
4141     OUTPUT:
4142         RETVAL
4143
4144 void
4145 sv_catpvn(SV *sv, SV *sv2)
4146     CODE:
4147     {
4148         STRLEN len;
4149         const char *s = SvPV(sv2,len);
4150         sv_catpvn_flags(sv,s,len, SvUTF8(sv2) ? SV_CATUTF8 : SV_CATBYTES);
4151     }
4152
4153 bool
4154 test_newOP_CUSTOM()
4155     CODE:
4156     {
4157         OP *o = newLISTOP(OP_CUSTOM, 0, NULL, NULL);
4158         op_free(o);
4159         o = newOP(OP_CUSTOM, 0);
4160         op_free(o);
4161         o = newUNOP(OP_CUSTOM, 0, NULL);
4162         op_free(o);
4163         o = newUNOP_AUX(OP_CUSTOM, 0, NULL, NULL);
4164         op_free(o);
4165         o = newMETHOP(OP_CUSTOM, 0, newOP(OP_NULL,0));
4166         op_free(o);
4167         o = newMETHOP_named(OP_CUSTOM, 0, newSV(0));
4168         op_free(o);
4169         o = newBINOP(OP_CUSTOM, 0, NULL, NULL);
4170         op_free(o);
4171         o = newPMOP(OP_CUSTOM, 0);
4172         op_free(o);
4173         o = newSVOP(OP_CUSTOM, 0, newSV(0));
4174         op_free(o);
4175 #ifdef USE_ITHREADS
4176         ENTER;
4177         lex_start(NULL, NULL, 0);
4178         {
4179             I32 ix = start_subparse(FALSE,0);
4180             o = newPADOP(OP_CUSTOM, 0, newSV(0));
4181             op_free(o);
4182             LEAVE_SCOPE(ix);
4183         }
4184         LEAVE;
4185 #endif
4186         o = newPVOP(OP_CUSTOM, 0, NULL);
4187         op_free(o);
4188         o = newLOGOP(OP_CUSTOM, 0, newOP(OP_NULL,0), newOP(OP_NULL,0));
4189         op_free(o);
4190         o = newLOOPEX(OP_CUSTOM, newOP(OP_NULL,0));
4191         op_free(o);
4192         RETVAL = TRUE;
4193     }
4194     OUTPUT:
4195         RETVAL
4196
4197 void
4198 test_sv_catpvf(SV *fmtsv)
4199     PREINIT:
4200         SV *sv;
4201         char *fmt;
4202     CODE:
4203         fmt = SvPV_nolen(fmtsv);
4204         sv = sv_2mortal(newSVpvn("", 0));
4205         sv_catpvf(sv, fmt, 5, 6, 7, 8);
4206
4207 void
4208 load_module(flags, name, ...)
4209     U32 flags
4210     SV *name
4211 CODE:
4212     if (items == 2) {
4213         Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL);
4214     } else if (items == 3) {
4215         Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2)));
4216     } else
4217         Perl_croak(aTHX_ "load_module can't yet support %"IVdf" items", (IV)items);
4218
4219 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
4220
4221 int
4222 AUTOLOAD(...)
4223   INIT:
4224     SV* comms;
4225     SV* class_and_method;
4226   CODE:
4227     PERL_UNUSED_ARG(items);
4228     class_and_method = GvSV(CvGV(cv));
4229     comms = get_sv("main::the_method", 1);
4230     if (class_and_method == NULL) {
4231       RETVAL = 1;
4232     } else if (!SvOK(class_and_method)) {
4233       RETVAL = 2;
4234     } else if (!SvPOK(class_and_method)) {
4235       RETVAL = 3;
4236     } else {
4237       sv_setsv(comms, class_and_method);
4238       RETVAL = 0;
4239     }
4240   OUTPUT: RETVAL
4241
4242
4243 MODULE = XS::APItest            PACKAGE = XS::APItest::Magic
4244
4245 PROTOTYPES: DISABLE
4246
4247 void
4248 sv_magic_foo(SV *sv, SV *thingy)
4249 ALIAS:
4250     sv_magic_bar = 1
4251 CODE:
4252     sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
4253
4254 SV *
4255 mg_find_foo(SV *sv)
4256 ALIAS:
4257     mg_find_bar = 1
4258 CODE:
4259     MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
4260     RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef;
4261 OUTPUT:
4262     RETVAL
4263
4264 void
4265 sv_unmagic_foo(SV *sv)
4266 ALIAS:
4267     sv_unmagic_bar = 1
4268 CODE:
4269     sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
4270
4271 void
4272 sv_magic(SV *sv, SV *thingy)
4273 CODE:
4274     sv_magic(SvRV(sv), NULL, PERL_MAGIC_ext, (const char *)thingy, 0);
4275
4276 UV
4277 test_get_vtbl()
4278     PREINIT:
4279         MGVTBL *have;
4280         MGVTBL *want;
4281     CODE:
4282 #define test_get_this_vtable(name) \
4283         want = (MGVTBL*)CAT2(&PL_vtbl_, name); \
4284         have = get_vtbl(CAT2(want_vtbl_, name)); \
4285         if (have != want) \
4286             croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
4287
4288         test_get_this_vtable(sv);
4289         test_get_this_vtable(env);
4290         test_get_this_vtable(envelem);
4291         test_get_this_vtable(sigelem);
4292         test_get_this_vtable(pack);
4293         test_get_this_vtable(packelem);
4294         test_get_this_vtable(dbline);
4295         test_get_this_vtable(isa);
4296         test_get_this_vtable(isaelem);
4297         test_get_this_vtable(arylen);
4298         test_get_this_vtable(mglob);
4299         test_get_this_vtable(nkeys);
4300         test_get_this_vtable(taint);
4301         test_get_this_vtable(substr);
4302         test_get_this_vtable(vec);
4303         test_get_this_vtable(pos);
4304         test_get_this_vtable(bm);
4305         test_get_this_vtable(fm);
4306         test_get_this_vtable(uvar);
4307         test_get_this_vtable(defelem);
4308         test_get_this_vtable(regexp);
4309         test_get_this_vtable(regdata);
4310         test_get_this_vtable(regdatum);
4311 #ifdef USE_LOCALE_COLLATE
4312         test_get_this_vtable(collxfrm);
4313 #endif
4314         test_get_this_vtable(backref);
4315         test_get_this_vtable(utf8);
4316
4317         RETVAL = PTR2UV(get_vtbl(-1));
4318     OUTPUT:
4319         RETVAL
4320
4321 bool
4322 test_isBLANK_uni(UV ord)
4323     CODE:
4324         RETVAL = isBLANK_uni(ord);
4325     OUTPUT:
4326         RETVAL
4327
4328 bool
4329 test_isBLANK_LC_uvchr(UV ord)
4330     CODE:
4331         RETVAL = isBLANK_LC_uvchr(ord);
4332     OUTPUT:
4333         RETVAL
4334
4335 bool
4336 test_isBLANK_A(UV ord)
4337     CODE:
4338         RETVAL = isBLANK_A(ord);
4339     OUTPUT:
4340         RETVAL
4341
4342 bool
4343 test_isBLANK_L1(UV ord)
4344     CODE:
4345         RETVAL = isBLANK_L1(ord);
4346     OUTPUT:
4347         RETVAL
4348
4349 bool
4350 test_isBLANK_LC(UV ord)
4351     CODE:
4352         RETVAL = isBLANK_LC(ord);
4353     OUTPUT:
4354         RETVAL
4355
4356 bool
4357 test_isBLANK_utf8(unsigned char * p)
4358     CODE:
4359         RETVAL = isBLANK_utf8(p);
4360     OUTPUT:
4361         RETVAL
4362
4363 bool
4364 test_isBLANK_LC_utf8(unsigned char * p)
4365     CODE:
4366         RETVAL = isBLANK_LC_utf8(p);
4367     OUTPUT:
4368         RETVAL
4369
4370 bool
4371 test_isVERTWS_uni(UV ord)
4372     CODE:
4373         RETVAL = isVERTWS_uni(ord);
4374     OUTPUT:
4375         RETVAL
4376
4377 bool
4378 test_isVERTWS_utf8(unsigned char * p)
4379     CODE:
4380         RETVAL = isVERTWS_utf8(p);
4381     OUTPUT:
4382         RETVAL
4383
4384 bool
4385 test_isUPPER_uni(UV ord)
4386     CODE:
4387         RETVAL = isUPPER_uni(ord);
4388     OUTPUT:
4389         RETVAL
4390
4391 bool
4392 test_isUPPER_LC_uvchr(UV ord)
4393     CODE:
4394         RETVAL = isUPPER_LC_uvchr(ord);
4395     OUTPUT:
4396         RETVAL
4397
4398 bool
4399 test_isUPPER_A(UV ord)
4400     CODE:
4401         RETVAL = isUPPER_A(ord);
4402     OUTPUT:
4403         RETVAL
4404
4405 bool
4406 test_isUPPER_L1(UV ord)
4407     CODE:
4408         RETVAL = isUPPER_L1(ord);
4409     OUTPUT:
4410         RETVAL
4411
4412 bool
4413 test_isUPPER_LC(UV ord)
4414     CODE:
4415         RETVAL = isUPPER_LC(ord);
4416     OUTPUT:
4417         RETVAL
4418
4419 bool
4420 test_isUPPER_utf8(unsigned char * p)
4421     CODE:
4422         RETVAL = isUPPER_utf8( p);
4423     OUTPUT:
4424         RETVAL
4425
4426 bool
4427 test_isUPPER_LC_utf8(unsigned char * p)
4428     CODE:
4429         RETVAL = isUPPER_LC_utf8( p);
4430     OUTPUT:
4431         RETVAL
4432
4433 bool
4434 test_isLOWER_uni(UV ord)
4435     CODE:
4436         RETVAL = isLOWER_uni(ord);
4437     OUTPUT:
4438         RETVAL
4439
4440 bool
4441 test_isLOWER_LC_uvchr(UV ord)
4442     CODE:
4443         RETVAL = isLOWER_LC_uvchr(ord);
4444     OUTPUT:
4445         RETVAL
4446
4447 bool
4448 test_isLOWER_A(UV ord)
4449     CODE:
4450         RETVAL = isLOWER_A(ord);
4451     OUTPUT:
4452         RETVAL
4453
4454 bool
4455 test_isLOWER_L1(UV ord)
4456     CODE:
4457         RETVAL = isLOWER_L1(ord);
4458     OUTPUT:
4459         RETVAL
4460
4461 bool
4462 test_isLOWER_LC(UV ord)
4463     CODE:
4464         RETVAL = isLOWER_LC(ord);
4465     OUTPUT:
4466         RETVAL
4467
4468 bool
4469 test_isLOWER_utf8(unsigned char * p)
4470     CODE:
4471         RETVAL = isLOWER_utf8( p);
4472     OUTPUT:
4473         RETVAL
4474
4475 bool
4476 test_isLOWER_LC_utf8(unsigned char * p)
4477     CODE:
4478         RETVAL = isLOWER_LC_utf8( p);
4479     OUTPUT:
4480         RETVAL
4481
4482 bool
4483 test_isALPHA_uni(UV ord)
4484     CODE:
4485         RETVAL = isALPHA_uni(ord);
4486     OUTPUT:
4487         RETVAL
4488
4489 bool
4490 test_isALPHA_LC_uvchr(UV ord)
4491     CODE:
4492         RETVAL = isALPHA_LC_uvchr(ord);
4493     OUTPUT:
4494         RETVAL
4495
4496 bool
4497 test_isALPHA_A(UV ord)
4498     CODE:
4499         RETVAL = isALPHA_A(ord);
4500     OUTPUT:
4501         RETVAL
4502
4503 bool
4504 test_isALPHA_L1(UV ord)
4505     CODE:
4506         RETVAL = isALPHA_L1(ord);
4507     OUTPUT:
4508         RETVAL
4509
4510 bool
4511 test_isALPHA_LC(UV ord)
4512     CODE:
4513         RETVAL = isALPHA_LC(ord);
4514     OUTPUT:
4515         RETVAL
4516
4517 bool
4518 test_isALPHA_utf8(unsigned char * p)
4519     CODE:
4520         RETVAL = isALPHA_utf8( p);
4521     OUTPUT:
4522         RETVAL
4523
4524 bool
4525 test_isALPHA_LC_utf8(unsigned char * p)
4526     CODE:
4527         RETVAL = isALPHA_LC_utf8( p);
4528     OUTPUT:
4529         RETVAL
4530
4531 bool
4532 test_isWORDCHAR_uni(UV ord)
4533     CODE:
4534         RETVAL = isWORDCHAR_uni(ord);
4535     OUTPUT:
4536         RETVAL
4537
4538 bool
4539 test_isWORDCHAR_LC_uvchr(UV ord)
4540     CODE:
4541         RETVAL = isWORDCHAR_LC_uvchr(ord);
4542     OUTPUT:
4543         RETVAL
4544
4545 bool
4546 test_isWORDCHAR_A(UV ord)
4547     CODE:
4548         RETVAL = isWORDCHAR_A(ord);
4549     OUTPUT:
4550         RETVAL
4551
4552 bool
4553 test_isWORDCHAR_L1(UV ord)
4554     CODE:
4555         RETVAL = isWORDCHAR_L1(ord);
4556     OUTPUT:
4557         RETVAL
4558
4559 bool
4560 test_isWORDCHAR_LC(UV ord)
4561     CODE:
4562         RETVAL = isWORDCHAR_LC(ord);
4563     OUTPUT:
4564         RETVAL
4565
4566 bool
4567 test_isWORDCHAR_utf8(unsigned char * p)
4568     CODE:
4569         RETVAL = isWORDCHAR_utf8( p);
4570     OUTPUT:
4571         RETVAL
4572
4573 bool
4574 test_isWORDCHAR_LC_utf8(unsigned char * p)
4575     CODE:
4576         RETVAL = isWORDCHAR_LC_utf8( p);
4577     OUTPUT:
4578         RETVAL
4579
4580 bool
4581 test_isALPHANUMERIC_uni(UV ord)
4582     CODE:
4583         RETVAL = isALPHANUMERIC_uni(ord);
4584     OUTPUT:
4585         RETVAL
4586
4587 bool
4588 test_isALPHANUMERIC_LC_uvchr(UV ord)
4589     CODE:
4590         RETVAL = isALPHANUMERIC_LC_uvchr(ord);
4591     OUTPUT:
4592         RETVAL
4593
4594 bool
4595 test_isALPHANUMERIC_A(UV ord)
4596     CODE:
4597         RETVAL = isALPHANUMERIC_A(ord);
4598     OUTPUT:
4599         RETVAL
4600
4601 bool
4602 test_isALPHANUMERIC_L1(UV ord)
4603     CODE:
4604         RETVAL = isALPHANUMERIC_L1(ord);
4605     OUTPUT:
4606         RETVAL
4607
4608 bool
4609 test_isALPHANUMERIC_LC(UV ord)
4610     CODE:
4611         RETVAL = isALPHANUMERIC_LC(ord);
4612     OUTPUT:
4613         RETVAL
4614
4615 bool
4616 test_isALPHANUMERIC_utf8(unsigned char * p)
4617     CODE:
4618         RETVAL = isALPHANUMERIC_utf8( p);
4619     OUTPUT:
4620         RETVAL
4621
4622 bool
4623 test_isALPHANUMERIC_LC_utf8(unsigned char * p)
4624     CODE:
4625         RETVAL = isALPHANUMERIC_LC_utf8( p);
4626     OUTPUT:
4627         RETVAL
4628
4629 bool
4630 test_isALNUM_uni(UV ord)
4631     CODE:
4632         RETVAL = isALNUM_uni(ord);
4633     OUTPUT:
4634         RETVAL
4635
4636 bool
4637 test_isALNUM_LC_uvchr(UV ord)
4638     CODE:
4639         RETVAL = isALNUM_LC_uvchr(ord);
4640     OUTPUT:
4641         RETVAL
4642
4643 bool
4644 test_isALNUM_LC(UV ord)
4645     CODE:
4646         RETVAL = isALNUM_LC(ord);
4647     OUTPUT:
4648         RETVAL
4649
4650 bool
4651 test_isALNUM_utf8(unsigned char * p)
4652     CODE:
4653         RETVAL = isALNUM_utf8( p);
4654     OUTPUT:
4655         RETVAL
4656
4657 bool
4658 test_isALNUM_LC_utf8(unsigned char * p)
4659     CODE:
4660         RETVAL = isALNUM_LC_utf8( p);
4661     OUTPUT:
4662         RETVAL
4663
4664 bool
4665 test_isDIGIT_uni(UV ord)
4666     CODE:
4667         RETVAL = isDIGIT_uni(ord);
4668     OUTPUT:
4669         RETVAL
4670
4671 bool
4672 test_isDIGIT_LC_uvchr(UV ord)
4673     CODE:
4674         RETVAL = isDIGIT_LC_uvchr(ord);
4675     OUTPUT:
4676         RETVAL
4677
4678 bool
4679 test_isDIGIT_utf8(unsigned char * p)
4680     CODE:
4681         RETVAL = isDIGIT_utf8( p);
4682     OUTPUT:
4683         RETVAL
4684
4685 bool
4686 test_isDIGIT_LC_utf8(unsigned char * p)
4687     CODE:
4688         RETVAL = isDIGIT_LC_utf8( p);
4689     OUTPUT:
4690         RETVAL
4691
4692 bool
4693 test_isDIGIT_A(UV ord)
4694     CODE:
4695         RETVAL = isDIGIT_A(ord);
4696     OUTPUT:
4697         RETVAL
4698
4699 bool
4700 test_isDIGIT_L1(UV ord)
4701     CODE:
4702         RETVAL = isDIGIT_L1(ord);
4703     OUTPUT:
4704         RETVAL
4705
4706 bool
4707 test_isDIGIT_LC(UV ord)
4708     CODE:
4709         RETVAL = isDIGIT_LC(ord);
4710     OUTPUT:
4711         RETVAL
4712
4713 bool
4714 test_isOCTAL_A(UV ord)
4715     CODE:
4716         RETVAL = isOCTAL_A(ord);
4717     OUTPUT:
4718         RETVAL
4719
4720 bool
4721 test_isOCTAL_L1(UV ord)
4722     CODE:
4723         RETVAL = isOCTAL_L1(ord);
4724     OUTPUT:
4725         RETVAL