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 = *svp;
 452         if ((svp = hv_fetchs(params, "hash", 0)))
 453             action = SvUV(*svp);
 454
 455         result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
 456         if (!result) {
 457             XSRETURN_EMPTY;
 458         }
 459         /* Force mg_get  */
 460         RETVAL = newSVsv(HeVAL(result));
 461         OUTPUT:
 462         RETVAL
 463
 464 #endif
 465
 466 void
 467 test_hv_free_ent()
 468         PPCODE:
 469         test_freeent(&Perl_hv_free_ent);
 470         XSRETURN(4);
 471
 472 void
 473 test_hv_delayfree_ent()
 474         PPCODE:
 475         test_freeent(&Perl_hv_delayfree_ent);
 476         XSRETURN(4);
 477
 478 SV *
 479 test_share_unshare_pvn(input)
 480         PREINIT:
 481         STRLEN len;
 482         U32 hash;
 483         char *pvx;
 484         char *p;
 485         INPUT:
 486         SV *input
 487         CODE:
 488         pvx = SvPV(input, len);
 489         PERL_HASH(hash, pvx, len);
 490         p = sharepvn(pvx, len, hash);
 491         RETVAL = newSVpvn(p, len);
 492         unsharepvn(p, len, hash);
 493         OUTPUT:
 494         RETVAL
 495
 496 #if PERL_VERSION >= 9
 497
 498 bool
 499 refcounted_he_exists(key, level=0)
 500         SV *key
 501         IV level
 502         CODE:
 503         if (level) {
 504             croak("level must be zero, not %"IVdf, level);
 505         }
 506         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 507                                            key, NULL, 0, 0, 0)
 508                   != &PL_sv_placeholder);
 509         OUTPUT:
 510         RETVAL
 511
 512 SV *
 513 refcounted_he_fetch(key, level=0)
 514         SV *key
 515         IV level
 516         CODE:
 517         if (level) {
 518             croak("level must be zero, not %"IVdf, level);
 519         }
 520         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
 521                                           NULL, 0, 0, 0);
 522         SvREFCNT_inc(RETVAL);
 523         OUTPUT:
 524         RETVAL
 525
 526 #endif
 527
 528 =pod
 529
 530 sub TIEHASH  { bless {}, $_[0] }
 531 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 532 sub FETCH    { $_[0]->{$_[1]} }
 533 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 534 sub NEXTKEY  { each %{$_[0]} }
 535 sub EXISTS   { exists $_[0]->{$_[1]} }
 536 sub DELETE   { delete $_[0]->{$_[1]} }
 537 sub CLEAR    { %{$_[0]} = () }
 538
 539 =cut
 540
 541 MODULE = XS::APItest            PACKAGE = XS::APItest
 542
 543 PROTOTYPES: DISABLE
 544
 545 BOOT:
 546 {
 547     MY_CXT_INIT;
 548     MY_CXT.i  = 99;
 549     MY_CXT.sv = newSVpv("initial",0);
 550 }
 551
 552 void
 553 CLONE(...)
 554     CODE:
 555     MY_CXT_CLONE;
 556     MY_CXT.sv = newSVpv("initial_clone",0);
 557
 558 void
 559 print_double(val)
 560         double val
 561         CODE:
 562         printf("%5.3f\n",val);
 563
 564 int
 565 have_long_double()
 566         CODE:
 567 #ifdef HAS_LONG_DOUBLE
 568         RETVAL = 1;
 569 #else
 570         RETVAL = 0;
 571 #endif
 572         OUTPUT:
 573         RETVAL
 574
 575 void
 576 print_long_double()
 577         CODE:
 578 #ifdef HAS_LONG_DOUBLE
 579 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
 580         long double val = 7.0;
 581         printf("%5.3" PERL_PRIfldbl "\n",val);
 582 #   else
 583         double val = 7.0;
 584         printf("%5.3f\n",val);
 585 #   endif
 586 #endif
 587
 588 void
 589 print_int(val)
 590         int val
 591         CODE:
 592         printf("%d\n",val);
 593
 594 void
 595 print_long(val)
 596         long val
 597         CODE:
 598         printf("%ld\n",val);
 599
 600 void
 601 print_float(val)
 602         float val
 603         CODE:
 604         printf("%5.3f\n",val);
 605
 606 void
 607 print_flush()
 608         CODE:
 609         fflush(stdout);
 610
 611 void
 612 mpushp()
 613         PPCODE:
 614         EXTEND(SP, 3);
 615         mPUSHp("one", 3);
 616         mPUSHp("two", 3);
 617         mPUSHp("three", 5);
 618         XSRETURN(3);
 619
 620 void
 621 mpushn()
 622         PPCODE:
 623         EXTEND(SP, 3);
 624         mPUSHn(0.5);
 625         mPUSHn(-0.25);
 626         mPUSHn(0.125);
 627         XSRETURN(3);
 628
 629 void
 630 mpushi()
 631         PPCODE:
 632         EXTEND(SP, 3);
 633         mPUSHi(-1);
 634         mPUSHi(2);
 635         mPUSHi(-3);
 636         XSRETURN(3);
 637
 638 void
 639 mpushu()
 640         PPCODE:
 641         EXTEND(SP, 3);
 642         mPUSHu(1);
 643         mPUSHu(2);
 644         mPUSHu(3);
 645         XSRETURN(3);
 646
 647 void
 648 mxpushp()
 649         PPCODE:
 650         mXPUSHp("one", 3);
 651         mXPUSHp("two", 3);
 652         mXPUSHp("three", 5);
 653         XSRETURN(3);
 654
 655 void
 656 mxpushn()
 657         PPCODE:
 658         mXPUSHn(0.5);
 659         mXPUSHn(-0.25);
 660         mXPUSHn(0.125);
 661         XSRETURN(3);
 662
 663 void
 664 mxpushi()
 665         PPCODE:
 666         mXPUSHi(-1);
 667         mXPUSHi(2);
 668         mXPUSHi(-3);
 669         XSRETURN(3);
 670
 671 void
 672 mxpushu()
 673         PPCODE:
 674         mXPUSHu(1);
 675         mXPUSHu(2);
 676         mXPUSHu(3);
 677         XSRETURN(3);
 678
 679
 680 void
 681 call_sv(sv, flags, ...)
 682     SV* sv
 683     I32 flags
 684     PREINIT:
 685         I32 i;
 686     PPCODE:
 687         for (i=0; i<items-2; i++)
 688             ST(i) = ST(i+2); /* pop first two args */
 689         PUSHMARK(SP);
 690         SP += items - 2;
 691         PUTBACK;
 692         i = call_sv(sv, flags);
 693         SPAGAIN;
 694         EXTEND(SP, 1);
 695         PUSHs(sv_2mortal(newSViv(i)));
 696
 697 void
 698 call_pv(subname, flags, ...)
 699     char* subname
 700     I32 flags
 701     PREINIT:
 702         I32 i;
 703     PPCODE:
 704         for (i=0; i<items-2; i++)
 705             ST(i) = ST(i+2); /* pop first two args */
 706         PUSHMARK(SP);
 707         SP += items - 2;
 708         PUTBACK;
 709         i = call_pv(subname, flags);
 710         SPAGAIN;
 711         EXTEND(SP, 1);
 712         PUSHs(sv_2mortal(newSViv(i)));
 713
 714 void
 715 call_method(methname, flags, ...)
 716     char* methname
 717     I32 flags
 718     PREINIT:
 719         I32 i;
 720     PPCODE:
 721         for (i=0; i<items-2; i++)
 722             ST(i) = ST(i+2); /* pop first two args */
 723         PUSHMARK(SP);
 724         SP += items - 2;
 725         PUTBACK;
 726         i = call_method(methname, flags);
 727         SPAGAIN;
 728         EXTEND(SP, 1);
 729         PUSHs(sv_2mortal(newSViv(i)));
 730
 731 void
 732 eval_sv(sv, flags)
 733     SV* sv
 734     I32 flags
 735     PREINIT:
 736         I32 i;
 737     PPCODE:
 738         PUTBACK;
 739         i = eval_sv(sv, flags);
 740         SPAGAIN;
 741         EXTEND(SP, 1);
 742         PUSHs(sv_2mortal(newSViv(i)));
 743
 744 void
 745 eval_pv(p, croak_on_error)
 746     const char* p
 747     I32 croak_on_error
 748     PPCODE:
 749         PUTBACK;
 750         EXTEND(SP, 1);
 751         PUSHs(eval_pv(p, croak_on_error));
 752
 753 void
 754 require_pv(pv)
 755     const char* pv
 756     PPCODE:
 757         PUTBACK;
 758         require_pv(pv);
 759
 760 int
 761 apitest_exception(throw_e)
 762     int throw_e
 763     OUTPUT:
 764         RETVAL
 765
 766 void
 767 mycroak(sv)
 768     SV* sv
 769     CODE:
 770     if (SvOK(sv)) {
 771         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
 772     }
 773     else {
 774         Perl_croak(aTHX_ NULL);
 775     }
 776
 777 SV*
 778 strtab()
 779    CODE:
 780    RETVAL = newRV_inc((SV*)PL_strtab);
 781    OUTPUT:
 782    RETVAL
 783
 784 int
 785 my_cxt_getint()
 786     CODE:
 787         dMY_CXT;
 788         RETVAL = my_cxt_getint_p(aMY_CXT);
 789     OUTPUT:
 790         RETVAL
 791
 792 void
 793 my_cxt_setint(i)
 794     int i;
 795     CODE:
 796         dMY_CXT;
 797         my_cxt_setint_p(aMY_CXT_ i);
 798
 799 void
 800 my_cxt_getsv(how)
 801     bool how;
 802     PPCODE:
 803         EXTEND(SP, 1);
 804         ST(0) = how ? my_cxt_getsv_interp_context() : my_cxt_getsv_interp();
 805         XSRETURN(1);
 806
 807 void
 808 my_cxt_setsv(sv)
 809     SV *sv;
 810     CODE:
 811         dMY_CXT;
 812         SvREFCNT_dec(MY_CXT.sv);
 813         my_cxt_setsv_p(sv _aMY_CXT);
 814         SvREFCNT_inc(sv);
 815
 816 bool
 817 sv_setsv_cow_hashkey_core()
 818
 819 bool
 820 sv_setsv_cow_hashkey_notcore()
 821
 822 void
 823 rmagical_cast(sv, type)
 824     SV *sv;
 825     SV *type;
 826     PREINIT:
 827         struct ufuncs uf;
 828     PPCODE:
 829         if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
 830         sv = SvRV(sv);
 831         if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
 832         uf.uf_val = rmagical_a_dummy;
 833         uf.uf_set = NULL;
 834         uf.uf_index = 0;
 835         if (SvTRUE(type)) { /* b */
 836             sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
 837         } else { /* a */
 838             sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
 839         }
 840         XSRETURN_YES;
 841
 842 void
 843 rmagical_flags(sv)
 844     SV *sv;
 845     PPCODE:
 846         if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
 847         sv = SvRV(sv);
 848         EXTEND(SP, 3);
 849         mXPUSHu(SvFLAGS(sv) & SVs_GMG);
 850         mXPUSHu(SvFLAGS(sv) & SVs_SMG);
 851         mXPUSHu(SvFLAGS(sv) & SVs_RMG);
 852         XSRETURN(3);
 853
 854 void
 855 DPeek (sv)
 856     SV   *sv
 857
 858   PPCODE:
 859     ST (0) = newSVpv (Perl_sv_peek (sv), 0);
 860     XSRETURN (1);
 861
 862 void
 863 BEGIN()
 864     CODE:
 865         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
 866
 867 void
 868 CHECK()
 869     CODE:
 870         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
 871
 872 void
 873 UNITCHECK()
 874     CODE:
 875         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
 876
 877 void
 878 INIT()
 879     CODE:
 880         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
 881
 882 void
 883 END()
 884     CODE:
 885         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));