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