ext/XS-APItest/APItest.xs

   1 #define PERL_IN_XS_APITEST
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 typedef SV *SVREF;
   7 typedef PTR_TBL_t *XS__APItest__PtrTable;
   8
   9 #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
  10
  11 /* for my_cxt tests */
  12
  13 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
  14
  15 typedef struct {
  16     int i;
  17     SV *sv;
  18     GV *cscgv;
  19     AV *cscav;
  20     AV *bhkav;
  21     bool bhk_record;
  22     peep_t orig_peep;
  23     peep_t orig_rpeep;
  24     int peep_recording;
  25     AV *peep_recorder;
  26     AV *rpeep_recorder;
  27 } my_cxt_t;
  28
  29 START_MY_CXT
  30
  31 /* indirect functions to test the [pa]MY_CXT macros */
  32
  33 int
  34 my_cxt_getint_p(pMY_CXT)
  35 {
  36     return MY_CXT.i;
  37 }
  38
  39 void
  40 my_cxt_setint_p(pMY_CXT_ int i)
  41 {
  42     MY_CXT.i = i;
  43 }
  44
  45 SV*
  46 my_cxt_getsv_interp_context(void)
  47 {
  48     dTHX;
  49     dMY_CXT_INTERP(my_perl);
  50     return MY_CXT.sv;
  51 }
  52
  53 SV*
  54 my_cxt_getsv_interp(void)
  55 {
  56     dMY_CXT;
  57     return MY_CXT.sv;
  58 }
  59
  60 void
  61 my_cxt_setsv_p(SV* sv _pMY_CXT)
  62 {
  63     MY_CXT.sv = sv;
  64 }
  65
  66
  67 /* from exception.c */
  68 int apitest_exception(int);
  69
  70 /* from core_or_not.inc */
  71 bool sv_setsv_cow_hashkey_core(void);
  72 bool sv_setsv_cow_hashkey_notcore(void);
  73
  74 /* A routine to test hv_delayfree_ent
  75    (which itself is tested by testing on hv_free_ent  */
  76
  77 typedef void (freeent_function)(pTHX_ HV *, register HE *);
  78
  79 void
  80 test_freeent(freeent_function *f) {
  81     dTHX;
  82     dSP;
  83     HV *test_hash = newHV();
  84     HE *victim;
  85     SV *test_scalar;
  86     U32 results[4];
  87     int i;
  88
  89 #ifdef PURIFY
  90     victim = (HE*)safemalloc(sizeof(HE));
  91 #else
  92     /* Storing then deleting something should ensure that a hash entry is
  93        available.  */
  94     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
  95     hv_delete(test_hash, "", 0, 0);
  96
  97     /* We need to "inline" new_he here as it's static, and the functions we
  98        test expect to be able to call del_HE on the HE  */
  99     if (!PL_body_roots[HE_SVSLOT])
 100         croak("PL_he_root is 0");
 101     victim = (HE*) PL_body_roots[HE_SVSLOT];
 102     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
 103 #endif
 104
 105     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
 106
 107     test_scalar = newSV(0);
 108     SvREFCNT_inc(test_scalar);
 109     HeVAL(victim) = test_scalar;
 110
 111     /* Need this little game else we free the temps on the return stack.  */
 112     results[0] = SvREFCNT(test_scalar);
 113     SAVETMPS;
 114     results[1] = SvREFCNT(test_scalar);
 115     f(aTHX_ test_hash, victim);
 116     results[2] = SvREFCNT(test_scalar);
 117     FREETMPS;
 118     results[3] = SvREFCNT(test_scalar);
 119
 120     i = 0;
 121     do {
 122         mPUSHu(results[i]);
 123     } while (++i < sizeof(results)/sizeof(results[0]));
 124
 125     /* Goodbye to our extra reference.  */
 126     SvREFCNT_dec(test_scalar);
 127 }
 128
 129
 130 static I32
 131 bitflip_key(pTHX_ IV action, SV *field) {
 132     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 133     SV *keysv;
 134     if (mg && (keysv = mg->mg_obj)) {
 135         STRLEN len;
 136         const char *p = SvPV(keysv, len);
 137
 138         if (len) {
 139             SV *newkey = newSV(len);
 140             char *new_p = SvPVX(newkey);
 141
 142             if (SvUTF8(keysv)) {
 143                 const char *const end = p + len;
 144                 while (p < end) {
 145                     STRLEN len;
 146                     UV chr = utf8_to_uvuni((U8 *)p, &len);
 147                     new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
 148                     p += len;
 149                 }
 150                 SvUTF8_on(newkey);
 151             } else {
 152                 while (len--)
 153                     *new_p++ = *p++ ^ 32;
 154             }
 155             *new_p = '\0';
 156             SvCUR_set(newkey, SvCUR(keysv));
 157             SvPOK_on(newkey);
 158
 159             mg->mg_obj = newkey;
 160         }
 161     }
 162     return 0;
 163 }
 164
 165 static I32
 166 rot13_key(pTHX_ IV action, SV *field) {
 167     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 168     SV *keysv;
 169     if (mg && (keysv = mg->mg_obj)) {
 170         STRLEN len;
 171         const char *p = SvPV(keysv, len);
 172
 173         if (len) {
 174             SV *newkey = newSV(len);
 175             char *new_p = SvPVX(newkey);
 176
 177             /* There's a deliberate fencepost error here to loop len + 1 times
 178                to copy the trailing \0  */
 179             do {
 180                 char new_c = *p++;
 181                 /* Try doing this cleanly and clearly in EBCDIC another way: */
 182                 switch (new_c) {
 183                 case 'A': new_c = 'N'; break;
 184                 case 'B': new_c = 'O'; break;
 185                 case 'C': new_c = 'P'; break;
 186                 case 'D': new_c = 'Q'; break;
 187                 case 'E': new_c = 'R'; break;
 188                 case 'F': new_c = 'S'; break;
 189                 case 'G': new_c = 'T'; break;
 190                 case 'H': new_c = 'U'; break;
 191                 case 'I': new_c = 'V'; break;
 192                 case 'J': new_c = 'W'; break;
 193                 case 'K': new_c = 'X'; break;
 194                 case 'L': new_c = 'Y'; break;
 195                 case 'M': new_c = 'Z'; break;
 196                 case 'N': new_c = 'A'; break;
 197                 case 'O': new_c = 'B'; break;
 198                 case 'P': new_c = 'C'; break;
 199                 case 'Q': new_c = 'D'; break;
 200                 case 'R': new_c = 'E'; break;
 201                 case 'S': new_c = 'F'; break;
 202                 case 'T': new_c = 'G'; break;
 203                 case 'U': new_c = 'H'; break;
 204                 case 'V': new_c = 'I'; break;
 205                 case 'W': new_c = 'J'; break;
 206                 case 'X': new_c = 'K'; break;
 207                 case 'Y': new_c = 'L'; break;
 208                 case 'Z': new_c = 'M'; break;
 209                 case 'a': new_c = 'n'; break;
 210                 case 'b': new_c = 'o'; break;
 211                 case 'c': new_c = 'p'; break;
 212                 case 'd': new_c = 'q'; break;
 213                 case 'e': new_c = 'r'; break;
 214                 case 'f': new_c = 's'; break;
 215                 case 'g': new_c = 't'; break;
 216                 case 'h': new_c = 'u'; break;
 217                 case 'i': new_c = 'v'; break;
 218                 case 'j': new_c = 'w'; break;
 219                 case 'k': new_c = 'x'; break;
 220                 case 'l': new_c = 'y'; break;
 221                 case 'm': new_c = 'z'; break;
 222                 case 'n': new_c = 'a'; break;
 223                 case 'o': new_c = 'b'; break;
 224                 case 'p': new_c = 'c'; break;
 225                 case 'q': new_c = 'd'; break;
 226                 case 'r': new_c = 'e'; break;
 227                 case 's': new_c = 'f'; break;
 228                 case 't': new_c = 'g'; break;
 229                 case 'u': new_c = 'h'; break;
 230                 case 'v': new_c = 'i'; break;
 231                 case 'w': new_c = 'j'; break;
 232                 case 'x': new_c = 'k'; break;
 233                 case 'y': new_c = 'l'; break;
 234                 case 'z': new_c = 'm'; break;
 235                 }
 236                 *new_p++ = new_c;
 237             } while (len--);
 238             SvCUR_set(newkey, SvCUR(keysv));
 239             SvPOK_on(newkey);
 240             if (SvUTF8(keysv))
 241                 SvUTF8_on(newkey);
 242
 243             mg->mg_obj = newkey;
 244         }
 245     }
 246     return 0;
 247 }
 248
 249 STATIC I32
 250 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
 251     return 0;
 252 }
 253
 254 STATIC MGVTBL rmagical_b = { 0 };
 255
 256 STATIC void
 257 blockhook_csc_start(pTHX_ int full)
 258 {
 259     dMY_CXT;
 260     AV *const cur = GvAV(MY_CXT.cscgv);
 261
 262     SAVEGENERICSV(GvAV(MY_CXT.cscgv));
 263
 264     if (cur) {
 265         I32 i;
 266         AV *const new_av = newAV();
 267
 268         for (i = 0; i <= av_len(cur); i++) {
 269             av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
 270         }
 271
 272         GvAV(MY_CXT.cscgv) = new_av;
 273     }
 274 }
 275
 276 STATIC void
 277 blockhook_csc_pre_end(pTHX_ OP **o)
 278 {
 279     dMY_CXT;
 280
 281     /* if we hit the end of a scope we missed the start of, we need to
 282      * unconditionally clear @CSC */
 283     if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
 284         av_clear(MY_CXT.cscav);
 285     }
 286
 287 }
 288
 289 STATIC void
 290 blockhook_test_start(pTHX_ int full)
 291 {
 292     dMY_CXT;
 293     AV *av;
 294
 295     if (MY_CXT.bhk_record) {
 296         av = newAV();
 297         av_push(av, newSVpvs("start"));
 298         av_push(av, newSViv(full));
 299         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 300     }
 301 }
 302
 303 STATIC void
 304 blockhook_test_pre_end(pTHX_ OP **o)
 305 {
 306     dMY_CXT;
 307
 308     if (MY_CXT.bhk_record)
 309         av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
 310 }
 311
 312 STATIC void
 313 blockhook_test_post_end(pTHX_ OP **o)
 314 {
 315     dMY_CXT;
 316
 317     if (MY_CXT.bhk_record)
 318         av_push(MY_CXT.bhkav, newSVpvs("post_end"));
 319 }
 320
 321 STATIC void
 322 blockhook_test_eval(pTHX_ OP *const o)
 323 {
 324     dMY_CXT;
 325     AV *av;
 326
 327     if (MY_CXT.bhk_record) {
 328         av = newAV();
 329         av_push(av, newSVpvs("eval"));
 330         av_push(av, newSVpv(OP_NAME(o), 0));
 331         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 332     }
 333 }
 334
 335 STATIC BHK bhk_csc, bhk_test;
 336
 337 STATIC void
 338 my_peep (pTHX_ OP *o)
 339 {
 340     dMY_CXT;
 341
 342     if (!o)
 343         return;
 344
 345     MY_CXT.orig_peep(aTHX_ o);
 346
 347     if (!MY_CXT.peep_recording)
 348         return;
 349
 350     for (; o; o = o->op_next) {
 351         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
 352             av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
 353         }
 354     }
 355 }
 356
 357 STATIC void
 358 my_rpeep (pTHX_ OP *o)
 359 {
 360     dMY_CXT;
 361
 362     if (!o)
 363         return;
 364
 365     MY_CXT.orig_rpeep(aTHX_ o);
 366
 367     if (!MY_CXT.peep_recording)
 368         return;
 369
 370     for (; o; o = o->op_next) {
 371         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
 372             av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
 373         }
 374     }
 375 }
 376
 377 STATIC OP *
 378 THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 379 {
 380     return ck_entersub_args_list(entersubop);
 381 }
 382
 383 STATIC OP *
 384 THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 385 {
 386     OP *aop = cUNOPx(entersubop)->op_first;
 387     if (!aop->op_sibling)
 388         aop = cUNOPx(aop)->op_first;
 389     for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
 390         op_contextualize(aop, G_SCALAR);
 391     }
 392     return entersubop;
 393 }
 394
 395 STATIC OP *
 396 THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
 397 {
 398     OP *sumop = NULL;
 399     OP *pushop = cUNOPx(entersubop)->op_first;
 400     if (!pushop->op_sibling)
 401         pushop = cUNOPx(pushop)->op_first;
 402     while (1) {
 403         OP *aop = pushop->op_sibling;
 404         if (!aop->op_sibling)
 405             break;
 406         pushop->op_sibling = aop->op_sibling;
 407         aop->op_sibling = NULL;
 408         op_contextualize(aop, G_SCALAR);
 409         if (sumop) {
 410             sumop = newBINOP(OP_ADD, 0, sumop, aop);
 411         } else {
 412             sumop = aop;
 413         }
 414     }
 415     if (!sumop)
 416         sumop = newSVOP(OP_CONST, 0, newSViv(0));
 417     op_free(entersubop);
 418     return sumop;
 419 }
 420
 421 STATIC void test_op_list_describe_part(SV *res, OP *o);
 422 STATIC void
 423 test_op_list_describe_part(SV *res, OP *o)
 424 {
 425     sv_catpv(res, PL_op_name[o->op_type]);
 426     switch (o->op_type) {
 427         case OP_CONST: {
 428             sv_catpvf(res, "(%d)", (int)SvIV(cSVOPx(o)->op_sv));
 429         } break;
 430     }
 431     if (o->op_flags & OPf_KIDS) {
 432         OP *k;
 433         sv_catpvs(res, "[");
 434         for (k = cUNOPx(o)->op_first; k; k = k->op_sibling)
 435             test_op_list_describe_part(res, k);
 436         sv_catpvs(res, "]");
 437     } else {
 438         sv_catpvs(res, ".");
 439     }
 440 }
 441
 442 STATIC char *
 443 test_op_list_describe(OP *o)
 444 {
 445     SV *res = sv_2mortal(newSVpvs(""));
 446     if (o)
 447         test_op_list_describe_part(res, o);
 448     return SvPVX(res);
 449 }
 450
 451 /* the real new*OP functions have a tendancy to call fold_constants, and
 452  * other such unhelpful things, so we need our own versions for testing */
 453
 454 #define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
 455 static OP *
 456 THX_mkUNOP(pTHX_ U32 type, OP *first)
 457 {
 458     UNOP *unop;
 459     NewOp(1103, unop, 1, UNOP);
 460     unop->op_type   = (OPCODE)type;
 461     unop->op_first  = first;
 462     unop->op_flags  = OPf_KIDS;
 463     return (OP *)unop;
 464 }
 465
 466 #define mkBINOP(t, f, l) THX_mkBINOP(aTHX_ (t), (f), (l))
 467 static OP *
 468 THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last)
 469 {
 470     BINOP *binop;
 471     NewOp(1103, binop, 1, BINOP);
 472     binop->op_type      = (OPCODE)type;
 473     binop->op_first     = first;
 474     binop->op_flags     = OPf_KIDS;
 475     binop->op_last      = last;
 476     first->op_sibling   = last;
 477     return (OP *)binop;
 478 }
 479
 480 #define mkLISTOP(t, f, s, l) THX_mkLISTOP(aTHX_ (t), (f), (s), (l))
 481 static OP *
 482 THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last)
 483 {
 484     LISTOP *listop;
 485     NewOp(1103, listop, 1, LISTOP);
 486     listop->op_type     = (OPCODE)type;
 487     listop->op_flags    = OPf_KIDS;
 488     listop->op_first    = first;
 489     first->op_sibling   = sib;
 490     sib->op_sibling     = last;
 491     listop->op_last     = last;
 492     return (OP *)listop;
 493 }
 494
 495 static char *
 496 test_op_linklist_describe(OP *start)
 497 {
 498     SV *rv = sv_2mortal(newSVpvs(""));
 499     OP *o;
 500     o = start = LINKLIST(start);
 501     do {
 502         sv_catpvs(rv, ".");
 503         sv_catpv(rv, OP_NAME(o));
 504         if (o->op_type == OP_CONST)
 505             sv_catsv(rv, cSVOPo->op_sv);
 506         o = o->op_next;
 507     } while (o && o != start);
 508     return SvPVX(rv);
 509 }
 510
 511 /** RPN keyword parser **/
 512
 513 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
 514 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
 515 #define sv_is_string(sv) \
 516     (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
 517      (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
 518
 519 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
 520 static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
 521 static SV *hintkey_scopelessblock_sv;
 522 static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
 523 static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
 524 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
 525
 526 /* low-level parser helpers */
 527
 528 #define PL_bufptr (PL_parser->bufptr)
 529 #define PL_bufend (PL_parser->bufend)
 530
 531 /* RPN parser */
 532
 533 #define parse_var() THX_parse_var(aTHX)
 534 static OP *THX_parse_var(pTHX)
 535 {
 536     char *s = PL_bufptr;
 537     char *start = s;
 538     PADOFFSET varpos;
 539     OP *padop;
 540     if(*s != '$') croak("RPN syntax error");
 541     while(1) {
 542         char c = *++s;
 543         if(!isALNUM(c)) break;
 544     }
 545     if(s-start < 2) croak("RPN syntax error");
 546     lex_read_to(s);
 547     {
 548         /* because pad_findmy() doesn't really use length yet */
 549         SV *namesv = sv_2mortal(newSVpvn(start, s-start));
 550         varpos = pad_findmy(SvPVX(namesv), s-start, 0);
 551     }
 552     if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
 553         croak("RPN only supports \"my\" variables");
 554     padop = newOP(OP_PADSV, 0);
 555     padop->op_targ = varpos;
 556     return padop;
 557 }
 558
 559 #define push_rpn_item(o) \
 560     (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
 561 #define pop_rpn_item() \
 562     (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
 563      (tmpop = stack, stack = stack->op_sibling, \
 564       tmpop->op_sibling = NULL, tmpop))
 565
 566 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
 567 static OP *THX_parse_rpn_expr(pTHX)
 568 {
 569     OP *stack = NULL, *tmpop;
 570     while(1) {
 571         I32 c;
 572         lex_read_space(0);
 573         c = lex_peek_unichar(0);
 574         switch(c) {
 575             case /*(*/')': case /*{*/'}': {
 576                 OP *result = pop_rpn_item();
 577                 if(stack) croak("RPN expression must return a single value");
 578                 return result;
 579             } break;
 580             case '0': case '1': case '2': case '3': case '4':
 581             case '5': case '6': case '7': case '8': case '9': {
 582                 UV val = 0;
 583                 do {
 584                     lex_read_unichar(0);
 585                     val = 10*val + (c - '0');
 586                     c = lex_peek_unichar(0);
 587                 } while(c >= '0' && c <= '9');
 588                 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
 589             } break;
 590             case '$': {
 591                 push_rpn_item(parse_var());
 592             } break;
 593             case '+': {
 594                 OP *b = pop_rpn_item();
 595                 OP *a = pop_rpn_item();
 596                 lex_read_unichar(0);
 597                 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
 598             } break;
 599             case '-': {
 600                 OP *b = pop_rpn_item();
 601                 OP *a = pop_rpn_item();
 602                 lex_read_unichar(0);
 603                 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
 604             } break;
 605             case '*': {
 606                 OP *b = pop_rpn_item();
 607                 OP *a = pop_rpn_item();
 608                 lex_read_unichar(0);
 609                 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
 610             } break;
 611             case '/': {
 612                 OP *b = pop_rpn_item();
 613                 OP *a = pop_rpn_item();
 614                 lex_read_unichar(0);
 615                 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
 616             } break;
 617             case '%': {
 618                 OP *b = pop_rpn_item();
 619                 OP *a = pop_rpn_item();
 620                 lex_read_unichar(0);
 621                 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
 622             } break;
 623             default: {
 624                 croak("RPN syntax error");
 625             } break;
 626         }
 627     }
 628 }
 629
 630 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
 631 static OP *THX_parse_keyword_rpn(pTHX)
 632 {
 633     OP *op;
 634     lex_read_space(0);
 635     if(lex_peek_unichar(0) != '('/*)*/)
 636         croak("RPN expression must be parenthesised");
 637     lex_read_unichar(0);
 638     op = parse_rpn_expr();
 639     if(lex_peek_unichar(0) != /*(*/')')
 640         croak("RPN expression must be parenthesised");
 641     lex_read_unichar(0);
 642     return op;
 643 }
 644
 645 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
 646 static OP *THX_parse_keyword_calcrpn(pTHX)
 647 {
 648     OP *varop, *exprop;
 649     lex_read_space(0);
 650     varop = parse_var();
 651     lex_read_space(0);
 652     if(lex_peek_unichar(0) != '{'/*}*/)
 653         croak("RPN expression must be braced");
 654     lex_read_unichar(0);
 655     exprop = parse_rpn_expr();
 656     if(lex_peek_unichar(0) != /*{*/'}')
 657         croak("RPN expression must be braced");
 658     lex_read_unichar(0);
 659     return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
 660 }
 661
 662 #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
 663 static OP *THX_parse_keyword_stufftest(pTHX)
 664 {
 665     I32 c;
 666     bool do_stuff;
 667     lex_read_space(0);
 668     do_stuff = lex_peek_unichar(0) == '+';
 669     if(do_stuff) {
 670         lex_read_unichar(0);
 671         lex_read_space(0);
 672     }
 673     c = lex_peek_unichar(0);
 674     if(c == ';') {
 675         lex_read_unichar(0);
 676     } else if(c != /*{*/'}') {
 677         croak("syntax error");
 678     }
 679     if(do_stuff) lex_stuff_pvs(" ", 0);
 680     return newOP(OP_NULL, 0);
 681 }
 682
 683 #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
 684 static OP *THX_parse_keyword_swaptwostmts(pTHX)
 685 {
 686     OP *a, *b;
 687     a = parse_fullstmt(0);
 688     b = parse_fullstmt(0);
 689     if(a && b)
 690         PL_hints |= HINT_BLOCK_SCOPE;
 691     return op_append_list(OP_LINESEQ, b, a);
 692 }
 693
 694 #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
 695 static OP *THX_parse_keyword_looprest(pTHX)
 696 {
 697     I32 condline;
 698     OP *body;
 699     condline = CopLINE(PL_curcop);
 700     body = parse_stmtseq(0);
 701     return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
 702                         body, NULL, 1);
 703 }
 704
 705 #define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
 706 static OP *THX_parse_keyword_scopelessblock(pTHX)
 707 {
 708     I32 c;
 709     OP *body;
 710     lex_read_space(0);
 711     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
 712     lex_read_unichar(0);
 713     body = parse_stmtseq(0);
 714     c = lex_peek_unichar(0);
 715     if(c != /*{*/'}' && c != /*[*/']' && c != /*(*/')') croak("syntax error");
 716     lex_read_unichar(0);
 717     return body;
 718 }
 719
 720 #define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
 721 static OP *THX_parse_keyword_stmtasexpr(pTHX)
 722 {
 723     OP *o = parse_fullstmt(0);
 724     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
 725     o->op_type = OP_LEAVE;
 726     o->op_ppaddr = PL_ppaddr[OP_LEAVE];
 727     return o;
 728 }
 729
 730 #define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
 731 static OP *THX_parse_keyword_stmtsasexpr(pTHX)
 732 {
 733     OP *o;
 734     lex_read_space(0);
 735     if(lex_peek_unichar(0) != '{'/*}*/) croak("syntax error");
 736     lex_read_unichar(0);
 737     o = parse_stmtseq(0);
 738     lex_read_space(0);
 739     if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
 740     lex_read_unichar(0);
 741     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
 742     o->op_type = OP_LEAVE;
 743     o->op_ppaddr = PL_ppaddr[OP_LEAVE];
 744     return o;
 745 }
 746
 747 #define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX)
 748 static OP *THX_parse_keyword_loopblock(pTHX)
 749 {
 750     I32 condline;
 751     OP *body;
 752     condline = CopLINE(PL_curcop);
 753     body = parse_block(0);
 754     return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
 755                         body, NULL, 1);
 756 }
 757
 758 #define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX)
 759 static OP *THX_parse_keyword_blockasexpr(pTHX)
 760 {
 761     OP *o = parse_block(0);
 762     o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
 763     o->op_type = OP_LEAVE;
 764     o->op_ppaddr = PL_ppaddr[OP_LEAVE];
 765     return o;
 766 }
 767
 768 /* plugin glue */
 769
 770 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
 771 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
 772 {
 773     HE *he;
 774     if(!GvHV(PL_hintgv)) return 0;
 775     he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
 776                 SvSHARED_HASH(hintkey_sv));
 777     return he && SvTRUE(HeVAL(he));
 778 }
 779
 780 static int my_keyword_plugin(pTHX_
 781     char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
 782 {
 783     if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
 784                     keyword_active(hintkey_rpn_sv)) {
 785         *op_ptr = parse_keyword_rpn();
 786         return KEYWORD_PLUGIN_EXPR;
 787     } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
 788                     keyword_active(hintkey_calcrpn_sv)) {
 789         *op_ptr = parse_keyword_calcrpn();
 790         return KEYWORD_PLUGIN_STMT;
 791     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
 792                     keyword_active(hintkey_stufftest_sv)) {
 793         *op_ptr = parse_keyword_stufftest();
 794         return KEYWORD_PLUGIN_STMT;
 795     } else if(keyword_len == 12 &&
 796                     strnEQ(keyword_ptr, "swaptwostmts", 12) &&
 797                     keyword_active(hintkey_swaptwostmts_sv)) {
 798         *op_ptr = parse_keyword_swaptwostmts();
 799         return KEYWORD_PLUGIN_STMT;
 800     } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
 801                     keyword_active(hintkey_looprest_sv)) {
 802         *op_ptr = parse_keyword_looprest();
 803         return KEYWORD_PLUGIN_STMT;
 804     } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) &&
 805                     keyword_active(hintkey_scopelessblock_sv)) {
 806         *op_ptr = parse_keyword_scopelessblock();
 807         return KEYWORD_PLUGIN_STMT;
 808     } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) &&
 809                     keyword_active(hintkey_stmtasexpr_sv)) {
 810         *op_ptr = parse_keyword_stmtasexpr();
 811         return KEYWORD_PLUGIN_EXPR;
 812     } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) &&
 813                     keyword_active(hintkey_stmtsasexpr_sv)) {
 814         *op_ptr = parse_keyword_stmtsasexpr();
 815         return KEYWORD_PLUGIN_EXPR;
 816     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "loopblock", 9) &&
 817                     keyword_active(hintkey_loopblock_sv)) {
 818         *op_ptr = parse_keyword_loopblock();
 819         return KEYWORD_PLUGIN_STMT;
 820     } else if(keyword_len == 11 && strnEQ(keyword_ptr, "blockasexpr", 11) &&
 821                     keyword_active(hintkey_blockasexpr_sv)) {
 822         *op_ptr = parse_keyword_blockasexpr();
 823         return KEYWORD_PLUGIN_EXPR;
 824     } else {
 825         return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
 826     }
 827 }
 828
 829 XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
 830 XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
 831 XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
 832
 833 #include "const-c.inc"
 834
 835 MODULE = XS::APItest            PACKAGE = XS::APItest
 836
 837 INCLUDE: const-xs.inc
 838
 839 INCLUDE: numeric.xs
 840
 841 MODULE = XS::APItest            PACKAGE = XS::APItest::XSUB
 842
 843 BOOT:
 844     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
 845     newXS("XS::APItest::XSUB::XS_VERSION_empty", XS_XS__APItest__XSUB_XS_VERSION_empty, __FILE__);
 846     newXS("XS::APItest::XSUB::XS_APIVERSION_invalid", XS_XS__APItest__XSUB_XS_APIVERSION_invalid, __FILE__);
 847
 848 void
 849 XS_VERSION_defined(...)
 850     PPCODE:
 851         XS_VERSION_BOOTCHECK;
 852         XSRETURN_EMPTY;
 853
 854 void
 855 XS_APIVERSION_valid(...)
 856     PPCODE:
 857         XS_APIVERSION_BOOTCHECK;
 858         XSRETURN_EMPTY;
 859
 860 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
 861
 862 void
 863 rot13_hash(hash)
 864         HV *hash
 865         CODE:
 866         {
 867             struct ufuncs uf;
 868             uf.uf_val = rot13_key;
 869             uf.uf_set = 0;
 870             uf.uf_index = 0;
 871
 872             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
 873         }
 874
 875 void
 876 bitflip_hash(hash)
 877         HV *hash
 878         CODE:
 879         {
 880             struct ufuncs uf;
 881             uf.uf_val = bitflip_key;
 882             uf.uf_set = 0;
 883             uf.uf_index = 0;
 884
 885             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
 886         }
 887
 888 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
 889
 890 bool
 891 exists(hash, key_sv)
 892         PREINIT:
 893         STRLEN len;
 894         const char *key;
 895         INPUT:
 896         HV *hash
 897         SV *key_sv
 898         CODE:
 899         key = SvPV(key_sv, len);
 900         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
 901         OUTPUT:
 902         RETVAL
 903
 904 bool
 905 exists_ent(hash, key_sv)
 906         PREINIT:
 907         INPUT:
 908         HV *hash
 909         SV *key_sv
 910         CODE:
 911         RETVAL = hv_exists_ent(hash, key_sv, 0);
 912         OUTPUT:
 913         RETVAL
 914
 915 SV *
 916 delete(hash, key_sv, flags = 0)
 917         PREINIT:
 918         STRLEN len;
 919         const char *key;
 920         INPUT:
 921         HV *hash
 922         SV *key_sv
 923         I32 flags;
 924         CODE:
 925         key = SvPV(key_sv, len);
 926         /* It's already mortal, so need to increase reference count.  */
 927         RETVAL
 928             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
 929         OUTPUT:
 930         RETVAL
 931
 932 SV *
 933 delete_ent(hash, key_sv, flags = 0)
 934         INPUT:
 935         HV *hash
 936         SV *key_sv
 937         I32 flags;
 938         CODE:
 939         /* It's already mortal, so need to increase reference count.  */
 940         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
 941         OUTPUT:
 942         RETVAL
 943
 944 SV *
 945 store_ent(hash, key, value)
 946         PREINIT:
 947         SV *copy;
 948         HE *result;
 949         INPUT:
 950         HV *hash
 951         SV *key
 952         SV *value
 953         CODE:
 954         copy = newSV(0);
 955         result = hv_store_ent(hash, key, copy, 0);
 956         SvSetMagicSV(copy, value);
 957         if (!result) {
 958             SvREFCNT_dec(copy);
 959             XSRETURN_EMPTY;
 960         }
 961         /* It's about to become mortal, so need to increase reference count.
 962          */
 963         RETVAL = SvREFCNT_inc(HeVAL(result));
 964         OUTPUT:
 965         RETVAL
 966
 967 SV *
 968 store(hash, key_sv, value)
 969         PREINIT:
 970         STRLEN len;
 971         const char *key;
 972         SV *copy;
 973         SV **result;
 974         INPUT:
 975         HV *hash
 976         SV *key_sv
 977         SV *value
 978         CODE:
 979         key = SvPV(key_sv, len);
 980         copy = newSV(0);
 981         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
 982         SvSetMagicSV(copy, value);
 983         if (!result) {
 984             SvREFCNT_dec(copy);
 985             XSRETURN_EMPTY;
 986         }
 987         /* It's about to become mortal, so need to increase reference count.
 988          */
 989         RETVAL = SvREFCNT_inc(*result);
 990         OUTPUT:
 991         RETVAL
 992
 993 SV *
 994 fetch_ent(hash, key_sv)
 995         PREINIT:
 996         HE *result;
 997         INPUT:
 998         HV *hash
 999         SV *key_sv
