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     AV *peep_record;
  22 } my_cxt_t;
  23
  24 START_MY_CXT
  25
  26 /* indirect functions to test the [pa]MY_CXT macros */
  27
  28 int
  29 my_cxt_getint_p(pMY_CXT)
  30 {
  31     return MY_CXT.i;
  32 }
  33
  34 void
  35 my_cxt_setint_p(pMY_CXT_ int i)
  36 {
  37     MY_CXT.i = i;
  38 }
  39
  40 SV*
  41 my_cxt_getsv_interp_context(void)
  42 {
  43     dTHX;
  44     dMY_CXT_INTERP(my_perl);
  45     return MY_CXT.sv;
  46 }
  47
  48 SV*
  49 my_cxt_getsv_interp(void)
  50 {
  51     dMY_CXT;
  52     return MY_CXT.sv;
  53 }
  54
  55 void
  56 my_cxt_setsv_p(SV* sv _pMY_CXT)
  57 {
  58     MY_CXT.sv = sv;
  59 }
  60
  61
  62 /* from exception.c */
  63 int apitest_exception(int);
  64
  65 /* from core_or_not.inc */
  66 bool sv_setsv_cow_hashkey_core(void);
  67 bool sv_setsv_cow_hashkey_notcore(void);
  68
  69 /* A routine to test hv_delayfree_ent
  70    (which itself is tested by testing on hv_free_ent  */
  71
  72 typedef void (freeent_function)(pTHX_ HV *, register HE *);
  73
  74 void
  75 test_freeent(freeent_function *f) {
  76     dTHX;
  77     dSP;
  78     HV *test_hash = newHV();
  79     HE *victim;
  80     SV *test_scalar;
  81     U32 results[4];
  82     int i;
  83
  84 #ifdef PURIFY
  85     victim = (HE*)safemalloc(sizeof(HE));
  86 #else
  87     /* Storing then deleting something should ensure that a hash entry is
  88        available.  */
  89     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
  90     hv_delete(test_hash, "", 0, 0);
  91
  92     /* We need to "inline" new_he here as it's static, and the functions we
  93        test expect to be able to call del_HE on the HE  */
  94     if (!PL_body_roots[HE_SVSLOT])
  95         croak("PL_he_root is 0");
  96     victim = (HE*) PL_body_roots[HE_SVSLOT];
  97     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
  98 #endif
  99
 100     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
 101
 102     test_scalar = newSV(0);
 103     SvREFCNT_inc(test_scalar);
 104     HeVAL(victim) = test_scalar;
 105
 106     /* Need this little game else we free the temps on the return stack.  */
 107     results[0] = SvREFCNT(test_scalar);
 108     SAVETMPS;
 109     results[1] = SvREFCNT(test_scalar);
 110     f(aTHX_ test_hash, victim);
 111     results[2] = SvREFCNT(test_scalar);
 112     FREETMPS;
 113     results[3] = SvREFCNT(test_scalar);
 114
 115     i = 0;
 116     do {
 117         mPUSHu(results[i]);
 118     } while (++i < sizeof(results)/sizeof(results[0]));
 119
 120     /* Goodbye to our extra reference.  */
 121     SvREFCNT_dec(test_scalar);
 122 }
 123
 124
 125 static I32
 126 bitflip_key(pTHX_ IV action, SV *field) {
 127     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 128     SV *keysv;
 129     if (mg && (keysv = mg->mg_obj)) {
 130         STRLEN len;
 131         const char *p = SvPV(keysv, len);
 132
 133         if (len) {
 134             SV *newkey = newSV(len);
 135             char *new_p = SvPVX(newkey);
 136
 137             if (SvUTF8(keysv)) {
 138                 const char *const end = p + len;
 139                 while (p < end) {
 140                     STRLEN len;
 141                     UV chr = utf8_to_uvuni((U8 *)p, &len);
 142                     new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
 143                     p += len;
 144                 }
 145                 SvUTF8_on(newkey);
 146             } else {
 147                 while (len--)
 148                     *new_p++ = *p++ ^ 32;
 149             }
 150             *new_p = '\0';
 151             SvCUR_set(newkey, SvCUR(keysv));
 152             SvPOK_on(newkey);
 153
 154             mg->mg_obj = newkey;
 155         }
 156     }
 157     return 0;
 158 }
 159
 160 static I32
 161 rot13_key(pTHX_ IV action, SV *field) {
 162     MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
 163     SV *keysv;
 164     if (mg && (keysv = mg->mg_obj)) {
 165         STRLEN len;
 166         const char *p = SvPV(keysv, len);
 167
 168         if (len) {
 169             SV *newkey = newSV(len);
 170             char *new_p = SvPVX(newkey);
 171
 172             /* There's a deliberate fencepost error here to loop len + 1 times
 173                to copy the trailing \0  */
 174             do {
 175                 char new_c = *p++;
 176                 /* Try doing this cleanly and clearly in EBCDIC another way: */
 177                 switch (new_c) {
 178                 case 'A': new_c = 'N'; break;
 179                 case 'B': new_c = 'O'; break;
 180                 case 'C': new_c = 'P'; break;
 181                 case 'D': new_c = 'Q'; break;
 182                 case 'E': new_c = 'R'; break;
 183                 case 'F': new_c = 'S'; break;
 184                 case 'G': new_c = 'T'; break;
 185                 case 'H': new_c = 'U'; break;
 186                 case 'I': new_c = 'V'; break;
 187                 case 'J': new_c = 'W'; break;
 188                 case 'K': new_c = 'X'; break;
 189                 case 'L': new_c = 'Y'; break;
 190                 case 'M': new_c = 'Z'; break;
 191                 case 'N': new_c = 'A'; break;
 192                 case 'O': new_c = 'B'; break;
 193                 case 'P': new_c = 'C'; break;
 194                 case 'Q': new_c = 'D'; break;
 195                 case 'R': new_c = 'E'; break;
 196                 case 'S': new_c = 'F'; break;
 197                 case 'T': new_c = 'G'; break;
 198                 case 'U': new_c = 'H'; break;
 199                 case 'V': new_c = 'I'; break;
 200                 case 'W': new_c = 'J'; break;
 201                 case 'X': new_c = 'K'; break;
 202                 case 'Y': new_c = 'L'; break;
 203                 case 'Z': new_c = 'M'; break;
 204                 case 'a': new_c = 'n'; break;
 205                 case 'b': new_c = 'o'; break;
 206                 case 'c': new_c = 'p'; break;
 207                 case 'd': new_c = 'q'; break;
 208                 case 'e': new_c = 'r'; break;
 209                 case 'f': new_c = 's'; break;
 210                 case 'g': new_c = 't'; break;
 211                 case 'h': new_c = 'u'; break;
 212                 case 'i': new_c = 'v'; break;
 213                 case 'j': new_c = 'w'; break;
 214                 case 'k': new_c = 'x'; break;
 215                 case 'l': new_c = 'y'; break;
 216                 case 'm': new_c = 'z'; break;
 217                 case 'n': new_c = 'a'; break;
 218                 case 'o': new_c = 'b'; break;
 219                 case 'p': new_c = 'c'; break;
 220                 case 'q': new_c = 'd'; break;
 221                 case 'r': new_c = 'e'; break;
 222                 case 's': new_c = 'f'; break;
 223                 case 't': new_c = 'g'; break;
 224                 case 'u': new_c = 'h'; break;
 225                 case 'v': new_c = 'i'; break;
 226                 case 'w': new_c = 'j'; break;
 227                 case 'x': new_c = 'k'; break;
 228                 case 'y': new_c = 'l'; break;
 229                 case 'z': new_c = 'm'; break;
 230                 }
 231                 *new_p++ = new_c;
 232             } while (len--);
 233             SvCUR_set(newkey, SvCUR(keysv));
 234             SvPOK_on(newkey);
 235             if (SvUTF8(keysv))
 236                 SvUTF8_on(newkey);
 237
 238             mg->mg_obj = newkey;
 239         }
 240     }
 241     return 0;
 242 }
 243
 244 STATIC I32
 245 rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
 246     return 0;
 247 }
 248
 249 STATIC MGVTBL rmagical_b = { 0 };
 250
 251 STATIC void
 252 blockhook_csc_start(pTHX_ int full)
 253 {
 254     dMY_CXT;
 255     AV *const cur = GvAV(MY_CXT.cscgv);
 256
 257     SAVEGENERICSV(GvAV(MY_CXT.cscgv));
 258
 259     if (cur) {
 260         I32 i;
 261         AV *const new_av = newAV();
 262
 263         for (i = 0; i <= av_len(cur); i++) {
 264             av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
 265         }
 266
 267         GvAV(MY_CXT.cscgv) = new_av;
 268     }
 269 }
 270
 271 STATIC void
 272 blockhook_csc_pre_end(pTHX_ OP **o)
 273 {
 274     dMY_CXT;
 275
 276     /* if we hit the end of a scope we missed the start of, we need to
 277      * unconditionally clear @CSC */
 278     if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
 279         av_clear(MY_CXT.cscav);
 280     }
 281
 282 }
 283
 284 STATIC void
 285 blockhook_test_start(pTHX_ int full)
 286 {
 287     dMY_CXT;
 288     AV *av;
 289
 290     if (MY_CXT.bhk_record) {
 291         av = newAV();
 292         av_push(av, newSVpvs("start"));
 293         av_push(av, newSViv(full));
 294         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 295     }
 296 }
 297
 298 STATIC void
 299 blockhook_test_pre_end(pTHX_ OP **o)
 300 {
 301     dMY_CXT;
 302
 303     if (MY_CXT.bhk_record)
 304         av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
 305 }
 306
 307 STATIC void
 308 blockhook_test_post_end(pTHX_ OP **o)
 309 {
 310     dMY_CXT;
 311
 312     if (MY_CXT.bhk_record)
 313         av_push(MY_CXT.bhkav, newSVpvs("post_end"));
 314 }
 315
 316 STATIC void
 317 blockhook_test_eval(pTHX_ OP *const o)
 318 {
 319     dMY_CXT;
 320     AV *av;
 321
 322     if (MY_CXT.bhk_record) {
 323         av = newAV();
 324         av_push(av, newSVpvs("eval"));
 325         av_push(av, newSVpv(OP_NAME(o), 0));
 326         av_push(MY_CXT.bhkav, newRV_noinc(MUTABLE_SV(av)));
 327     }
 328 }
 329
 330 STATIC BHK bhk_csc, bhk_test;
 331
 332 STATIC void
 333 my_peep (pTHX_ OP *o, peep_next_t *next_peep)
 334 {
 335     dMY_CXT;
 336
 337     if (!o)
 338         return;
 339
 340     CALL_FPTR(MY_CXT.orig_peep)(aTHX_ o, next_peep);
 341
 342     for (; o; o = o->op_next) {
 343         if (o->op_type == OP_CONST && cSVOPx_sv(o) && SvPOK(cSVOPx_sv(o))) {
 344             av_push(MY_CXT.peep_record, newSVsv(cSVOPx_sv(o)));
 345         }
 346     }
 347 }
 348
 349 #include "const-c.inc"
 350
 351 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
 352
 353 INCLUDE: const-xs.inc
 354
 355 void
 356 rot13_hash(hash)
 357         HV *hash
 358         CODE:
 359         {
 360             struct ufuncs uf;
 361             uf.uf_val = rot13_key;
 362             uf.uf_set = 0;
 363             uf.uf_index = 0;
 364
 365             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
 366         }
 367
 368 void
 369 bitflip_hash(hash)
 370         HV *hash
 371         CODE:
 372         {
 373             struct ufuncs uf;
 374             uf.uf_val = bitflip_key;
 375             uf.uf_set = 0;
 376             uf.uf_index = 0;
 377
 378             sv_magic((SV*)hash, NULL, PERL_MAGIC_uvar, (char*)&uf, sizeof(uf));
 379         }
 380
 381 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
 382
 383 bool
 384 exists(hash, key_sv)
 385         PREINIT:
 386         STRLEN len;
 387         const char *key;
 388         INPUT:
 389         HV *hash
 390         SV *key_sv
 391         CODE:
 392         key = SvPV(key_sv, len);
 393         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
 394         OUTPUT:
 395         RETVAL
 396
 397 bool
 398 exists_ent(hash, key_sv)
 399         PREINIT:
 400         INPUT:
 401         HV *hash
 402         SV *key_sv
 403         CODE:
 404         RETVAL = hv_exists_ent(hash, key_sv, 0);
 405         OUTPUT:
 406         RETVAL
 407
 408 SV *
 409 delete(hash, key_sv, flags = 0)
 410         PREINIT:
 411         STRLEN len;
 412         const char *key;
 413         INPUT:
 414         HV *hash
 415         SV *key_sv
 416         I32 flags;
 417         CODE:
 418         key = SvPV(key_sv, len);
 419         /* It's already mortal, so need to increase reference count.  */
 420         RETVAL
 421             = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), flags));
 422         OUTPUT:
 423         RETVAL
 424
 425 SV *
 426 delete_ent(hash, key_sv, flags = 0)
 427         INPUT:
 428         HV *hash
 429         SV *key_sv
 430         I32 flags;
 431         CODE:
 432         /* It's already mortal, so need to increase reference count.  */
 433         RETVAL = SvREFCNT_inc(hv_delete_ent(hash, key_sv, flags, 0));
 434         OUTPUT:
 435         RETVAL
 436
 437 SV *
 438 store_ent(hash, key, value)
 439         PREINIT:
 440         SV *copy;
 441         HE *result;
 442         INPUT:
 443         HV *hash
 444         SV *key
 445         SV *value
 446         CODE:
 447         copy = newSV(0);
 448         result = hv_store_ent(hash, key, copy, 0);
 449         SvSetMagicSV(copy, value);
 450         if (!result) {
 451             SvREFCNT_dec(copy);
 452             XSRETURN_EMPTY;
 453         }
 454         /* It's about to become mortal, so need to increase reference count.
 455          */
 456         RETVAL = SvREFCNT_inc(HeVAL(result));
 457         OUTPUT:
 458         RETVAL
 459
 460 SV *
 461 store(hash, key_sv, value)
 462         PREINIT:
 463         STRLEN len;
 464         const char *key;
 465         SV *copy;
 466         SV **result;
 467         INPUT:
 468         HV *hash
 469         SV *key_sv
 470         SV *value
 471         CODE:
 472         key = SvPV(key_sv, len);
 473         copy = newSV(0);
 474         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
 475         SvSetMagicSV(copy, value);
 476         if (!result) {
 477             SvREFCNT_dec(copy);
 478             XSRETURN_EMPTY;
 479         }
 480         /* It's about to become mortal, so need to increase reference count.
 481          */
 482         RETVAL = SvREFCNT_inc(*result);
 483         OUTPUT:
 484         RETVAL
 485
 486 SV *
 487 fetch_ent(hash, key_sv)
 488         PREINIT:
 489         HE *result;
 490         INPUT:
 491         HV *hash
 492         SV *key_sv
 493         CODE:
 494         result = hv_fetch_ent(hash, key_sv, 0, 0);
 495         if (!result) {
 496             XSRETURN_EMPTY;
 497         }
 498         /* Force mg_get  */
 499         RETVAL = newSVsv(HeVAL(result));
 500         OUTPUT:
 501         RETVAL
 502
 503 SV *
 504 fetch(hash, key_sv)
 505         PREINIT:
 506         STRLEN len;
 507         const char *key;
 508         SV **result;
 509         INPUT:
 510         HV *hash
 511         SV *key_sv
 512         CODE:
 513         key = SvPV(key_sv, len);
 514         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
 515         if (!result) {
 516             XSRETURN_EMPTY;
 517         }
 518         /* Force mg_get  */
 519         RETVAL = newSVsv(*result);
 520         OUTPUT:
 521         RETVAL
 522
 523 #if defined (hv_common)
 524
 525 SV *
 526 common(params)
 527         INPUT:
 528         HV *params
 529         PREINIT:
 530         HE *result;
 531         HV *hv = NULL;
 532         SV *keysv = NULL;
 533         const char *key = NULL;
 534         STRLEN klen = 0;
 535         int flags = 0;
 536         int action = 0;
 537         SV *val = NULL;
 538         U32 hash = 0;
 539         SV **svp;
 540         CODE:
 541         if ((svp = hv_fetchs(params, "hv", 0))) {
 542             SV *const rv = *svp;
 543             if (!SvROK(rv))
 544                 croak("common passed a non-reference for parameter hv");
 545             hv = (HV *)SvRV(rv);
 546         }
 547         if ((svp = hv_fetchs(params, "keysv", 0)))
 548             keysv = *svp;
 549         if ((svp = hv_fetchs(params, "keypv", 0))) {
 550             key = SvPV_const(*svp, klen);
 551             if (SvUTF8(*svp))
 552                 flags = HVhek_UTF8;
 553         }
 554         if ((svp = hv_fetchs(params, "action", 0)))
 555             action = SvIV(*svp);
 556         if ((svp = hv_fetchs(params, "val", 0)))
 557             val = newSVsv(*svp);
 558         if ((svp = hv_fetchs(params, "hash", 0)))
 559             hash = SvUV(*svp);
 560
 561         if ((svp = hv_fetchs(params, "hash_pv", 0))) {
 562             PERL_HASH(hash, key, klen);
 563         }
 564         if ((svp = hv_fetchs(params, "hash_sv", 0))) {
 565             STRLEN len;
 566             const char *const p = SvPV(keysv, len);
 567             PERL_HASH(hash, p, len);
 568         }
 569
 570         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
 571         if (!result) {
 572             XSRETURN_EMPTY;
 573         }
 574         /* Force mg_get  */
 575         RETVAL = newSVsv(HeVAL(result));
 576         OUTPUT:
 577         RETVAL
 578
 579 #endif
 580
 581 void
 582 test_hv_free_ent()
 583         PPCODE:
 584         test_freeent(&Perl_hv_free_ent);
 585         XSRETURN(4);
 586
 587 void
 588 test_hv_delayfree_ent()
 589         PPCODE:
 590         test_freeent(&Perl_hv_delayfree_ent);
 591         XSRETURN(4);
 592
 593 SV *
 594 test_share_unshare_pvn(input)
 595         PREINIT:
 596         STRLEN len;
 597         U32 hash;
 598         char *pvx;
 599         char *p;
 600         INPUT:
 601         SV *input
 602         CODE:
 603         pvx = SvPV(input, len);
 604         PERL_HASH(hash, pvx, len);
 605         p = sharepvn(pvx, len, hash);
 606         RETVAL = newSVpvn(p, len);
 607         unsharepvn(p, len, hash);
 608         OUTPUT:
 609         RETVAL
 610
 611 #if PERL_VERSION >= 9
 612
 613 bool
 614 refcounted_he_exists(key, level=0)
 615         SV *key
 616         IV level
 617         CODE:
 618         if (level) {
 619             croak("level must be zero, not %"IVdf, level);
 620         }
 621         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 622                                            key, NULL, 0, 0, 0)
 623                   != &PL_sv_placeholder);
 624         OUTPUT:
 625         RETVAL
 626
 627 SV *
 628 refcounted_he_fetch(key, level=0)
 629         SV *key
 630         IV level
 631         CODE:
 632         if (level) {
 633             croak("level must be zero, not %"IVdf, level);
 634         }
 635         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
 636                                           NULL, 0, 0, 0);
 637         SvREFCNT_inc(RETVAL);
 638         OUTPUT:
 639         RETVAL
 640
 641 #endif
 642
 643 =pod
 644
 645 sub TIEHASH  { bless {}, $_[0] }
 646 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 647 sub FETCH    { $_[0]->{$_[1]} }
 648 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 649 sub NEXTKEY  { each %{$_[0]} }
 650 sub EXISTS   { exists $_[0]->{$_[1]} }
 651 sub DELETE   { delete $_[0]->{$_[1]} }
 652 sub CLEAR    { %{$_[0]} = () }
 653
 654 =cut
 655
 656 MODULE = XS::APItest::PtrTable  PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
 657
 658 void
 659 ptr_table_new(classname)
 660 const char * classname
 661     PPCODE:
 662     PUSHs(sv_setref_pv(sv_newmortal(), classname, (void*)ptr_table_new()));
 663
 664 void
 665 DESTROY(table)
 666 XS::APItest::PtrTable table
 667     CODE:
 668     ptr_table_free(table);
 669
 670 void
 671 ptr_table_store(table, from, to)
 672 XS::APItest::PtrTable table
 673 SVREF from
 674 SVREF to
 675    CODE:
 676    ptr_table_store(table, from, to);
 677
 678 UV
 679 ptr_table_fetch(table, from)
 680 XS::APItest::PtrTable table
 681 SVREF from
 682    CODE:
 683    RETVAL = PTR2UV(ptr_table_fetch(table, from));
 684    OUTPUT:
 685    RETVAL
 686
 687 void
 688 ptr_table_split(table)
 689 XS::APItest::PtrTable table
 690
 691 void
 692 ptr_table_clear(table)
 693 XS::APItest::PtrTable table
 694
 695 MODULE = XS::APItest            PACKAGE = XS::APItest
 696
 697 PROTOTYPES: DISABLE
 698
 699 BOOT:
 700 {
 701     MY_CXT_INIT;
 702
 703     MY_CXT.i  = 99;
 704     MY_CXT.sv = newSVpv("initial",0);
 705
 706     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
 707     MY_CXT.bhk_record = 0;
 708
 709     BhkENTRY_set(&bhk_test, start, blockhook_test_start);
 710     BhkENTRY_set(&bhk_test, pre_end, blockhook_test_pre_end);
 711     BhkENTRY_set(&bhk_test, post_end, blockhook_test_post_end);
 712     BhkENTRY_set(&bhk_test, eval, blockhook_test_eval);
 713     Perl_blockhook_register(aTHX_ &bhk_test);
 714
 715     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
 716         GV_ADDMULTI, SVt_PVAV);
 717     MY_CXT.cscav = GvAV(MY_CXT.cscgv);
 718
 719     BhkENTRY_set(&bhk_csc, start, blockhook_csc_start);
 720     BhkENTRY_set(&bhk_csc, pre_end, blockhook_csc_pre_end);
 721     Perl_blockhook_register(aTHX_ &bhk_csc);
 722
 723     MY_CXT.peep_record = newAV();
 724 }
 725
 726 void
 727 CLONE(...)
 728     CODE:
 729     MY_CXT_CLONE;
 730     MY_CXT.sv = newSVpv("initial_clone",0);
 731     MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
 732         GV_ADDMULTI, SVt_PVAV);
 733     MY_CXT.cscav = NULL;
 734     MY_CXT.bhkav = get_av("XS::APItest::bhkav", GV_ADDMULTI);
 735     MY_CXT.bhk_record = 0;
 736     MY_CXT.peep_record = newAV();
 737
 738 void
 739 print_double(val)
 740         double val
 741         CODE:
 742         printf("%5.3f\n",val);
 743
 744 int
 745 have_long_double()
 746         CODE:
 747 #ifdef HAS_LONG_DOUBLE
 748         RETVAL = 1;
 749 #else
 750         RETVAL = 0;
 751 #endif
 752         OUTPUT:
 753         RETVAL
 754
 755 void
 756 print_long_double()
 757         CODE:
 758 #ifdef HAS_LONG_DOUBLE
 759 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
 760         long double val = 7.0;
 761         printf("%5.3" PERL_PRIfldbl "\n",val);
 762 #   else
 763         double val = 7.0;
 764         printf("%5.3f\n",val);
 765 #   endif
 766 #endif
 767
 768 void
 769 print_int(val)
 770         int val
 771         CODE:
 772         printf("%d\n",val);
 773
 774 void
 775 print_long(val)
 776         long val
 777         CODE:
 778         printf("%ld\n",val);
 779
 780 void
 781 print_float(val)
 782         float val
 783         CODE:
 784         printf("%5.3f\n",val);
 785
 786 void
 787 print_flush()
 788         CODE:
 789         fflush(stdout);
 790
 791 void
 792 mpushp()
 793         PPCODE:
 794         EXTEND(SP, 3);
 795         mPUSHp("one", 3);
 796         mPUSHp("two", 3);
 797         mPUSHp("three", 5);
 798         XSRETURN(3);
 799
 800 void
 801 mpushn()
 802         PPCODE:
 803         EXTEND(SP, 3);
 804         mPUSHn(0.5);
 805         mPUSHn(-0.25);
 806         mPUSHn(0.125);
 807         XSRETURN(3);
 808
 809 void
 810 mpushi()
 811         PPCODE:
 812         EXTEND(SP, 3);
 813         mPUSHi(-1);
 814         mPUSHi(2);
 815         mPUSHi(-3);
 816         XSRETURN(3);
 817
 818 void
 819 mpushu()
 820         PPCODE:
 821         EXTEND(SP, 3);
 822         mPUSHu(1);
 823         mPUSHu(2);
 824         mPUSHu(3);
 825         XSRETURN(3);
 826
 827 void
 828 mxpushp()
 829         PPCODE:
 830         mXPUSHp("one", 3);
 831         mXPUSHp("two", 3);
 832         mXPUSHp("three", 5);
 833         XSRETURN(3);
 834
 835 void
 836 mxpushn()
 837         PPCODE:
 838         mXPUSHn(0.5);
 839         mXPUSHn(-0.25);
 840         mXPUSHn(0.125);
 841         XSRETURN(3);
 842
 843 void
 844 mxpushi()
 845         PPCODE:
 846         mXPUSHi(-1);
 847         mXPUSHi(2);
 848         mXPUSHi(-3);
 849         XSRETURN(3);
 850
 851 void
 852 mxpushu()
 853         PPCODE:
 854         mXPUSHu(1);
 855         mXPUSHu(2);
 856         mXPUSHu(3);
 857         XSRETURN(3);
 858
 859
 860 void
 861 call_sv(sv, flags, ...)
 862     SV* sv
 863     I32 flags
 864     PREINIT:
 865         I32 i;
 866     PPCODE:
 867         for (i=0; i<items-2; i++)
 868             ST(i) = ST(i+2); /* pop first two args */
 869         PUSHMARK(SP);
 870         SP += items - 2;
 871         PUTBACK;
 872         i = call_sv(sv, flags);
 873         SPAGAIN;
 874         EXTEND(SP, 1);
 875         PUSHs(sv_2mortal(newSViv(i)));
 876
 877 void
 878 call_pv(subname, flags, ...)
 879     char* subname
 880     I32 flags
 881     PREINIT:
 882         I32 i;
 883     PPCODE:
 884         for (i=0; i<items-2; i++)
 885             ST(i) = ST(i+2); /* pop first two args */
 886         PUSHMARK(SP);
 887         SP += items - 2;
 888         PUTBACK;
 889         i = call_pv(subname, flags);
 890         SPAGAIN;
 891         EXTEND(SP, 1);
 892         PUSHs(sv_2mortal(newSViv(i)));
 893
 894 void
 895 call_method(methname, flags, ...)
 896     char* methname
 897     I32 flags
 898     PREINIT:
 899         I32 i;
 900     PPCODE:
 901         for (i=0; i<items-2; i++)
 902             ST(i) = ST(i+2); /* pop first two args */
 903         PUSHMARK(SP);
 904         SP += items - 2;
 905         PUTBACK;
 906         i = call_method(methname, flags);
 907         SPAGAIN;
 908         EXTEND(SP, 1);
 909         PUSHs(sv_2mortal(newSViv(i)));
 910
 911 void
 912 eval_sv(sv, flags)
 913     SV* sv
 914     I32 flags
 915     PREINIT:
 916         I32 i;
 917     PPCODE:
 918         PUTBACK;
 919         i = eval_sv(sv, flags);
 920         SPAGAIN;
 921         EXTEND(SP, 1);
 922         PUSHs(sv_2mortal(newSViv(i)));
 923
 924 void
 925 eval_pv(p, croak_on_error)
 926     const char* p
 927     I32 croak_on_error
 928     PPCODE:
 929         PUTBACK;
 930         EXTEND(SP, 1);
 931         PUSHs(eval_pv(p, croak_on_error));
 932
 933 void
 934 require_pv(pv)
 935     const char* pv
 936     PPCODE:
 937         PUTBACK;
 938         require_pv(pv);
 939
 940 int
 941 apitest_exception(throw_e)
 942     int throw_e
 943     OUTPUT:
 944         RETVAL
 945
 946 void
 947 mycroak(sv)
 948     SV* sv
 949     CODE:
 950     if (SvOK(sv)) {
 951         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
 952     }
 953     else {
 954         Perl_croak(aTHX_ NULL);
 955     }
 956
 957 SV*
 958 strtab()
 959    CODE:
 960    RETVAL = newRV_inc((SV*)PL_strtab);
 961    OUTPUT:
 962    RETVAL
 963
 964 int
 965 my_cxt_getint()
 966     CODE:
 967         dMY_CXT;
 968         RETVAL = my_cxt_getint_p(aMY_CXT);
 969     OUTPUT:
 970         RETVAL
 971
 972 void
 973 my_cxt_setint(i)
 974     int i;
 975     CODE:
 976         dMY_CXT;
 977         my_cxt_setint_p(aMY_CXT_ i);
 978
 979 void
 980 my_cxt_getsv(how)
 981     bool how;
 982     PPCODE:
 983         EXTEND(SP, 1);
 984         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
 985         XSRETURN(1);
 986
 987 void
 988 my_cxt_setsv(sv)
 989     SV *sv;
 990     CODE:
 991         dMY_CXT;
 992         SvREFCNT_dec(MY_CXT.sv);
 993         my_cxt_setsv_p(sv _aMY_CXT);
 994         SvREFCNT_inc(sv);
 995
 996 bool
 997 sv_setsv_cow_hashkey_core()
 998
 999 bool
