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