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