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