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