ext/XS-APItest/APItest.xs

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