ext/XS-APItest/APItest.xs

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