1000         CODE:
1001         result = hv_fetch_ent(hash, key_sv, 0, 0);
1002         if (!result) {
1003             XSRETURN_EMPTY;
1004         }
1005         /* Force mg_get  */
1006         RETVAL = newSVsv(HeVAL(result));
1007         OUTPUT:
1008         RETVAL
1009
1010 SV *
1011 fetch(hash, key_sv)
1012         PREINIT:
1013         STRLEN len;
1014         const char *key;
1015         SV **result;
1016         INPUT:
1017         HV *hash
1018         SV *key_sv
1019         CODE:
1020         key = SvPV(key_sv, len);
1021         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
1022         if (!result) {
1023             XSRETURN_EMPTY;
1024         }
1025         /* Force mg_get  */
1026         RETVAL = newSVsv(*result);
1027         OUTPUT:
1028         RETVAL
1029
1030 #if defined (hv_common)
1031
1032 SV *
1033 common(params)
1034         INPUT:
1035         HV *params
1036         PREINIT:
1037         HE *result;
1038         HV *hv = NULL;
1039         SV *keysv = NULL;
1040         const char *key = NULL;
1041         STRLEN klen = 0;
1042         int flags = 0;
1043         int action = 0;
1044         SV *val = NULL;
1045         U32 hash = 0;
1046         SV **svp;
1047         CODE:
1048         if ((svp = hv_fetchs(params, "hv", 0))) {
1049             SV *const rv = *svp;
1050             if (!SvROK(rv))
1051                 croak("common passed a non-reference for parameter hv");
1052             hv = (HV *)SvRV(rv);
1053         }
1054         if ((svp = hv_fetchs(params, "keysv", 0)))
1055             keysv = *svp;
1056         if ((svp = hv_fetchs(params, "keypv", 0))) {
1057             key = SvPV_const(*svp, klen);
1058             if (SvUTF8(*svp))
1059                 flags = HVhek_UTF8;
1060         }
1061         if ((svp = hv_fetchs(params, "action", 0)))
1062             action = SvIV(*svp);
1063         if ((svp = hv_fetchs(params, "val", 0)))
1064             val = newSVsv(*svp);
1065         if ((svp = hv_fetchs(params, "hash", 0)))
1066             hash = SvUV(*svp);
1067
1068         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
1069             PERL_HASH(hash, key, klen);
1070         }
1071         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
1072             STRLEN len;
1073             const char *const p = SvPV(keysv, len);
1074             PERL_HASH(hash, p, len);
1075         }
1076
1077         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
1078         if (!result) {
1079             XSRETURN_EMPTY;
1080         }
1081         /* Force mg_get  */
1082         RETVAL = newSVsv(HeVAL(result));
1083         OUTPUT:
1084         RETVAL
1085
1086 #endif
1087
1088 void
1089 test_hv_free_ent()
1090         PPCODE:
1091         test_freeent(&Perl_hv_free_ent);
1092         XSRETURN(4);
1093
1094 void
1095 test_hv_delayfree_ent()
1096         PPCODE:
1097         test_freeent(&Perl_hv_delayfree_ent);
1098         XSRETURN(4);
1099
1100 SV *
1101 test_share_unshare_pvn(input)
1102         PREINIT:
1103         STRLEN len;
1104         U32 hash;
1105         char *pvx;
1106         char *p;
1107         INPUT:
1108         SV *input
1109         CODE:
1110         pvx = SvPV(input, len);
1111         PERL_HASH(hash, pvx, len);
1112         p = sharepvn(pvx, len, hash);
1113         RETVAL = newSVpvn(p, len);
1114         unsharepvn(p, len, hash);
1115         OUTPUT:
1116         RETVAL
1117
1118 #if PERL_VERSION >= 9
1119
1120 bool
1121 refcounted_he_exists(key, level=0)
1122         SV *key
1123         IV level
1124         CODE:
1125         if (level) {
1126             croak("level must be zero, not %"IVdf, level);
1127         }
1128         RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder);
1129         OUTPUT:
1130         RETVAL
1131
1132 SV *
1133 refcounted_he_fetch(key, level=0)
1134         SV *key
1135         IV level
1136         CODE:
1137         if (level) {
1138             croak("level must be zero, not %"IVdf, level);
1139         }
1140         RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0);
1141         SvREFCNT_inc(RETVAL);
1142         OUTPUT:
1143         RETVAL
1144
1145 #endif
1146
1147 =pod
1148
1149 sub TIEHASH  { bless {}, $_[0] }
1150 sub STORE    { $_[0]->{$_[1]} = $_[2] }
1151 sub FETCH    { $_[0]->{$_[1]} }
1152 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
1153 sub NEXTKEY  { each %{$_[0]} }
1154 sub EXISTS   { exists $_[0]->{$_[1]} }
1155 sub DELETE   { delete $_[0]->{$_[1]} }
1156 sub CLEAR    { %{$_[0]} = () }
1157
1158 =cut
1159
1160 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
1161
1162 void
1163 make_temp_mg_lv(sv)
1164 SV* sv
1165     PREINIT:
1166         SV * const lv = newSV_type(SVt_PVLV);
1167         STRLEN len;
1168     PPCODE:
1169         SvPV(sv, len);
1170
1171         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
1172         LvTYPE(lv) = 'x';
1173         LvTARG(lv) = SvREFCNT_inc_simple(sv);
1174         LvTARGOFF(lv) = len == 0 ? 0 : 1;
1175         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
1176
1177         EXTEND(SP, 1);
1178         ST(0) = sv_2mortal(lv);
1179         XSRETURN(1);
1180
1181
1182 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
1183
1184 void
1185 ptr_table_new(classname)
1186 const char * classname
1187     PPCODE:
1188     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
1189
1190 void
1191 DESTROY(table)
1192 XS::APItest::PtrTable table
1193     CODE:
1194     ptr_table_free(table);
1195
1196 void
1197 ptr_table_store(table, from, to)
1198 XS::APItest::PtrTable table
1199 SVREF from
1200 SVREF to
1201    CODE:
1202    ptr_table_store(table, from, to);
1203
1204 UV
1205 ptr_table_fetch(table, from)
1206 XS::APItest::PtrTable table
1207 SVREF from
1208    CODE:
1209    RETVAL = PTR2UV(ptr_table_fetch(table, from));
1210    OUTPUT:
1211    RETVAL
1212
1213 void
1214 ptr_table_split(table)
1215 XS::APItest::PtrTable table
1216
1217 void
1218 ptr_table_clear(table)
1219 XS::APItest::PtrTable table
1220
1221 MODULE = XS::APItest            PACKAGE = XS::APItest
1222
1223 PROTOTYPES: DISABLE
1224
1225 BOOT:
1226 {
1227     MY_CXT_INIT;
1228
1229     MY_CXT.i  = 99;
1230     MY_CXT.sv = newSVpv("initial",0);
1231
1232     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1233     MY_CXT.bhk_record = 0;
1234
1235     BhkENTRY_set(&bhk_test, bhk_start, blockhook_test_start);
1236     BhkENTRY_set(&bhk_test, bhk_pre_end, blockhook_test_pre_end);
1237     BhkENTRY_set(&bhk_test, bhk_post_end, blockhook_test_post_end);
1238     BhkENTRY_set(&bhk_test, bhk_eval, blockhook_test_eval);
1239     Perl_blockhook_register(aTHX_ &bhk_test);
1240
1241     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1242         GV_ADDMULTI, SVt_PVAV);
1243     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1244
1245     BhkENTRY_set(&bhk_csc, bhk_start, blockhook_csc_start);
1246     BhkENTRY_set(&bhk_csc, bhk_pre_end, blockhook_csc_pre_end);
1247     Perl_blockhook_register(aTHX_ &bhk_csc);
1248
1249     MY_CXT.peep_recorder = newAV();
1250     MY_CXT.rpeep_recorder = newAV();
1251
1252     MY_CXT.orig_peep = PL_peepp;
1253     MY_CXT.orig_rpeep = PL_rpeepp;
1254     PL_peepp = my_peep;
1255     PL_rpeepp = my_rpeep;
1256 }
1257
1258 void
1259 CLONE(...)
1260     CODE:
1261     MY_CXT_CLONE;
1262     MY_CXT.sv = newSVpv("initial_clone",0);
1263     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1264         GV_ADDMULTI, SVt_PVAV);
1265     MY_CXT.cscav = NULL;
1266     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1267     MY_CXT.bhk_record = 0;
1268     MY_CXT.peep_recorder = newAV();
1269     MY_CXT.rpeep_recorder = newAV();
1270
1271 void
1272 print_double(val)
1273         double val
1274         CODE:
1275         printf("%5.3f\n",val);
1276
1277 int
1278 have_long_double()
1279         CODE:
1280 #ifdef HAS_LONG_DOUBLE
1281         RETVAL = 1;
1282 #else
1283         RETVAL = 0;
1284 #endif
1285         OUTPUT:
1286         RETVAL
1287
1288 void
1289 print_long_double()
1290         CODE:
1291 #ifdef HAS_LONG_DOUBLE
1292 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
1293         long double val = 7.0;
1294         printf("%5.3" PERL_PRIfldbl "\n",val);
1295 #   else
1296         double val = 7.0;
1297         printf("%5.3f\n",val);
1298 #   endif
1299 #endif
1300
1301 void
1302 print_int(val)
1303         int val
1304         CODE:
1305         printf("%d\n",val);
1306
1307 void
1308 print_long(val)
1309         long val
1310         CODE:
1311         printf("%ld\n",val);
1312
1313 void
1314 print_float(val)
1315         float val
1316         CODE:
1317         printf("%5.3f\n",val);
1318
1319 void
1320 print_flush()
1321         CODE:
1322         fflush(stdout);
1323
1324 void
1325 mpushp()
1326         PPCODE:
1327         EXTEND(SP, 3);
1328         mPUSHp("one", 3);
1329         mPUSHp("two", 3);
1330         mPUSHp("three", 5);
1331         XSRETURN(3);
1332
1333 void
1334 mpushn()
1335         PPCODE:
1336         EXTEND(SP, 3);
1337         mPUSHn(0.5);
1338         mPUSHn(-0.25);
1339         mPUSHn(0.125);
1340         XSRETURN(3);
1341
1342 void
1343 mpushi()
1344         PPCODE:
1345         EXTEND(SP, 3);
1346         mPUSHi(-1);
1347         mPUSHi(2);
1348         mPUSHi(-3);
1349         XSRETURN(3);
1350
1351 void
1352 mpushu()
1353         PPCODE:
1354         EXTEND(SP, 3);
1355         mPUSHu(1);
1356         mPUSHu(2);
1357         mPUSHu(3);
1358         XSRETURN(3);
1359
1360 void
1361 mxpushp()
1362         PPCODE:
1363         mXPUSHp("one", 3);
1364         mXPUSHp("two", 3);
1365         mXPUSHp("three", 5);
1366         XSRETURN(3);
1367
1368 void
1369 mxpushn()
1370         PPCODE:
1371         mXPUSHn(0.5);
1372         mXPUSHn(-0.25);
1373         mXPUSHn(0.125);
1374         XSRETURN(3);
1375
1376 void
1377 mxpushi()
1378         PPCODE:
1379         mXPUSHi(-1);
1380         mXPUSHi(2);
1381         mXPUSHi(-3);
1382         XSRETURN(3);
1383
1384 void
1385 mxpushu()
1386         PPCODE:
1387         mXPUSHu(1);
1388         mXPUSHu(2);
1389         mXPUSHu(3);
1390         XSRETURN(3);
1391
1392
1393 void
1394 call_sv(sv, flags, ...)
1395     SV* sv
1396     I32 flags
1397     PREINIT:
1398         I32 i;
1399     PPCODE:
1400         for (i=0; i<items-2; i++)
1401             ST(i) = ST(i+2); /* pop first two args */
1402         PUSHMARK(SP);
1403         SP += items - 2;
1404         PUTBACK;
1405         i = call_sv(sv, flags);
1406         SPAGAIN;
1407         EXTEND(SP, 1);
1408         PUSHs(sv_2mortal(newSViv(i)));
1409
1410 void
1411 call_pv(subname, flags, ...)
1412     char* subname
1413     I32 flags
1414     PREINIT:
1415         I32 i;
1416     PPCODE:
1417         for (i=0; i<items-2; i++)
1418             ST(i) = ST(i+2); /* pop first two args */
1419         PUSHMARK(SP);
1420         SP += items - 2;
1421         PUTBACK;
1422         i = call_pv(subname, flags);
1423         SPAGAIN;
1424         EXTEND(SP, 1);
1425         PUSHs(sv_2mortal(newSViv(i)));
1426
1427 void
1428 call_method(methname, flags, ...)
1429     char* methname
1430     I32 flags
1431     PREINIT:
1432         I32 i;
1433     PPCODE:
1434         for (i=0; i<items-2; i++)
1435             ST(i) = ST(i+2); /* pop first two args */
1436         PUSHMARK(SP);
1437         SP += items - 2;
1438         PUTBACK;
1439         i = call_method(methname, flags);
1440         SPAGAIN;
1441         EXTEND(SP, 1);
1442         PUSHs(sv_2mortal(newSViv(i)));
1443
1444 void
1445 eval_sv(sv, flags)
1446     SV* sv
1447     I32 flags
1448     PREINIT:
1449         I32 i;
1450     PPCODE:
1451         PUTBACK;
1452         i = eval_sv(sv, flags);
1453         SPAGAIN;
1454         EXTEND(SP, 1);
1455         PUSHs(sv_2mortal(newSViv(i)));
1456
1457 void
1458 eval_pv(p, croak_on_error)
1459     const char* p
1460     I32 croak_on_error
1461     PPCODE:
1462         PUTBACK;
1463         EXTEND(SP, 1);
1464         PUSHs(eval_pv(p, croak_on_error));
1465
1466 void
1467 require_pv(pv)
1468     const char* pv
1469     PPCODE:
1470         PUTBACK;
1471         require_pv(pv);
1472
1473 int
1474 apitest_exception(throw_e)
1475     int throw_e
1476     OUTPUT:
1477         RETVAL
1478
1479 void
1480 mycroak(sv)
1481     SV* sv
1482     CODE:
1483     if (SvOK(sv)) {
1484         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
1485     }
1486     else {
1487         Perl_croak(aTHX_ NULL);
1488     }
1489
1490 SV*
1491 strtab()
1492    CODE:
1493    RETVAL = newRV_inc((SV*)PL_strtab);
1494    OUTPUT:
1495    RETVAL
1496
1497 int
1498 my_cxt_getint()
1499     CODE:
1500         dMY_CXT;
1501         RETVAL = my_cxt_getint_p(aMY_CXT);
1502     OUTPUT:
1503         RETVAL
1504
1505 void
1506 my_cxt_setint(i)
1507     int i;
1508     CODE:
1509         dMY_CXT;
1510         my_cxt_setint_p(aMY_CXT_ i);
1511
1512 void
1513 my_cxt_getsv(how)
1514     bool how;
1515     PPCODE:
1516         EXTEND(SP, 1);
1517         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
1518         XSRETURN(1);
1519
1520 void
1521 my_cxt_setsv(sv)
1522     SV *sv;
1523     CODE:
1524         dMY_CXT;
1525         SvREFCNT_dec(MY_CXT.sv);
1526         my_cxt_setsv_p(sv _aMY_CXT);
1527         SvREFCNT_inc(sv);
1528
1529 bool
1530 sv_setsv_cow_hashkey_core()
1531
1532 bool
1533 sv_setsv_cow_hashkey_notcore()
1534
1535 void
1536 rmagical_cast(sv, type)
1537     SV *sv;
1538     SV *type;
1539     PREINIT:
1540         struct ufuncs uf;
1541     PPCODE:
1542         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1543         sv = SvRV(sv);
1544         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1545         uf.uf_val = rmagical_a_dummy;
1546         uf.uf_set = NULL;
1547         uf.uf_index = 0;
1548         if (SvTRUE(type)) { /* b */
1549             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1550         } else { /* a */
1551             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1552         }
1553         XSRETURN_YES;
1554
1555 void
1556 rmagical_flags(sv)
1557     SV *sv;
1558     PPCODE:
1559         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1560         sv = SvRV(sv);
1561         EXTEND(SP, 3);
1562         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1563         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1564         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1565         XSRETURN(3);
1566
1567 void
1568 my_caller(level)
1569         I32 level
1570     PREINIT:
1571         const PERL_CONTEXT *cx, *dbcx;
1572         const char *pv;
1573         const GV *gv;
1574         HV *hv;
1575     PPCODE:
1576         cx = caller_cx(level, &dbcx);
1577         EXTEND(SP, 8);
1578
1579         pv = CopSTASHPV(cx->blk_oldcop);
1580         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1581         gv = CvGV(cx->blk_sub.cv);
1582         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1583
1584         pv = CopSTASHPV(dbcx->blk_oldcop);
1585         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1586         gv = CvGV(dbcx->blk_sub.cv);
1587         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1588
1589         ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
1590         ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
1591         ST(6) = cop_hints_fetch_sv(cx->blk_oldcop,
1592                 sv_2mortal(newSVpvn("foo", 3)), 0, 0);
1593
1594         hv = cop_hints_2hv(cx->blk_oldcop, 0);
1595         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1596
1597         XSRETURN(8);
1598
1599 void
1600 DPeek (sv)
1601     SV   *sv
1602
1603   PPCODE:
1604     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1605     XSRETURN (1);
1606
1607 void
1608 BEGIN()
1609     CODE:
1610         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1611
1612 void
1613 CHECK()
1614     CODE:
1615         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1616
1617 void
1618 UNITCHECK()
1619     CODE:
1620         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1621
1622 void
1623 INIT()
1624     CODE:
1625         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1626
1627 void
1628 END()
1629     CODE:
1630         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1631
1632 void
1633 utf16_to_utf8 (sv, ...)
1634     SV* sv
1635         ALIAS:
1636             utf16_to_utf8_reversed = 1
1637     PREINIT:
1638         STRLEN len;
1639         U8 *source;
1640         SV *dest;
1641         I32 got; /* Gah, badly thought out APIs */
1642     CODE:
1643         source = (U8 *)SvPVbyte(sv, len);
1644         /* Optionally only convert part of the buffer.  */
1645         if (items > 1) {
1646             len = SvUV(ST(1));
1647         }
1648         /* Mortalise this right now, as we'll be testing croak()s  */
1649         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1650         if (ix) {
1651             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1652         } else {
1653             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1654         }
1655         SvCUR_set(dest, got);
1656         SvPVX(dest)[got] = '\0';
1657         SvPOK_on(dest);
1658         ST(0) = dest;
1659         XSRETURN(1);
1660
1661 void
1662 my_exit(int exitcode)
1663         PPCODE:
1664         my_exit(exitcode);
1665
1666 I32
1667 sv_count()
1668         CODE:
1669             RETVAL = PL_sv_count;
1670         OUTPUT:
1671             RETVAL
1672
1673 void
1674 bhk_record(bool on)
1675     CODE:
1676         dMY_CXT;
1677         MY_CXT.bhk_record = on;
1678         if (on)
1679             av_clear(MY_CXT.bhkav);
1680
1681 void
1682 test_magic_chain()
1683     PREINIT:
1684         SV *sv;
1685         MAGIC *callmg, *uvarmg;
1686     CODE:
1687         sv = sv_2mortal(newSV(0));
1688         if (SvTYPE(sv) >= SVt_PVMG) croak_fail();
1689         if (SvMAGICAL(sv)) croak_fail();
1690         sv_magic(sv, &PL_sv_yes, PERL_MAGIC_checkcall, (char*)&callmg, 0);
1691         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1692         if (!SvMAGICAL(sv)) croak_fail();
1693         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
1694         callmg = mg_find(sv, PERL_MAGIC_checkcall);
1695         if (!callmg) croak_fail();
1696         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1697             croak_fail();
1698         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
1699         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1700         if (!SvMAGICAL(sv)) croak_fail();
1701         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1702         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
1703         if (!uvarmg) croak_fail();
1704         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1705             croak_fail();
1706         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1707             croak_fail();
1708         mg_free_type(sv, PERL_MAGIC_vec);
1709         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1710         if (!SvMAGICAL(sv)) croak_fail();
1711         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1712         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
1713         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1714             croak_fail();
1715         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1716             croak_fail();
1717         mg_free_type(sv, PERL_MAGIC_uvar);
1718         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1719         if (!SvMAGICAL(sv)) croak_fail();
1720         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1721         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
1722         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1723             croak_fail();
1724         sv_magic(sv, &PL_sv_no, PERL_MAGIC_uvar, (char*)&uvarmg, 0);
1725         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1726         if (!SvMAGICAL(sv)) croak_fail();
1727         if (mg_find(sv, PERL_MAGIC_checkcall) != callmg) croak_fail();
1728         uvarmg = mg_find(sv, PERL_MAGIC_uvar);
1729         if (!uvarmg) croak_fail();
1730         if (callmg->mg_obj != &PL_sv_yes || callmg->mg_ptr != (char*)&callmg)
1731             croak_fail();
1732         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1733             croak_fail();
1734         mg_free_type(sv, PERL_MAGIC_checkcall);
1735         if (SvTYPE(sv) < SVt_PVMG) croak_fail();
1736         if (!SvMAGICAL(sv)) croak_fail();
1737         if (mg_find(sv, PERL_MAGIC_uvar) != uvarmg) croak_fail();
1738         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
1739         if (uvarmg->mg_obj != &PL_sv_no || uvarmg->mg_ptr != (char*)&uvarmg)
1740             croak_fail();
1741         mg_free_type(sv, PERL_MAGIC_uvar);
1742         if (SvMAGICAL(sv)) croak_fail();
1743         if (mg_find(sv, PERL_MAGIC_checkcall)) croak_fail();
1744         if (mg_find(sv, PERL_MAGIC_uvar)) croak_fail();
1745
1746 void
1747 test_op_contextualize()
1748     PREINIT:
1749         OP *o;
1750     CODE:
1751         o = newSVOP(OP_CONST, 0, newSViv(0));
1752         o->op_flags &= ~OPf_WANT;
1753         o = op_contextualize(o, G_SCALAR);
1754         if (o->op_type != OP_CONST ||
1755                 (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR)
1756             croak_fail();
1757         op_free(o);
1758         o = newSVOP(OP_CONST, 0, newSViv(0));
1759         o->op_flags &= ~OPf_WANT;
1760         o = op_contextualize(o, G_ARRAY);
1761         if (o->op_type != OP_CONST ||
1762                 (o->op_flags & OPf_WANT) != OPf_WANT_LIST)
1763             croak_fail();
1764         op_free(o);
1765         o = newSVOP(OP_CONST, 0, newSViv(0));
1766         o->op_flags &= ~OPf_WANT;
1767         o = op_contextualize(o, G_VOID);
1768         if (o->op_type != OP_NULL) croak_fail();
1769         op_free(o);
1770
1771 void
1772 test_rv2cv_op_cv()
1773     PROTOTYPE:
1774     PREINIT:
1775         GV *troc_gv, *wibble_gv;
1776         CV *troc_cv;
1777         OP *o;
1778     CODE:
1779         troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
1780         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1781         wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
1782         o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
1783         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
1784         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
1785             croak_fail();
1786         o->op_private |= OPpENTERSUB_AMPER;
1787         if (rv2cv_op_cv(o, 0)) croak_fail();
1788         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1789         o->op_private &= ~OPpENTERSUB_AMPER;
1790         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1791         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1792         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1793         op_free(o);
1794         o = newSVOP(OP_CONST, 0, newSVpv("XS::APItest::test_rv2cv_op_cv", 0));
1795         o->op_private = OPpCONST_BARE;
1796         o = newCVREF(0, o);
1797         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
1798         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
1799             croak_fail();
1800         o->op_private |= OPpENTERSUB_AMPER;
1801         if (rv2cv_op_cv(o, 0)) croak_fail();
1802         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1803         op_free(o);
1804         o = newCVREF(0, newSVOP(OP_CONST, 0, newRV_inc((SV*)troc_cv)));
1805         if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
1806         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
1807             croak_fail();
1808         o->op_private |= OPpENTERSUB_AMPER;
1809         if (rv2cv_op_cv(o, 0)) croak_fail();
1810         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1811         o->op_private &= ~OPpENTERSUB_AMPER;
1812         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1813         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY) != troc_cv) croak_fail();
1814         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1815         op_free(o);
1816         o = newCVREF(0, newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0))));
1817         if (rv2cv_op_cv(o, 0)) croak_fail();
1818         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1819         o->op_private |= OPpENTERSUB_AMPER;
1820         if (rv2cv_op_cv(o, 0)) croak_fail();
1821         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1822         o->op_private &= ~OPpENTERSUB_AMPER;
1823         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1824         if (rv2cv_op_cv(o, RV2CVOPCV_MARK_EARLY)) croak_fail();
1825         if (cUNOPx(o)->op_first->op_private & OPpEARLY_CV) croak_fail();
1826         op_free(o);
1827         o = newUNOP(OP_RAND, 0, newSVOP(OP_CONST, 0, newSViv(0)));
1828         if (rv2cv_op_cv(o, 0)) croak_fail();
1829         if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV)) croak_fail();
1830         op_free(o);
1831
1832 void
1833 test_cv_getset_call_checker()
1834     PREINIT:
1835         CV *troc_cv, *tsh_cv;
1836         Perl_call_checker ckfun;
1837         SV *ckobj;
1838     CODE:
1839 #define check_cc(cv, xckfun, xckobj) \
1840     do { \
1841         cv_get_call_checker((cv), &ckfun, &ckobj); \
1842         if (ckfun != (xckfun) || ckobj != (xckobj)) croak_fail(); \
1843     } while(0)
1844         troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
1845         tsh_cv = get_cv("XS::APItest::test_savehints", 0);
1846         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1847         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1848         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1849                                     &PL_sv_yes);
1850         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1851         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1852         cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1853         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1854         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
1855         cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list,
1856                                     (SV*)tsh_cv);
1857         check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
1858         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1859         cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list,
1860                                     (SV*)troc_cv);
1861         check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv);
1862         check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv);
1863         if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail();
1864         if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail();
1865 #undef check_cc
1866
1867 void
1868 cv_set_call_checker_lists(CV *cv)
1869     CODE:
1870         cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
1871
1872 void
1873 cv_set_call_checker_scalars(CV *cv)
1874     CODE:
1875         cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
1876
1877 void
1878 cv_set_call_checker_proto(CV *cv, SV *proto)
1879     CODE:
1880         if (SvROK(proto))
1881             proto = SvRV(proto);
1882         cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
1883
1884 void
1885 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
1886     CODE:
1887         if (SvROK(proto))
1888             proto = SvRV(proto);
1889         cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
1890
1891 void
1892 cv_set_call_checker_multi_sum(CV *cv)
1893     CODE:
1894         cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
1895
1896 void
1897 test_cophh()
1898     PREINIT:
1899         COPHH *a, *b;
1900     CODE:
1901 #define check_ph(EXPR) \
1902             do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0)
1903 #define check_iv(EXPR, EXPECT) \
1904             do { if(SvIV(EXPR) != (EXPECT)) croak("fail"); } while(0)
1905 #define msvpvs(STR) sv_2mortal(newSVpvs(STR))
1906 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
1907         a = cophh_new_empty();
1908         check_ph(cophh_fetch_pvn(a, "foo_1", 5, 0, 0));
1909         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
1910         check_ph(cophh_fetch_pv(a, "foo_1", 0, 0));
1911         check_ph(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0));
1912         a = cophh_store_pvn(a, "foo_1abc", 5, 0, msviv(111), 0);
1913         a = cophh_store_pvs(a, "foo_2", msviv(222), 0);
1914         a = cophh_store_pv(a, "foo_3", 0, msviv(333), 0);
1915         a = cophh_store_sv(a, msvpvs("foo_4"), 0, msviv(444), 0);
1916         check_iv(cophh_fetch_pvn(a, "foo_1xyz", 5, 0, 0), 111);
1917         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
1918         check_iv(cophh_fetch_pv(a, "foo_1", 0, 0), 111);
1919         check_iv(cophh_fetch_sv(a, msvpvs("foo_1"), 0, 0), 111);
1920         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
1921         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
1922         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
1923         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
1924         b = cophh_copy(a);
1925         b = cophh_store_pvs(b, "foo_1", msviv(1111), 0);
1926         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 111);
1927         check_iv(cophh_fetch_pvs(a, "foo_2", 0), 222);
1928         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
1929         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
1930         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
1931         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
1932         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
1933         check_iv(cophh_fetch_pvs(b, "foo_3", 0), 333);
1934         check_iv(cophh_fetch_pvs(b, "foo_4", 0), 444);
1935         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
1936         a = cophh_delete_pvn(a, "foo_1abc", 5, 0, 0);
1937         a = cophh_delete_pvs(a, "foo_2", 0);
1938         b = cophh_delete_pv(b, "foo_3", 0, 0);
1939         b = cophh_delete_sv(b, msvpvs("foo_4"), 0, 0);
1940         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
1941         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
1942         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
1943         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
1944         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
1945         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
1946         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
1947         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
1948         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
1949         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
1950         b = cophh_delete_pvs(b, "foo_3", 0);
1951         b = cophh_delete_pvs(b, "foo_5", 0);
1952         check_iv(cophh_fetch_pvs(b, "foo_1", 0), 1111);
1953         check_iv(cophh_fetch_pvs(b, "foo_2", 0), 222);
1954         check_ph(cophh_fetch_pvs(b, "foo_3", 0));
1955         check_ph(cophh_fetch_pvs(b, "foo_4", 0));
1956         check_ph(cophh_fetch_pvs(b, "foo_5", 0));
1957         cophh_free(b);
1958         check_ph(cophh_fetch_pvs(a, "foo_1", 0));
1959         check_ph(cophh_fetch_pvs(a, "foo_2", 0));
1960         check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333);
1961         check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444);
1962         check_ph(cophh_fetch_pvs(a, "foo_5", 0));
1963         a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8);
1964         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
1965         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
1966         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
1967         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
1968         check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111);
1969         check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111);
1970         check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123);
1971         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123);
1972         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0));
1973         check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456);
1974         check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456);
1975         check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0));
1976         check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789);
1977         check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789);
1978         check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
1979         check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
1980         check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
1981         cophh_free(a);
1982 #undef check_ph
1983 #undef check_iv
1984 #undef msvpvs
1985 #undef msviv
1986
1987 HV *
1988 example_cophh_2hv()
1989     PREINIT:
1990         COPHH *a;
1991     CODE:
1992 #define msviv(VALUE) sv_2mortal(newSViv(VALUE))
1993         a = cophh_new_empty();
1994         a = cophh_store_pvs(a, "foo_0", msviv(999), 0);
1995         a = cophh_store_pvs(a, "foo_1", msviv(111), 0);
1996         a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0);
1997         a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8);
1998         a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8);
1999         a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8);
2000         a = cophh_delete_pvs(a, "foo_0", 0);
2001         a = cophh_delete_pvs(a, "foo_2", 0);
2002         RETVAL = cophh_2hv(a, 0);
2003         cophh_free(a);
2004 #undef msviv
2005     OUTPUT:
2006         RETVAL
2007
2008 void
2009 test_savehints()
2010     PREINIT:
2011         SV **svp, *sv;
2012     CODE:
2013 #define store_hint(KEY, VALUE) \
2014                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
2015 #define hint_ok(KEY, EXPECT) \
2016                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
2017                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
2018                     (sv = cop_hints_fetch_pvs(&PL_compiling, KEY, 0)) && \
2019                     SvIV(sv) == (EXPECT))
2020 #define check_hint(KEY, EXPECT) \
2021                 do { if (!hint_ok(KEY, EXPECT)) croak_fail(); } while(0)
2022         PL_hints |= HINT_LOCALIZE_HH;
2023         ENTER;
2024         SAVEHINTS();
2025         PL_hints &= HINT_INTEGER;
2026         store_hint("t0", 123);
2027         store_hint("t1", 456);
2028         if (PL_hints & HINT_INTEGER) croak_fail();
2029         check_hint("t0", 123); check_hint("t1", 456);
2030         ENTER;
2031         SAVEHINTS();
2032         if (PL_hints & HINT_INTEGER) croak_fail();
2033         check_hint("t0", 123); check_hint("t1", 456);
2034         PL_hints |= HINT_INTEGER;
2035         store_hint("t0", 321);
2036         if (!(PL_hints & HINT_INTEGER)) croak_fail();
2037         check_hint("t0", 321); check_hint("t1", 456);
2038         LEAVE;
2039         if (PL_hints & HINT_INTEGER) croak_fail();
2040         check_hint("t0", 123); check_hint("t1", 456);
2041         ENTER;
2042         SAVEHINTS();
2043         if (PL_hints & HINT_INTEGER) croak_fail();
2044         check_hint("t0", 123); check_hint("t1", 456);
2045         store_hint("t1", 654);
2046         if (PL_hints & HINT_INTEGER) croak_fail();
2047         check_hint("t0", 123); check_hint("t1", 654);
2048         LEAVE;
2049         if (PL_hints & HINT_INTEGER) croak_fail();
2050         check_hint("t0", 123); check_hint("t1", 456);
2051         LEAVE;
2052 #undef store_hint
2053 #undef hint_ok
2054 #undef check_hint
2055
2056 void
2057 test_copyhints()
2058     PREINIT:
2059         HV *a, *b;
2060     CODE:
2061         PL_hints |= HINT_LOCALIZE_HH;
2062         ENTER;
2063         SAVEHINTS();
2064         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
2065         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
2066             croak_fail();
2067         a = newHVhv(GvHV(PL_hintgv));
2068         sv_2mortal((SV*)a);
2069         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
2070         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 123)
2071             croak_fail();
2072         b = hv_copy_hints_hv(a);
2073         sv_2mortal((SV*)b);
2074         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
2075         if (SvIV(cop_hints_fetch_pvs(&PL_compiling, "t0", 0)) != 789)
2076             croak_fail();
2077         LEAVE;
2078
2079 void
2080 test_op_list()
2081     PREINIT:
2082         OP *a;
2083     CODE:
2084 #define iv_op(iv) newSVOP(OP_CONST, 0, newSViv(iv))
2085 #define check_op(o, expect) \
2086     do { \
2087         if (strcmp(test_op_list_describe(o), (expect))) \
2088             croak("fail %s %s", test_op_list_describe(o), (expect)); \
2089     } while(0)
2090         a = op_append_elem(OP_LIST, NULL, NULL);
2091         check_op(a, "");
2092         a = op_append_elem(OP_LIST, iv_op(1), a);
2093         check_op(a, "const(1).");
2094         a = op_append_elem(OP_LIST, NULL, a);
2095         check_op(a, "const(1).");
2096         a = op_append_elem(OP_LIST, a, iv_op(2));
2097         check_op(a, "list[pushmark.const(1).const(2).]");
2098         a = op_append_elem(OP_LIST, a, iv_op(3));
2099         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2100         a = op_append_elem(OP_LIST, a, NULL);
2101         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2102         a = op_append_elem(OP_LIST, NULL, a);
2103         check_op(a, "list[pushmark.const(1).const(2).const(3).]");
2104         a = op_append_elem(OP_LIST, iv_op(4), a);
2105         check_op(a, "list[pushmark.const(4)."
2106                 "list[pushmark.const(1).const(2).const(3).]]");
2107         a = op_append_elem(OP_LIST, a, iv_op(5));
2108         check_op(a, "list[pushmark.const(4)."
2109                 "list[pushmark.const(1).const(2).const(3).]const(5).]");
2110         a = op_append_elem(OP_LIST, a,
2111                 op_append_elem(OP_LIST, iv_op(7), iv_op(6)));
2112         check_op(a, "list[pushmark.const(4)."
2113                 "list[pushmark.const(1).const(2).const(3).]const(5)."
2114                 "list[pushmark.const(7).const(6).]]");
2115         op_free(a);
2116         a = op_append_elem(OP_LINESEQ, iv_op(1), iv_op(2));
2117         check_op(a, "lineseq[const(1).const(2).]");
2118         a = op_append_elem(OP_LINESEQ, a, iv_op(3));
2119         check_op(a, "lineseq[const(1).const(2).const(3).]");
2120         op_free(a);
2121         a = op_append_elem(OP_LINESEQ,
2122                 op_append_elem(OP_LIST, iv_op(1), iv_op(2)),
2123                 iv_op(3));
2124         check_op(a, "lineseq[list[pushmark.const(1).const(2).]const(3).]");
2125         op_free(a);
2126         a = op_prepend_elem(OP_LIST, NULL, NULL);
2127         check_op(a, "");
2128         a = op_prepend_elem(OP_LIST, a, iv_op(1));
2129         check_op(a, "const(1).");
2130         a = op_prepend_elem(OP_LIST, a, NULL);
2131         check_op(a, "const(1).");
2132         a = op_prepend_elem(OP_LIST, iv_op(2), a);
2133         check_op(a, "list[pushmark.const(2).const(1).]");
2134         a = op_prepend_elem(OP_LIST, iv_op(3), a);
2135         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2136         a = op_prepend_elem(OP_LIST, NULL, a);
2137         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2138         a = op_prepend_elem(OP_LIST, a, NULL);
2139         check_op(a, "list[pushmark.const(3).const(2).const(1).]");
2140         a = op_prepend_elem(OP_LIST, a, iv_op(4));
2141         check_op(a, "list[pushmark."
2142                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2143         a = op_prepend_elem(OP_LIST, iv_op(5), a);
2144         check_op(a, "list[pushmark.const(5)."
2145                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2146         a = op_prepend_elem(OP_LIST,
2147                 op_prepend_elem(OP_LIST, iv_op(6), iv_op(7)), a);
2148         check_op(a, "list[pushmark.list[pushmark.const(6).const(7).]const(5)."
2149                 "list[pushmark.const(3).const(2).const(1).]const(4).]");
2150         op_free(a);
2151         a = op_prepend_elem(OP_LINESEQ, iv_op(2), iv_op(1));
2152         check_op(a, "lineseq[const(2).const(1).]");
2153         a = op_prepend_elem(OP_LINESEQ, iv_op(3), a);
2154         check_op(a, "lineseq[const(3).const(2).const(1).]");
2155         op_free(a);
2156         a = op_prepend_elem(OP_LINESEQ, iv_op(3),
2157                 op_prepend_elem(OP_LIST, iv_op(2), iv_op(1)));
2158         check_op(a, "lineseq[const(3).list[pushmark.const(2).const(1).]]");
2159         op_free(a);
2160         a = op_append_list(OP_LINESEQ, NULL, NULL);
2161         check_op(a, "");
2162         a = op_append_list(OP_LINESEQ, iv_op(1), a);
2163         check_op(a, "const(1).");
2164         a = op_append_list(OP_LINESEQ, NULL, a);
2165         check_op(a, "const(1).");
2166         a = op_append_list(OP_LINESEQ, a, iv_op(2));
2167         check_op(a, "lineseq[const(1).const(2).]");
2168         a = op_append_list(OP_LINESEQ, a, iv_op(3));
2169         check_op(a, "lineseq[const(1).const(2).const(3).]");
2170         a = op_append_list(OP_LINESEQ, iv_op(4), a);
2171         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2172         a = op_append_list(OP_LINESEQ, a, NULL);
2173         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2174         a = op_append_list(OP_LINESEQ, NULL, a);
2175         check_op(a, "lineseq[const(4).const(1).const(2).const(3).]");
2176         a = op_append_list(OP_LINESEQ, a,
2177                 op_append_list(OP_LINESEQ, iv_op(5), iv_op(6)));
2178         check_op(a, "lineseq[const(4).const(1).const(2).const(3)."
2179                 "const(5).const(6).]");
2180         op_free(a);
2181         a = op_append_list(OP_LINESEQ,
2182                 op_append_list(OP_LINESEQ, iv_op(1), iv_op(2)),
2183                 op_append_list(OP_LIST, iv_op(3), iv_op(4)));
2184         check_op(a, "lineseq[const(1).const(2)."
2185                 "list[pushmark.const(3).const(4).]]");
2186         op_free(a);
2187         a = op_append_list(OP_LINESEQ,
2188                 op_append_list(OP_LIST, iv_op(1), iv_op(2)),
2189                 op_append_list(OP_LINESEQ, iv_op(3), iv_op(4)));
2190         check_op(a, "lineseq[list[pushmark.const(1).const(2).]"
2191                 "const(3).const(4).]");
2192         op_free(a);
2193 #undef check_op
2194
2195 void
2196 test_op_linklist ()
2197     PREINIT:
2198         OP *o;
2199     CODE:
2200 #define check_ll(o, expect) \
2201     STMT_START { \
2202         if (strNE(test_op_linklist_describe(o), (expect))) \
2203             croak("fail %s %s", test_op_linklist_describe(o), (expect)); \
2204     } STMT_END
2205         o = iv_op(1);
2206         check_ll(o, ".const1");
2207         op_free(o);
2208
2209         o = mkUNOP(OP_NOT, iv_op(1));
2210         check_ll(o, ".const1.not");
2211         op_free(o);
2212
2213         o = mkUNOP(OP_NOT, mkUNOP(OP_NEGATE, iv_op(1)));
2214         check_ll(o, ".const1.negate.not");
2215         op_free(o);
2216
2217         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2218         check_ll(o, ".const1.const2.add");
2219         op_free(o);
2220
2221         o = mkBINOP(OP_ADD, mkUNOP(OP_NOT, iv_op(1)), iv_op(2));
2222         check_ll(o, ".const1.not.const2.add");
2223         op_free(o);
2224
2225         o = mkUNOP(OP_NOT, mkBINOP(OP_ADD, iv_op(1), iv_op(2)));
2226         check_ll(o, ".const1.const2.add.not");
2227         op_free(o);
2228
2229         o = mkLISTOP(OP_LINESEQ, iv_op(1), iv_op(2), iv_op(3));
2230         check_ll(o, ".const1.const2.const3.lineseq");
2231         op_free(o);
2232
2233         o = mkLISTOP(OP_LINESEQ,
2234                 mkBINOP(OP_ADD, iv_op(1), iv_op(2)),
2235                 mkUNOP(OP_NOT, iv_op(3)),
2236                 mkLISTOP(OP_SUBSTR, iv_op(4), iv_op(5), iv_op(6)));
2237         check_ll(o, ".const1.const2.add.const3.not"
2238                     ".const4.const5.const6.substr.lineseq");
2239         op_free(o);
2240
2241         o = mkBINOP(OP_ADD, iv_op(1), iv_op(2));
2242         LINKLIST(o);
2243         o = mkBINOP(OP_SUBTRACT, o, iv_op(3));
2244         check_ll(o, ".const1.const2.add.const3.subtract");
2245         op_free(o);
2246 #undef check_ll
2247 #undef iv_op
2248
2249 void
2250 peep_enable ()
2251     PREINIT:
2252         dMY_CXT;
2253     CODE:
2254         av_clear(MY_CXT.peep_recorder);
2255         av_clear(MY_CXT.rpeep_recorder);
2256         MY_CXT.peep_recording = 1;
2257
2258 void
2259 peep_disable ()
2260     PREINIT:
2261         dMY_CXT;
2262     CODE:
2263         MY_CXT.peep_recording = 0;
2264
2265 SV *
2266 peep_record ()
2267     PREINIT:
2268         dMY_CXT;
2269     CODE:
2270         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
2271     OUTPUT:
2272         RETVAL
2273
2274 SV *
2275 rpeep_record ()
2276     PREINIT:
2277         dMY_CXT;
2278     CODE:
2279         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
2280     OUTPUT:
2281         RETVAL
2282
2283 =pod
2284
2285 multicall_each: call a sub for each item in the list. Used to test MULTICALL
2286
2287 =cut
2288
2289 void
2290 multicall_each(block,...)
2291     SV * block
2292 PROTOTYPE: &@
2293 CODE:
2294 {
2295     dMULTICALL;
2296     int index;
2297     GV *gv;
2298     HV *stash;
2299     I32 gimme = G_SCALAR;
2300     SV **args = &PL_stack_base[ax];
2301     CV *cv;
2302
2303     if(items <= 1) {
2304         XSRETURN_UNDEF;
2305     }
2306     cv = sv_2cv(block, &stash, &gv, 0);
2307     if (cv == Nullcv) {
2308        croak("multicall_each: not a subroutine reference");
2309     }
2310     PUSH_MULTICALL(cv);
2311     SAVESPTR(GvSV(PL_defgv));
2312
2313     for(index = 1 ; index < items ; index++) {
2314         GvSV(PL_defgv) = args[index];
2315         MULTICALL;
2316     }
2317     POP_MULTICALL;
2318     XSRETURN_UNDEF;
2319 }
2320
2321
2322 BOOT:
2323         {
2324         HV* stash;
2325         SV** meth = NULL;
2326         CV* cv;
2327         stash = gv_stashpv("XS::APItest::TempLv", 0);
2328         if (stash)
2329             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
2330         if (!meth)
2331             croak("lost method 'make_temp_mg_lv'");
2332         cv = GvCV(*meth);
2333         CvLVALUE_on(cv);
2334         }
2335
2336 BOOT:
2337 {
2338     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
2339     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
2340     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
2341     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
2342     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
2343     hintkey_scopelessblock_sv = newSVpvs_share("XS::APItest/scopelessblock");
2344     hintkey_stmtasexpr_sv = newSVpvs_share("XS::APItest/stmtasexpr");
2345     hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
2346     hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
2347     hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
2348     next_keyword_plugin = PL_keyword_plugin;
2349     PL_keyword_plugin = my_keyword_plugin;
2350 }