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