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