ext/XS-APItest/APItest.xs

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