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 /* for my_cxt tests */
  10
  11 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
  12
  13 typedef struct {
  14     int i;
  15     SV *sv;
  16     GV *cscgv;
  17     AV *cscav;
  18     AV *bhkav;
  19     bool bhk_record;
  20     peep_t orig_peep;
  21     peep_t orig_rpeep;
  22     int peep_recording;
  23     AV *peep_recorder;
  24     AV *rpeep_recorder;
  25 } my_cxt_t;
  26
  27 START_MY_CXT
  28
  29 /* indirect functions to test the [pa]MY_CXT macros */
  30
  31 int
  32 my_cxt_getint_p(pMY_CXT)
  33 {
  34     return MY_CXT.i;
  35 }
  36
  37 void
  38 my_cxt_setint_p(pMY_CXT_ int i)
  39 {
  40     MY_CXT.i = i;
  41 }
  42
  43 SV*
  44 my_cxt_getsv_interp_context(void)
  45 {
  46     dTHX;
  47     dMY_CXT_INTERP(my_perl);
  48     return MY_CXT.sv;
  49 }
  50
  51 SV*
  52 my_cxt_getsv_interp(void)
  53 {
  54     dMY_CXT;
  55     return MY_CXT.sv;
  56 }
  57
  58 void
  59 my_cxt_setsv_p(SV* sv _pMY_CXT)
  60 {
  61     MY_CXT.sv = sv;
  62 }
  63
  64
  65 /* from exception.c */
  66 int apitest_exception(int);
  67
  68 /* from core_or_not.inc */
  69 bool sv_setsv_cow_hashkey_core(void);
  70 bool sv_setsv_cow_hashkey_notcore(void);
  71
  72 /* A routine to test hv_delayfree_ent
  73    (which itself is tested by testing on hv_free_ent  */
  74
  75 typedef void (freeent_function)(pTHX_ HV *, register HE *);
  76
  77 void
  78 test_freeent(freeent_function *f) {
  79     dTHX;
  80     dSP;
  81     HV *test_hash = newHV();
  82     HE *victim;
  83     SV *test_scalar;
  84     U32 results[4];
  85     int i;
  86
  87 #ifdef PURIFY
  88     victim = (HE*)safemalloc(sizeof(HE));
  89 #else
  90     /* Storing then deleting something should ensure that a hash entry is
  91        available.  */
  92     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
  93     hv_delete(test_hash, "", 0, 0);
  94
  95     /* We need to "inline" new_he here as it's static, and the functions we
  96        test expect to be able to call del_HE on the HE  */
  97     if (!PL_body_roots[HE_SVSLOT])
  98         croak("PL_he_root is 0");
  99     victim = (HE*) PL_body_roots[HE_SVSLOT];
 100     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
 101 #endif
 102
 103     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
 104
 105     test_scalar = newSV(0);
 106     SvREFCNT_inc(test_scalar);
 107     HeVAL(victim) = test_scalar;
 108
 109     /* Need this little game else we free the temps on the return stack.  */
 110     results[0] = SvREFCNT(test_scalar);
 111     SAVETMPS;
 112     results[1] = SvREFCNT(test_scalar);
 113     f(aTHX_ test_hash, victim);
 114     results[2] = SvREFCNT(test_scalar);
 115     FREETMPS;
 116     results[3] = SvREFCNT(test_scalar);
 117
 118     i = 0;
 119     do {
 120         mPUSHu(results[i]);
 121     } while (++i < sizeof(results)/sizeof(results[0]));
 122
 123     /* Goodbye to our extra reference.  */
 124     SvREFCNT_dec(test_scalar);
 125 }
 126
 127
 128 static I32
 129 bitflip_key(pTHX_ IV action, SV *field) {
 130     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 131     SV *keysv;
 132     if (mg && (keysv = mg->mg_obj)) {
 133         STRLEN len;
 134         const char *p = SvPV(keysv, len);
 135
 136         if (len) {
 137             SV *newkey = newSV(len);
 138             char *new_p = SvPVX(newkey);
 139
 140             if (SvUTF8(keysv)) {
 141                 const char *const end = p + len;
 142                 while (p < end) {
 143                     STRLEN len;
 144                     UV chr = utf8_to_uvuni((U8 *)p, &len);
 145                     new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
 146                     p += len;
 147                 }
 148                 SvUTF8_on(newkey);
 149             } else {
 150                 while (len--)
 151                     *new_p++ = *p++ ^ 32;
 152             }
 153             *new_p = '\0';
 154             SvCUR_set(newkey, SvCUR(keysv));
 155             SvPOK_on(newkey);
 156
 157             mg->mg_obj = newkey;
 158         }
 159     }
 160     return 0;
 161 }
 162
 163 static I32
 164 rot13_key(pTHX_ IV action, SV *field) {
 165     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 166     SV *keysv;
 167     if (mg && (keysv = mg->mg_obj)) {
 168         STRLEN len;
 169         const char *p = SvPV(keysv, len);
 170
 171         if (len) {
 172             SV *newkey = newSV(len);
 173             char *new_p = SvPVX(newkey);
 174
 175             /* There's a deliberate fencepost error here to loop len + 1 times
 176                to copy the trailing \0  */
 177             do {
 178                 char new_c = *p++;
 179                 /* Try doing this cleanly and clearly in EBCDIC another way: */
 180                 switch (new_c) {
 181                 case 'A': new_c = 'N'; break;
 182                 case 'B': new_c = 'O'; break;
 183                 case 'C': new_c = 'P'; break;
 184                 case 'D': new_c = 'Q'; break;
 185                 case 'E': new_c = 'R'; break;
 186                 case 'F': new_c = 'S'; break;
 187                 case 'G': new_c = 'T'; break;
 188                 case 'H': new_c = 'U'; break;
 189                 case 'I': new_c = 'V'; break;
 190                 case 'J': new_c = 'W'; break;
 191                 case 'K': new_c = 'X'; break;
 192                 case 'L': new_c = 'Y'; break;
 193                 case 'M': new_c = 'Z'; break;
 194                 case 'N': new_c = 'A'; break;
 195                 case 'O': new_c = 'B'; break;
 196                 case 'P': new_c = 'C'; break;
 197                 case 'Q': new_c = 'D'; break;
 198                 case 'R': new_c = 'E'; break;
 199                 case 'S': new_c = 'F'; break;
 200                 case 'T': new_c = 'G'; break;
 201                 case 'U': new_c = 'H'; break;
 202                 case 'V': new_c = 'I'; break;
 203                 case 'W': new_c = 'J'; break;
 204                 case 'X': new_c = 'K'; break;
 205                 case 'Y': new_c = 'L'; break;
 206                 case 'Z': new_c = 'M'; break;
 207                 case 'a': new_c = 'n'; break;
 208                 case 'b': new_c = 'o'; break;
 209                 case 'c': new_c = 'p'; break;
 210                 case 'd': new_c = 'q'; break;
 211                 case 'e': new_c = 'r'; break;
 212                 case 'f': new_c = 's'; break;
 213                 case 'g': new_c = 't'; break;
 214                 case 'h': new_c = 'u'; break;
 215                 case 'i': new_c = 'v'; break;
 216                 case 'j': new_c = 'w'; break;
 217                 case 'k': new_c = 'x'; break;
 218                 case 'l': new_c = 'y'; break;
 219                 case 'm': new_c = 'z'; break;
 220                 case 'n': new_c = 'a'; break;
 221                 case 'o': new_c = 'b'; break;
 222                 case 'p': new_c = 'c'; break;
 223                 case 'q': new_c = 'd'; break;
 224                 case 'r': new_c = 'e'; break;
 225                 case 's': new_c = 'f'; break;
 226                 case 't': new_c = 'g'; break;
 227                 case 'u': new_c = 'h'; break;
 228                 case 'v': new_c = 'i'; break;
 229                 case 'w': new_c = 'j'; break;
 230                 case 'x': new_c = 'k'; break;
 231                 case 'y': new_c = 'l'; break;
 232                 case 'z': new_c = 'm'; break;
 233                 }
 234                 *new_p++ = new_c;
 235             } while (len--);
 236             SvCUR_set(newkey, SvCUR(keysv));
 237             SvPOK_on(newkey);
 238             if (SvUTF8(keysv))
 239                 SvUTF8_on(newkey);
 240
 241             mg->mg_obj = newkey;
 242         }
 243     }
 244     return 0;
 245 }
 246
 247 STATIC I32
 248 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
 249     return 0;
 250 }
 251
 252 STATIC MGVTBL rmagical_b = { 0 };
 253
 254 STATIC void
 255 blockhook_csc_start(pTHX_ int full)
 256 {
 257     dMY_CXT;
 258     AV *const cur = GvAV(MY_CXT.cscgv);
 259
 260     SAVEGENERICSV(GvAV(MY_CXT.cscgv));
 261
 262     if (cur) {
 263         I32 i;
 264         AV *const new_av = newAV();
 265
 266         for (i = 0; i <= av_len(cur); i++) {
 267             av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
 268         }
 269
 270         GvAV(MY_CXT.cscgv) = new_av;
 271     }
 272 }
 273
 274 STATIC void
 275 blockhook_csc_pre_end(pTHX_ OP **o)
 276 {
 277     dMY_CXT;
 278
 279     /* if we hit the end of a scope we missed the start of, we need to
 280      * unconditionally clear @CSC */
 281     if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
 282         av_clear(MY_CXT.cscav);
 283     }
 284
 285 }
 286
 287 STATIC void
 288 blockhook_test_start(pTHX_ int full)
 289 {
 290     dMY_CXT;
 291     AV *av;
 292
 293     if (MY_CXT.bhk_record) {
 294         av = newAV();
 295         av_push(av, newSVpvs("start"));
 296         av_push(av, newSViv(full));
 297         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 298     }
 299 }
 300
 301 STATIC void
 302 blockhook_test_pre_end(pTHX_ OP **o)
 303 {
 304     dMY_CXT;
 305
 306     if (MY_CXT.bhk_record)
 307         av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
 308 }
 309
 310 STATIC void
 311 blockhook_test_post_end(pTHX_ OP **o)
 312 {
 313     dMY_CXT;
 314
 315     if (MY_CXT.bhk_record)
 316         av_push(MY_CXT.bhkav, newSVpvs("post_end"));
 317 }
 318
 319 STATIC void
 320 blockhook_test_eval(pTHX_ OP *const o)
 321 {
 322     dMY_CXT;
 323     AV *av;
 324
 325     if (MY_CXT.bhk_record) {
 326         av = newAV();
 327         av_push(av, newSVpvs("eval"));
 328         av_push(av, newSVpv(OP_NAME(o), 0));
 329         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 330     }
 331 }
 332
 333 STATIC BHK bhk_csc, bhk_test;
 334
 335 STATIC void
 336 my_peep (pTHX_ OP *o)
 337 {
 338     dMY_CXT;
 339
 340     if (!o)
 341         return;
 342
 343     MY_CXT.orig_peep(aTHX_ o);
 344
 345     if (!MY_CXT.peep_recording)
 346         return;
 347
 348     for (; o; o = o->op_next) {
 349         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
 350             av_push(MY_CXT.peep_recorder, newSVsv(cSVOPx_sv(o)));
 351         }
 352     }
 353 }
 354
 355 STATIC void
 356 my_rpeep (pTHX_ OP *o)
 357 {
 358     dMY_CXT;
 359
 360     if (!o)
 361         return;
 362
 363     MY_CXT.orig_rpeep(aTHX_ o);
 364
 365     if (!MY_CXT.peep_recording)
 366         return;
 367
 368     for (; o; o = o->op_next) {
 369         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
 370             av_push(MY_CXT.rpeep_recorder, newSVsv(cSVOPx_sv(o)));
 371         }
 372     }
 373 }
 374
 375 /** RPN keyword parser **/
 376
 377 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
 378 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
 379 #define sv_is_string(sv) \
 380     (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
 381      (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
 382
 383 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv, *hintkey_stufftest_sv;
 384 static SV *hintkey_swaptwostmts_sv, *hintkey_looprest_sv;
 385 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
 386
 387 /* low-level parser helpers */
 388
 389 #define PL_bufptr (PL_parser->bufptr)
 390 #define PL_bufend (PL_parser->bufend)
 391
 392 /* RPN parser */
 393
 394 #define parse_var() THX_parse_var(aTHX)
 395 static OP *THX_parse_var(pTHX)
 396 {
 397     char *s = PL_bufptr;
 398     char *start = s;
 399     PADOFFSET varpos;
 400     OP *padop;
 401     if(*s != '$') croak("RPN syntax error");
 402     while(1) {
 403         char c = *++s;
 404         if(!isALNUM(c)) break;
 405     }
 406     if(s-start < 2) croak("RPN syntax error");
 407     lex_read_to(s);
 408     {
 409         /* because pad_findmy() doesn't really use length yet */
 410         SV *namesv = sv_2mortal(newSVpvn(start, s-start));
 411         varpos = pad_findmy(SvPVX(namesv), s-start, 0);
 412     }
 413     if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
 414         croak("RPN only supports \"my\" variables");
 415     padop = newOP(OP_PADSV, 0);
 416     padop->op_targ = varpos;
 417     return padop;
 418 }
 419
 420 #define push_rpn_item(o) \
 421     (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
 422 #define pop_rpn_item() \
 423     (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
 424      (tmpop = stack, stack = stack->op_sibling, \
 425       tmpop->op_sibling = NULL, tmpop))
 426
 427 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
 428 static OP *THX_parse_rpn_expr(pTHX)
 429 {
 430     OP *stack = NULL, *tmpop;
 431     while(1) {
 432         I32 c;
 433         lex_read_space(0);
 434         c = lex_peek_unichar(0);
 435         switch(c) {
 436             case /*(*/')': case /*{*/'}': {
 437                 OP *result = pop_rpn_item();
 438                 if(stack) croak("RPN expression must return a single value");
 439                 return result;
 440             } break;
 441             case '0': case '1': case '2': case '3': case '4':
 442             case '5': case '6': case '7': case '8': case '9': {
 443                 UV val = 0;
 444                 do {
 445                     lex_read_unichar(0);
 446                     val = 10*val + (c - '0');
 447                     c = lex_peek_unichar(0);
 448                 } while(c >= '0' && c <= '9');
 449                 push_rpn_item(newSVOP(OP_CONST, 0, newSVuv(val)));
 450             } break;
 451             case '$': {
 452                 push_rpn_item(parse_var());
 453             } break;
 454             case '+': {
 455                 OP *b = pop_rpn_item();
 456                 OP *a = pop_rpn_item();
 457                 lex_read_unichar(0);
 458                 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
 459             } break;
 460             case '-': {
 461                 OP *b = pop_rpn_item();
 462                 OP *a = pop_rpn_item();
 463                 lex_read_unichar(0);
 464                 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
 465             } break;
 466             case '*': {
 467                 OP *b = pop_rpn_item();
 468                 OP *a = pop_rpn_item();
 469                 lex_read_unichar(0);
 470                 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
 471             } break;
 472             case '/': {
 473                 OP *b = pop_rpn_item();
 474                 OP *a = pop_rpn_item();
 475                 lex_read_unichar(0);
 476                 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
 477             } break;
 478             case '%': {
 479                 OP *b = pop_rpn_item();
 480                 OP *a = pop_rpn_item();
 481                 lex_read_unichar(0);
 482                 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
 483             } break;
 484             default: {
 485                 croak("RPN syntax error");
 486             } break;
 487         }
 488     }
 489 }
 490
 491 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
 492 static OP *THX_parse_keyword_rpn(pTHX)
 493 {
 494     OP *op;
 495     lex_read_space(0);
 496     if(lex_peek_unichar(0) != '('/*)*/)
 497         croak("RPN expression must be parenthesised");
 498     lex_read_unichar(0);
 499     op = parse_rpn_expr();
 500     if(lex_peek_unichar(0) != /*(*/')')
 501         croak("RPN expression must be parenthesised");
 502     lex_read_unichar(0);
 503     return op;
 504 }
 505
 506 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
 507 static OP *THX_parse_keyword_calcrpn(pTHX)
 508 {
 509     OP *varop, *exprop;
 510     lex_read_space(0);
 511     varop = parse_var();
 512     lex_read_space(0);
 513     if(lex_peek_unichar(0) != '{'/*}*/)
 514         croak("RPN expression must be braced");
 515     lex_read_unichar(0);
 516     exprop = parse_rpn_expr();
 517     if(lex_peek_unichar(0) != /*{*/'}')
 518         croak("RPN expression must be braced");
 519     lex_read_unichar(0);
 520     return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
 521 }
 522
 523 #define parse_keyword_stufftest() THX_parse_keyword_stufftest(aTHX)
 524 static OP *THX_parse_keyword_stufftest(pTHX)
 525 {
 526     I32 c;
 527     bool do_stuff;
 528     lex_read_space(0);
 529     do_stuff = lex_peek_unichar(0) == '+';
 530     if(do_stuff) {
 531         lex_read_unichar(0);
 532         lex_read_space(0);
 533     }
 534     c = lex_peek_unichar(0);
 535     if(c == ';') {
 536         lex_read_unichar(0);
 537     } else if(c != /*{*/'}') {
 538         croak("syntax error");
 539     }
 540     if(do_stuff) lex_stuff_pvs(" ", 0);
 541     return newOP(OP_NULL, 0);
 542 }
 543
 544 #define parse_keyword_swaptwostmts() THX_parse_keyword_swaptwostmts(aTHX)
 545 static OP *THX_parse_keyword_swaptwostmts(pTHX)
 546 {
 547     OP *a, *b;
 548     a = parse_fullstmt(0);
 549     b = parse_fullstmt(0);
 550     if(a && b)
 551         PL_hints |= HINT_BLOCK_SCOPE;
 552     /* should use append_list(), but that's not part of the public API */
 553     return !a ? b : !b ? a : newLISTOP(OP_LINESEQ, 0, b, a);
 554 }
 555
 556 #define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
 557 static OP *THX_parse_keyword_looprest(pTHX)
 558 {
 559     I32 condline;
 560     OP *body;
 561     condline = CopLINE(PL_curcop);
 562     body = parse_stmtseq(0);
 563     return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
 564                         body, NULL, 1);
 565 }
 566
 567 /* plugin glue */
 568
 569 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
 570 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
 571 {
 572     HE *he;
 573     if(!GvHV(PL_hintgv)) return 0;
 574     he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
 575                 SvSHARED_HASH(hintkey_sv));
 576     return he && SvTRUE(HeVAL(he));
 577 }
 578
 579 static int my_keyword_plugin(pTHX_
 580     char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
 581 {
 582     if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
 583                     keyword_active(hintkey_rpn_sv)) {
 584         *op_ptr = parse_keyword_rpn();
 585         return KEYWORD_PLUGIN_EXPR;
 586     } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
 587                     keyword_active(hintkey_calcrpn_sv)) {
 588         *op_ptr = parse_keyword_calcrpn();
 589         return KEYWORD_PLUGIN_STMT;
 590     } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) &&
 591                     keyword_active(hintkey_stufftest_sv)) {
 592         *op_ptr = parse_keyword_stufftest();
 593         return KEYWORD_PLUGIN_STMT;
 594     } else if(keyword_len == 12 &&
 595                     strnEQ(keyword_ptr, "swaptwostmts", 12) &&
 596                     keyword_active(hintkey_swaptwostmts_sv)) {
 597         *op_ptr = parse_keyword_swaptwostmts();
 598         return KEYWORD_PLUGIN_STMT;
 599     } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) &&
 600                     keyword_active(hintkey_looprest_sv)) {
 601         *op_ptr = parse_keyword_looprest();
 602         return KEYWORD_PLUGIN_STMT;
 603     } else {
 604         return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
 605     }
 606 }
 607
 608 XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
 609
 610 #include "const-c.inc"
 611
 612 MODULE = XS::APItest            PACKAGE = XS::APItest
 613
 614 INCLUDE: const-xs.inc
 615
 616 INCLUDE: numeric.xs
 617
 618 MODULE = XS::APItest            PACKAGE = XS::APItest::XSUB
 619
 620 BOOT:
 621     newXS("XS::APItest::XSUB::XS_VERSION_undef", XS_XS__APItest__XSUB_XS_VERSION_undef, __FILE__);
 622
 623 void
 624 XS_VERSION_defined(...)
 625     PPCODE:
 626         XS_VERSION_BOOTCHECK;
 627         XSRETURN_EMPTY;
 628
 629 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
 630
 631 void
 632 rot13_hash(hash)
 633         HV *hash
 634         CODE:
 635         {
 636             struct ufuncs uf;
 637             uf.uf_val = rot13_key;
 638             uf.uf_set = 0;
 639             uf.uf_index = 0;
 640
 641             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
 642         }
 643
 644 void
 645 bitflip_hash(hash)
 646         HV *hash
 647         CODE:
 648         {
 649             struct ufuncs uf;
 650             uf.uf_val = bitflip_key;
 651             uf.uf_set = 0;
 652             uf.uf_index = 0;
 653
 654             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
 655         }
 656
 657 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
 658
 659 bool
 660 exists(hash, key_sv)
 661         PREINIT:
 662         STRLEN len;
 663         const char *key;
 664         INPUT:
 665         HV *hash
 666         SV *key_sv
 667         CODE:
 668         key = SvPV(key_sv, len);
 669         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
 670         OUTPUT:
 671         RETVAL
 672
 673 bool
 674 exists_ent(hash, key_sv)
 675         PREINIT:
 676         INPUT:
 677         HV *hash
 678         SV *key_sv
 679         CODE:
 680         RETVAL = hv_exists_ent(hash, key_sv, 0);
 681         OUTPUT:
 682         RETVAL
 683
 684 SV *
 685 delete(hash, key_sv, flags = 0)
 686         PREINIT:
 687         STRLEN len;
 688         const char *key;
 689         INPUT:
 690         HV *hash
 691         SV *key_sv
 692         I32 flags;
 693         CODE:
 694         key = SvPV(key_sv, len);
 695         /* It's already mortal, so need to increase reference count.  */
 696         RETVAL
 697             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
 698         OUTPUT:
 699         RETVAL
 700
 701 SV *
 702 delete_ent(hash, key_sv, flags = 0)
 703         INPUT:
 704         HV *hash
 705         SV *key_sv
 706         I32 flags;
 707         CODE:
 708         /* It's already mortal, so need to increase reference count.  */
 709         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
 710         OUTPUT:
 711         RETVAL
 712
 713 SV *
 714 store_ent(hash, key, value)
 715         PREINIT:
 716         SV *copy;
 717         HE *result;
 718         INPUT:
 719         HV *hash
 720         SV *key
 721         SV *value
 722         CODE:
 723         copy = newSV(0);
 724         result = hv_store_ent(hash, key, copy, 0);
 725         SvSetMagicSV(copy, value);
 726         if (!result) {
 727             SvREFCNT_dec(copy);
 728             XSRETURN_EMPTY;
 729         }
 730         /* It's about to become mortal, so need to increase reference count.
 731          */
 732         RETVAL = SvREFCNT_inc(HeVAL(result));
 733         OUTPUT:
 734         RETVAL
 735
 736 SV *
 737 store(hash, key_sv, value)
 738         PREINIT:
 739         STRLEN len;
 740         const char *key;
 741         SV *copy;
 742         SV **result;
 743         INPUT:
 744         HV *hash
 745         SV *key_sv
 746         SV *value
 747         CODE:
 748         key = SvPV(key_sv, len);
 749         copy = newSV(0);
 750         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
 751         SvSetMagicSV(copy, value);
 752         if (!result) {
 753             SvREFCNT_dec(copy);
 754             XSRETURN_EMPTY;
 755         }
 756         /* It's about to become mortal, so need to increase reference count.
 757          */
 758         RETVAL = SvREFCNT_inc(*result);
 759         OUTPUT:
 760         RETVAL
 761
 762 SV *
 763 fetch_ent(hash, key_sv)
 764         PREINIT:
 765         HE *result;
 766         INPUT:
 767         HV *hash
 768         SV *key_sv
 769         CODE:
 770         result = hv_fetch_ent(hash, key_sv, 0, 0);
 771         if (!result) {
 772             XSRETURN_EMPTY;
 773         }
 774         /* Force mg_get  */
 775         RETVAL = newSVsv(HeVAL(result));
 776         OUTPUT:
 777         RETVAL
 778
 779 SV *
 780 fetch(hash, key_sv)
 781         PREINIT:
 782         STRLEN len;
 783         const char *key;
 784         SV **result;
 785         INPUT:
 786         HV *hash
 787         SV *key_sv
 788         CODE:
 789         key = SvPV(key_sv, len);
 790         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
 791         if (!result) {
 792             XSRETURN_EMPTY;
 793         }
 794         /* Force mg_get  */
 795         RETVAL = newSVsv(*result);
 796         OUTPUT:
 797         RETVAL
 798
 799 #if defined (hv_common)
 800
 801 SV *
 802 common(params)
 803         INPUT:
 804         HV *params
 805         PREINIT:
 806         HE *result;
 807         HV *hv = NULL;
 808         SV *keysv = NULL;
 809         const char *key = NULL;
 810         STRLEN klen = 0;
 811         int flags = 0;
 812         int action = 0;
 813         SV *val = NULL;
 814         U32 hash = 0;
 815         SV **svp;
 816         CODE:
 817         if ((svp = hv_fetchs(params, "hv", 0))) {
 818             SV *const rv = *svp;
 819             if (!SvROK(rv))
 820                 croak("common passed a non-reference for parameter hv");
 821             hv = (HV *)SvRV(rv);
 822         }
 823         if ((svp = hv_fetchs(params, "keysv", 0)))
 824             keysv = *svp;
 825         if ((svp = hv_fetchs(params, "keypv", 0))) {
 826             key = SvPV_const(*svp, klen);
 827             if (SvUTF8(*svp))
 828                 flags = HVhek_UTF8;
 829         }
 830         if ((svp = hv_fetchs(params, "action", 0)))
 831             action = SvIV(*svp);
 832         if ((svp = hv_fetchs(params, "val", 0)))
 833             val = newSVsv(*svp);
 834         if ((svp = hv_fetchs(params, "hash", 0)))
 835             hash = SvUV(*svp);
 836
 837         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
 838             PERL_HASH(hash, key, klen);
 839         }
 840         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
 841             STRLEN len;
 842             const char *const p = SvPV(keysv, len);
 843             PERL_HASH(hash, p, len);
 844         }
 845
 846         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
 847         if (!result) {
 848             XSRETURN_EMPTY;
 849         }
 850         /* Force mg_get  */
 851         RETVAL = newSVsv(HeVAL(result));
 852         OUTPUT:
 853         RETVAL
 854
 855 #endif
 856
 857 void
 858 test_hv_free_ent()
 859         PPCODE:
 860         test_freeent(&Perl_hv_free_ent);
 861         XSRETURN(4);
 862
 863 void
 864 test_hv_delayfree_ent()
 865         PPCODE:
 866         test_freeent(&Perl_hv_delayfree_ent);
 867         XSRETURN(4);
 868
 869 SV *
 870 test_share_unshare_pvn(input)
 871         PREINIT:
 872         STRLEN len;
 873         U32 hash;
 874         char *pvx;
 875         char *p;
 876         INPUT:
 877         SV *input
 878         CODE:
 879         pvx = SvPV(input, len);
 880         PERL_HASH(hash, pvx, len);
 881         p = sharepvn(pvx, len, hash);
 882         RETVAL = newSVpvn(p, len);
 883         unsharepvn(p, len, hash);
 884         OUTPUT:
 885         RETVAL
 886
 887 #if PERL_VERSION >= 9
 888
 889 bool
 890 refcounted_he_exists(key, level=0)
 891         SV *key
 892         IV level
 893         CODE:
 894         if (level) {
 895             croak("level must be zero, not %"IVdf, level);
 896         }
 897         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 898                                            key, NULL, 0, 0, 0)
 899                   != &PL_sv_placeholder);
 900         OUTPUT:
 901         RETVAL
 902
 903 SV *
 904 refcounted_he_fetch(key, level=0)
 905         SV *key
 906         IV level
 907         CODE:
 908         if (level) {
 909             croak("level must be zero, not %"IVdf, level);
 910         }
 911         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
 912                                           NULL, 0, 0, 0);
 913         SvREFCNT_inc(RETVAL);
 914         OUTPUT:
 915         RETVAL
 916
 917 #endif
 918
 919 =pod
 920
 921 sub TIEHASH  { bless {}, $_[0] }
 922 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 923 sub FETCH    { $_[0]->{$_[1]} }
 924 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 925 sub NEXTKEY  { each %{$_[0]} }
 926 sub EXISTS   { exists $_[0]->{$_[1]} }
 927 sub DELETE   { delete $_[0]->{$_[1]} }
 928 sub CLEAR    { %{$_[0]} = () }
 929
 930 =cut
 931
 932 MODULE = XS::APItest:TempLv             PACKAGE = XS::APItest::TempLv
 933
 934 void
 935 make_temp_mg_lv(sv)
 936 SV* sv
 937     PREINIT:
 938         SV * const lv = newSV_type(SVt_PVLV);
 939         STRLEN len;
 940     PPCODE:
 941         SvPV(sv, len);
 942
 943         sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
 944         LvTYPE(lv) = 'x';
 945         LvTARG(lv) = SvREFCNT_inc_simple(sv);
 946         LvTARGOFF(lv) = len == 0 ? 0 : 1;
 947         LvTARGLEN(lv) = len < 2 ? 0 : len-2;
 948
 949         EXTEND(SP, 1);
 950         ST(0) = sv_2mortal(lv);
 951         XSRETURN(1);
 952
 953
 954 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
 955
 956 void
 957 ptr_table_new(classname)
 958 const char * classname
 959     PPCODE:
 960     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
 961
 962 void
 963 DESTROY(table)
 964 XS::APItest::PtrTable table
 965     CODE:
 966     ptr_table_free(table);
 967
 968 void
 969 ptr_table_store(table, from, to)
 970 XS::APItest::PtrTable table
 971 SVREF from
 972 SVREF to
 973    CODE:
 974    ptr_table_store(table, from, to);
 975
 976 UV
 977 ptr_table_fetch(table, from)
 978 XS::APItest::PtrTable table
 979 SVREF from
 980    CODE:
 981    RETVAL = PTR2UV(ptr_table_fetch(table, from));
 982    OUTPUT:
 983    RETVAL
 984
 985 void
 986 ptr_table_split(table)
 987 XS::APItest::PtrTable table
 988
 989 void
 990 ptr_table_clear(table)
 991 XS::APItest::PtrTable table
 992
 993 MODULE = XS::APItest            PACKAGE = XS::APItest
 994
 995 PROTOTYPES: DISABLE
 996
 997 BOOT:
 998 {
 999     MY_CXT_INIT;
1000
1001     MY_CXT.i  = 99;
1002     MY_CXT.sv = newSVpv("initial",0);
1003
1004     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1005     MY_CXT.bhk_record = 0;
1006
1007     BhkENTRY_set(&bhk_test, start, blockhook_test_start);
1008     BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
1009     BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
1010     BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
1011     Perl_blockhook_register(aTHX_ &bhk_test);
1012
1013     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1014         GV_ADDMULTI, SVt_PVAV);
1015     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
1016
1017     BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
1018     BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
1019     Perl_blockhook_register(aTHX_ &bhk_csc);
1020
1021     MY_CXT.peep_recorder = newAV();
1022     MY_CXT.rpeep_recorder = newAV();
1023
1024     MY_CXT.orig_peep = PL_peepp;
1025     MY_CXT.orig_rpeep = PL_rpeepp;
1026     PL_peepp = my_peep;
1027     PL_rpeepp = my_rpeep;
1028 }
1029
1030 void
1031 CLONE(...)
1032     CODE:
1033     MY_CXT_CLONE;
1034     MY_CXT.sv = newSVpv("initial_clone",0);
1035     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
1036         GV_ADDMULTI, SVt_PVAV);
1037     MY_CXT.cscav = NULL;
1038     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
1039     MY_CXT.bhk_record = 0;
1040     MY_CXT.peep_recorder = newAV();
1041     MY_CXT.rpeep_recorder = newAV();
1042
1043 void
1044 print_double(val)
1045         double val
1046         CODE:
1047         printf("%5.3f\n",val);
1048
1049 int
1050 have_long_double()
1051         CODE:
1052 #ifdef HAS_LONG_DOUBLE
1053         RETVAL = 1;
1054 #else
1055         RETVAL = 0;
1056 #endif
1057         OUTPUT:
1058         RETVAL
1059
1060 void
1061 print_long_double()
1062         CODE:
1063 #ifdef HAS_LONG_DOUBLE
1064 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
1065         long double val = 7.0;
1066         printf("%5.3" PERL_PRIfldbl "\n",val);
1067 #   else
1068         double val = 7.0;
1069         printf("%5.3f\n",val);
1070 #   endif
1071 #endif
1072
1073 void
1074 print_int(val)
1075         int val
1076         CODE:
1077         printf("%d\n",val);
1078
1079 void
1080 print_long(val)
1081         long val
1082         CODE:
1083         printf("%ld\n",val);
1084
1085 void
1086 print_float(val)
1087         float val
1088         CODE:
1089         printf("%5.3f\n",val);
1090
1091 void
1092 print_flush()
1093         CODE:
1094         fflush(stdout);
1095
1096 void
1097 mpushp()
1098         PPCODE:
1099         EXTEND(SP, 3);
1100         mPUSHp("one", 3);
1101         mPUSHp("two", 3);
1102         mPUSHp("three", 5);
1103         XSRETURN(3);
1104
1105 void
1106 mpushn()
1107         PPCODE:
1108         EXTEND(SP, 3);
1109         mPUSHn(0.5);
1110         mPUSHn(-0.25);
1111         mPUSHn(0.125);
1112         XSRETURN(3);
1113
1114 void
1115 mpushi()
1116         PPCODE:
1117         EXTEND(SP, 3);
1118         mPUSHi(-1);
1119         mPUSHi(2);
1120         mPUSHi(-3);
1121         XSRETURN(3);
1122
1123 void
1124 mpushu()
1125         PPCODE:
1126         EXTEND(SP, 3);
1127         mPUSHu(1);
1128         mPUSHu(2);
1129         mPUSHu(3);
1130         XSRETURN(3);
1131
1132 void
1133 mxpushp()
1134         PPCODE:
1135         mXPUSHp("one", 3);
1136         mXPUSHp("two", 3);
1137         mXPUSHp("three", 5);
1138         XSRETURN(3);
1139
1140 void
1141 mxpushn()
1142         PPCODE:
1143         mXPUSHn(0.5);
1144         mXPUSHn(-0.25);
1145         mXPUSHn(0.125);
1146         XSRETURN(3);
1147
1148 void
1149 mxpushi()
1150         PPCODE:
1151         mXPUSHi(-1);
1152         mXPUSHi(2);
1153         mXPUSHi(-3);
1154         XSRETURN(3);
1155
1156 void
1157 mxpushu()
1158         PPCODE:
1159         mXPUSHu(1);
1160         mXPUSHu(2);
1161         mXPUSHu(3);
1162         XSRETURN(3);
1163
1164
1165 void
1166 call_sv(sv, flags, ...)
1167     SV* sv
1168     I32 flags
1169     PREINIT:
1170         I32 i;
1171     PPCODE:
1172         for (i=0; i<items-2; i++)
1173             ST(i) = ST(i+2); /* pop first two args */
1174         PUSHMARK(SP);
1175         SP += items - 2;
1176         PUTBACK;
1177         i = call_sv(sv, flags);
1178         SPAGAIN;
1179         EXTEND(SP, 1);
1180         PUSHs(sv_2mortal(newSViv(i)));
1181
1182 void
1183 call_pv(subname, flags, ...)
1184     char* subname
1185     I32 flags
1186     PREINIT:
1187         I32 i;
1188     PPCODE:
1189         for (i=0; i<items-2; i++)
1190             ST(i) = ST(i+2); /* pop first two args */
1191         PUSHMARK(SP);
1192         SP += items - 2;
1193         PUTBACK;
1194         i = call_pv(subname, flags);
1195         SPAGAIN;
1196         EXTEND(SP, 1);
1197         PUSHs(sv_2mortal(newSViv(i)));
1198
1199 void
1200 call_method(methname, flags, ...)
1201     char* methname
1202     I32 flags
1203     PREINIT:
1204         I32 i;
1205     PPCODE:
1206         for (i=0; i<items-2; i++)
1207             ST(i) = ST(i+2); /* pop first two args */
1208         PUSHMARK(SP);
1209         SP += items - 2;
1210         PUTBACK;
1211         i = call_method(methname, flags);
1212         SPAGAIN;
1213         EXTEND(SP, 1);
1214         PUSHs(sv_2mortal(newSViv(i)));
1215
1216 void
1217 eval_sv(sv, flags)
1218     SV* sv
1219     I32 flags
1220     PREINIT:
1221         I32 i;
1222     PPCODE:
1223         PUTBACK;
1224         i = eval_sv(sv, flags);
1225         SPAGAIN;
1226         EXTEND(SP, 1);
1227         PUSHs(sv_2mortal(newSViv(i)));
1228
1229 void
1230 eval_pv(p, croak_on_error)
1231     const char* p
1232     I32 croak_on_error
1233     PPCODE:
1234         PUTBACK;
1235         EXTEND(SP, 1);
1236         PUSHs(eval_pv(p, croak_on_error));
1237
1238 void
1239 require_pv(pv)
1240     const char* pv
1241     PPCODE:
1242         PUTBACK;
1243         require_pv(pv);
1244
1245 int
1246 apitest_exception(throw_e)
1247     int throw_e
1248     OUTPUT:
1249         RETVAL
1250
1251 void
1252 mycroak(sv)
1253     SV* sv
1254     CODE:
1255     if (SvOK(sv)) {
1256         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
1257     }
1258     else {
1259         Perl_croak(aTHX_ NULL);
1260     }
1261
1262 SV*
1263 strtab()
1264    CODE:
1265    RETVAL = newRV_inc((SV*)PL_strtab);
1266    OUTPUT:
1267    RETVAL
1268
1269 int
1270 my_cxt_getint()
1271     CODE:
1272         dMY_CXT;
1273         RETVAL = my_cxt_getint_p(aMY_CXT);
1274     OUTPUT:
1275         RETVAL
1276
1277 void
1278 my_cxt_setint(i)
1279     int i;
1280     CODE:
1281         dMY_CXT;
1282         my_cxt_setint_p(aMY_CXT_ i);
1283
1284 void
1285 my_cxt_getsv(how)
1286     bool how;
1287     PPCODE:
1288         EXTEND(SP, 1);
1289         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
1290         XSRETURN(1);
1291
1292 void
1293 my_cxt_setsv(sv)
1294     SV *sv;
1295     CODE:
1296         dMY_CXT;
1297         SvREFCNT_dec(MY_CXT.sv);
1298         my_cxt_setsv_p(sv _aMY_CXT);
1299         SvREFCNT_inc(sv);
1300
1301 bool
1302 sv_setsv_cow_hashkey_core()
1303
1304 bool
1305 sv_setsv_cow_hashkey_notcore()
1306
1307 void
1308 rmagical_cast(sv, type)
1309     SV *sv;
1310     SV *type;
1311     PREINIT:
1312         struct ufuncs uf;
1313     PPCODE:
1314         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1315         sv = SvRV(sv);
1316         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1317         uf.uf_val = rmagical_a_dummy;
1318         uf.uf_set = NULL;
1319         uf.uf_index = 0;
1320         if (SvTRUE(type)) { /* b */
1321             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1322         } else { /* a */
1323             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1324         }
1325         XSRETURN_YES;
1326
1327 void
1328 rmagical_flags(sv)
1329     SV *sv;
1330     PPCODE:
1331         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1332         sv = SvRV(sv);
1333         EXTEND(SP, 3);
1334         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1335         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1336         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1337         XSRETURN(3);
1338
1339 void
1340 my_caller(level)
1341         I32 level
1342     PREINIT:
1343         const PERL_CONTEXT *cx, *dbcx;
1344         const char *pv;
1345         const GV *gv;
1346         HV *hv;
1347     PPCODE:
1348         cx = caller_cx(level, &dbcx);
1349         EXTEND(SP, 8);
1350
1351         pv = CopSTASHPV(cx->blk_oldcop);
1352         ST(0) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1353         gv = CvGV(cx->blk_sub.cv);
1354         ST(1) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1355
1356         pv = CopSTASHPV(dbcx->blk_oldcop);
1357         ST(2) = pv ? sv_2mortal(newSVpv(pv, 0)) : &PL_sv_undef;
1358         gv = CvGV(dbcx->blk_sub.cv);
1359         ST(3) = isGV(gv) ? sv_2mortal(newSVpv(GvNAME(gv), 0)) : &PL_sv_undef;
1360
1361         ST(4) = cop_hints_fetchpvs(cx->blk_oldcop, "foo");
1362         ST(5) = cop_hints_fetchpvn(cx->blk_oldcop, "foo", 3, 0, 0);
1363         ST(6) = cop_hints_fetchsv(cx->blk_oldcop,
1364                 sv_2mortal(newSVpvn("foo", 3)), 0);
1365
1366         hv = cop_hints_2hv(cx->blk_oldcop);
1367         ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
1368
1369         XSRETURN(8);
1370
1371 void
1372 DPeek (sv)
1373     SV   *sv
1374
1375   PPCODE:
1376     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1377     XSRETURN (1);
1378
1379 void
1380 BEGIN()
1381     CODE:
1382         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1383
1384 void
1385 CHECK()
1386     CODE:
1387         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1388
1389 void
1390 UNITCHECK()
1391     CODE:
1392         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1393
1394 void
1395 INIT()
1396     CODE:
1397         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1398
1399 void
1400 END()
1401     CODE:
1402         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1403
1404 void
1405 utf16_to_utf8 (sv, ...)
1406     SV* sv
1407         ALIAS:
1408             utf16_to_utf8_reversed = 1
1409     PREINIT:
1410         STRLEN len;
1411         U8 *source;
1412         SV *dest;
1413         I32 got; /* Gah, badly thought out APIs */
1414     CODE:
1415         source = (U8 *)SvPVbyte(sv, len);
1416         /* Optionally only convert part of the buffer.  */
1417         if (items > 1) {
1418             len = SvUV(ST(1));
1419         }
1420         /* Mortalise this right now, as we'll be testing croak()s  */
1421         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1422         if (ix) {
1423             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1424         } else {
1425             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1426         }
1427         SvCUR_set(dest, got);
1428         SvPVX(dest)[got] = '\0';
1429         SvPOK_on(dest);
1430         ST(0) = dest;
1431         XSRETURN(1);
1432
1433 void
1434 my_exit(int exitcode)
1435         PPCODE:
1436         my_exit(exitcode);
1437
1438 I32
1439 sv_count()
1440         CODE:
1441             RETVAL = PL_sv_count;
1442         OUTPUT:
1443             RETVAL
1444
1445 void
1446 bhk_record(bool on)
1447     CODE:
1448         dMY_CXT;
1449         MY_CXT.bhk_record = on;
1450         if (on)
1451             av_clear(MY_CXT.bhkav);
1452
1453 void
1454 test_savehints()
1455     PREINIT:
1456         SV **svp, *sv;
1457     CODE:
1458 #define store_hint(KEY, VALUE) \
1459                 sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
1460 #define hint_ok(KEY, EXPECT) \
1461                 ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
1462                     (sv = *svp) && SvIV(sv) == (EXPECT) && \
1463                     (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
1464                     SvIV(sv) == (EXPECT))
1465 #define check_hint(KEY, EXPECT) \
1466                 do { if (!hint_ok(KEY, EXPECT)) croak("fail"); } while(0)
1467         PL_hints |= HINT_LOCALIZE_HH;
1468         ENTER;
1469         SAVEHINTS();
1470         PL_hints &= HINT_INTEGER;
1471         store_hint("t0", 123);
1472         store_hint("t1", 456);
1473         if (PL_hints & HINT_INTEGER) croak("fail");
1474         check_hint("t0", 123); check_hint("t1", 456);
1475         ENTER;
1476         SAVEHINTS();
1477         if (PL_hints & HINT_INTEGER) croak("fail");
1478         check_hint("t0", 123); check_hint("t1", 456);
1479         PL_hints |= HINT_INTEGER;
1480         store_hint("t0", 321);
1481         if (!(PL_hints & HINT_INTEGER)) croak("fail");
1482         check_hint("t0", 321); check_hint("t1", 456);
1483         LEAVE;
1484         if (PL_hints & HINT_INTEGER) croak("fail");
1485         check_hint("t0", 123); check_hint("t1", 456);
1486         ENTER;
1487         SAVEHINTS();
1488         if (PL_hints & HINT_INTEGER) croak("fail");
1489         check_hint("t0", 123); check_hint("t1", 456);
1490         store_hint("t1", 654);
1491         if (PL_hints & HINT_INTEGER) croak("fail");
1492         check_hint("t0", 123); check_hint("t1", 654);
1493         LEAVE;
1494         if (PL_hints & HINT_INTEGER) croak("fail");
1495         check_hint("t0", 123); check_hint("t1", 456);
1496         LEAVE;
1497 #undef store_hint
1498 #undef hint_ok
1499 #undef check_hint
1500
1501 void
1502 test_copyhints()
1503     PREINIT:
1504         HV *a, *b;
1505     CODE:
1506         PL_hints |= HINT_LOCALIZE_HH;
1507         ENTER;
1508         SAVEHINTS();
1509         sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
1510         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1511         a = newHVhv(GvHV(PL_hintgv));
1512         sv_2mortal((SV*)a);
1513         sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
1514         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
1515         b = hv_copy_hints_hv(a);
1516         sv_2mortal((SV*)b);
1517         sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
1518         if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak("fail");
1519         LEAVE;
1520
1521 void
1522 peep_enable ()
1523     PREINIT:
1524         dMY_CXT;
1525     CODE:
1526         av_clear(MY_CXT.peep_recorder);
1527         av_clear(MY_CXT.rpeep_recorder);
1528         MY_CXT.peep_recording = 1;
1529
1530 void
1531 peep_disable ()
1532     PREINIT:
1533         dMY_CXT;
1534     CODE:
1535         MY_CXT.peep_recording = 0;
1536
1537 SV *
1538 peep_record ()
1539     PREINIT:
1540         dMY_CXT;
1541     CODE:
1542         RETVAL = newRV_inc((SV *)MY_CXT.peep_recorder);
1543     OUTPUT:
1544         RETVAL
1545
1546 SV *
1547 rpeep_record ()
1548     PREINIT:
1549         dMY_CXT;
1550     CODE:
1551         RETVAL = newRV_inc((SV *)MY_CXT.rpeep_recorder);
1552     OUTPUT:
1553         RETVAL
1554
1555 BOOT:
1556         {
1557         HV* stash;
1558         SV** meth = NULL;
1559         CV* cv;
1560         stash = gv_stashpv("XS::APItest::TempLv", 0);
1561         if (stash)
1562             meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
1563         if (!meth)
1564             croak("lost method 'make_temp_mg_lv'");
1565         cv = GvCV(*meth);
1566         CvLVALUE_on(cv);
1567         }
1568
1569 BOOT:
1570 {
1571     hintkey_rpn_sv = newSVpvs_share("XS::APItest/rpn");
1572     hintkey_calcrpn_sv = newSVpvs_share("XS::APItest/calcrpn");
1573     hintkey_stufftest_sv = newSVpvs_share("XS::APItest/stufftest");
1574     hintkey_swaptwostmts_sv = newSVpvs_share("XS::APItest/swaptwostmts");
1575     hintkey_looprest_sv = newSVpvs_share("XS::APItest/looprest");
1576     next_keyword_plugin = PL_keyword_plugin;
1577     PL_keyword_plugin = my_keyword_plugin;
1578 }