1000 sv_setsv_cow_hashkey_notcore()
1001
1002 void
1003 rmagical_cast(sv, type)
1004     SV *sv;
1005     SV *type;
1006     PREINIT:
1007         struct ufuncs uf;
1008     PPCODE:
1009         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
1010         sv = SvRV(sv);
1011         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
1012         uf.uf_val = rmagical_a_dummy;
1013         uf.uf_set = NULL;
1014         uf.uf_index = 0;
1015         if (SvTRUE(type)) { /* b */
1016             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
1017         } else { /* a */
1018             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
1019         }
1020         XSRETURN_YES;
1021
1022 void
1023 rmagical_flags(sv)
1024     SV *sv;
1025     PPCODE:
1026         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
1027         sv = SvRV(sv);
1028         EXTEND(SP, 3);
1029         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
1030         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
1031         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
1032         XSRETURN(3);
1033
1034 void
1035 DPeek (sv)
1036     SV   *sv
1037
1038   PPCODE:
1039     ST (0) = newSVpv (Perl_sv_peek (aTHX_ sv), 0);
1040     XSRETURN (1);
1041
1042 void
1043 BEGIN()
1044     CODE:
1045         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
1046
1047 void
1048 CHECK()
1049     CODE:
1050         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
1051
1052 void
1053 UNITCHECK()
1054     CODE:
1055         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
1056
1057 void
1058 INIT()
1059     CODE:
1060         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
1061
1062 void
1063 END()
1064     CODE:
1065         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));
1066
1067 void
1068 utf16_to_utf8 (sv, ...)
1069     SV* sv
1070         ALIAS:
1071             utf16_to_utf8_reversed = 1
1072     PREINIT:
1073         STRLEN len;
1074         U8 *source;
1075         SV *dest;
1076         I32 got; /* Gah, badly thought out APIs */
1077     CODE:
1078         source = (U8 *)SvPVbyte(sv, len);
1079         /* Optionally only convert part of the buffer.  */
1080         if (items > 1) {
1081             len = SvUV(ST(1));
1082         }
1083         /* Mortalise this right now, as we'll be testing croak()s  */
1084         dest = sv_2mortal(newSV(len * 3 / 2 + 1));
1085         if (ix) {
1086             utf16_to_utf8_reversed(source, (U8 *)SvPVX(dest), len, &got);
1087         } else {
1088             utf16_to_utf8(source, (U8 *)SvPVX(dest), len, &got);
1089         }
1090         SvCUR_set(dest, got);
1091         SvPVX(dest)[got] = '\0';
1092         SvPOK_on(dest);
1093         ST(0) = dest;
1094         XSRETURN(1);
1095
1096 void
1097 my_exit(int exitcode)
1098         PPCODE:
1099         my_exit(exitcode);
1100
1101 I32
1102 sv_count()
1103         CODE:
1104             RETVAL = PL_sv_count;
1105         OUTPUT:
1106             RETVAL
1107
1108 void
1109 bhk_record(bool on)
1110     CODE:
1111         dMY_CXT;
1112         MY_CXT.bhk_record = on;
1113         if (on)
1114             av_clear(MY_CXT.bhkav);
1115
1116 void
1117 peep_enable ()
1118     PREINIT:
1119         dMY_CXT;
1120     CODE:
1121         av_clear(MY_CXT.peep_record);
1122         MY_CXT.orig_peep = PL_peepp;
1123         PL_peepp = my_peep;
1124
1125 AV *
1126 peep_record ()
1127     PREINIT:
1128         dMY_CXT;
1129     CODE:
1130         RETVAL = MY_CXT.peep_record;
1131     OUTPUT:
1132         RETVAL
1133
1134 void
1135 peep_record_clear ()
1136     PREINIT:
1137         dMY_CXT;
1138     CODE:
1139         av_clear(MY_CXT.peep_record);