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