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 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
 114
 115 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
 116
 117 bool
 118 exists(hash, key_sv)
 119         PREINIT:
 120         STRLEN len;
 121         const char *key;
 122         INPUT:
 123         HV *hash
 124         SV *key_sv
 125         CODE:
 126         key = SvPV(key_sv, len);
 127         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
 128         OUTPUT:
 129         RETVAL
 130
 131 SV *
 132 delete(hash, key_sv)
 133         PREINIT:
 134         STRLEN len;
 135         const char *key;
 136         INPUT:
 137         HV *hash
 138         SV *key_sv
 139         CODE:
 140         key = SvPV(key_sv, len);
 141         /* It's already mortal, so need to increase reference count.  */
 142         RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
 143         OUTPUT:
 144         RETVAL
 145
 146 SV *
 147 store_ent(hash, key, value)
 148         PREINIT:
 149         SV *copy;
 150         HE *result;
 151         INPUT:
 152         HV *hash
 153         SV *key
 154         SV *value
 155         CODE:
 156         copy = newSV(0);
 157         result = hv_store_ent(hash, key, copy, 0);
 158         SvSetMagicSV(copy, value);
 159         if (!result) {
 160             SvREFCNT_dec(copy);
 161             XSRETURN_EMPTY;
 162         }
 163         /* It's about to become mortal, so need to increase reference count.
 164          */
 165         RETVAL = SvREFCNT_inc(HeVAL(result));
 166         OUTPUT:
 167         RETVAL
 168
 169
 170 SV *
 171 store(hash, key_sv, value)
 172         PREINIT:
 173         STRLEN len;
 174         const char *key;
 175         SV *copy;
 176         SV **result;
 177         INPUT:
 178         HV *hash
 179         SV *key_sv
 180         SV *value
 181         CODE:
 182         key = SvPV(key_sv, len);
 183         copy = newSV(0);
 184         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
 185         SvSetMagicSV(copy, value);
 186         if (!result) {
 187             SvREFCNT_dec(copy);
 188             XSRETURN_EMPTY;
 189         }
 190         /* It's about to become mortal, so need to increase reference count.
 191          */
 192         RETVAL = SvREFCNT_inc(*result);
 193         OUTPUT:
 194         RETVAL
 195
 196
 197 SV *
 198 fetch(hash, key_sv)
 199         PREINIT:
 200         STRLEN len;
 201         const char *key;
 202         SV **result;
 203         INPUT:
 204         HV *hash
 205         SV *key_sv
 206         CODE:
 207         key = SvPV(key_sv, len);
 208         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
 209         if (!result) {
 210             XSRETURN_EMPTY;
 211         }
 212         /* Force mg_get  */
 213         RETVAL = newSVsv(*result);
 214         OUTPUT:
 215         RETVAL
 216
 217 void
 218 test_hv_free_ent()
 219         PPCODE:
 220         test_freeent(&Perl_hv_free_ent);
 221         XSRETURN(4);
 222
 223 void
 224 test_hv_delayfree_ent()
 225         PPCODE:
 226         test_freeent(&Perl_hv_delayfree_ent);
 227         XSRETURN(4);
 228
 229 SV *
 230 test_share_unshare_pvn(input)
 231         PREINIT:
 232         STRLEN len;
 233         U32 hash;
 234         char *pvx;
 235         char *p;
 236         INPUT:
 237         SV *input
 238         CODE:
 239         pvx = SvPV(input, len);
 240         PERL_HASH(hash, pvx, len);
 241         p = sharepvn(pvx, len, hash);
 242         RETVAL = newSVpvn(p, len);
 243         unsharepvn(p, len, hash);
 244         OUTPUT:
 245         RETVAL
 246
 247 bool
 248 refcounted_he_exists(key, level=0)
 249         SV *key
 250         IV level
 251         CODE:
 252         if (level) {
 253             croak("level must be zero, not %"IVdf, level);
 254         }
 255         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 256                                            key, NULL, 0, 0, 0)
 257                   != &PL_sv_placeholder);
 258         OUTPUT:
 259         RETVAL
 260
 261
 262 SV *
 263 refcounted_he_fetch(key, level=0)
 264         SV *key
 265         IV level
 266         CODE:
 267         if (level) {
 268             croak("level must be zero, not %"IVdf, level);
 269         }
 270         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
 271                                           NULL, 0, 0, 0);
 272         SvREFCNT_inc(RETVAL);
 273         OUTPUT:
 274         RETVAL
 275
 276
 277 =pod
 278
 279 sub TIEHASH  { bless {}, $_[0] }
 280 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 281 sub FETCH    { $_[0]->{$_[1]} }
 282 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 283 sub NEXTKEY  { each %{$_[0]} }
 284 sub EXISTS   { exists $_[0]->{$_[1]} }
 285 sub DELETE   { delete $_[0]->{$_[1]} }
 286 sub CLEAR    { %{$_[0]} = () }
 287
 288 =cut
 289
 290 MODULE = XS::APItest            PACKAGE = XS::APItest
 291
 292 PROTOTYPES: DISABLE
 293
 294 BOOT:
 295 {
 296     MY_CXT_INIT;
 297     MY_CXT.i  = 99;
 298     MY_CXT.sv = newSVpv("initial",0);
 299 }
 300
 301 void
 302 CLONE(...)
 303     CODE:
 304     MY_CXT_CLONE;
 305     MY_CXT.sv = newSVpv("initial_clone",0);
 306
 307 void
 308 print_double(val)
 309         double val
 310         CODE:
 311         printf("%5.3f\n",val);
 312
 313 int
 314 have_long_double()
 315         CODE:
 316 #ifdef HAS_LONG_DOUBLE
 317         RETVAL = 1;
 318 #else
 319         RETVAL = 0;
 320 #endif
 321         OUTPUT:
 322         RETVAL
 323
 324 void
 325 print_long_double()
 326         CODE:
 327 #ifdef HAS_LONG_DOUBLE
 328 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
 329         long double val = 7.0;
 330         printf("%5.3" PERL_PRIfldbl "\n",val);
 331 #   else
 332         double val = 7.0;
 333         printf("%5.3f\n",val);
 334 #   endif
 335 #endif
 336
 337 void
 338 print_int(val)
 339         int val
 340         CODE:
 341         printf("%d\n",val);
 342
 343 void
 344 print_long(val)
 345         long val
 346         CODE:
 347         printf("%ld\n",val);
 348
 349 void
 350 print_float(val)
 351         float val
 352         CODE:
 353         printf("%5.3f\n",val);
 354
 355 void
 356 print_flush()
 357         CODE:
 358         fflush(stdout);
 359
 360 void
 361 mpushp()
 362         PPCODE:
 363         EXTEND(SP, 3);
 364         mPUSHp("one", 3);
 365         mPUSHp("two", 3);
 366         mPUSHp("three", 5);
 367         XSRETURN(3);
 368
 369 void
 370 mpushn()
 371         PPCODE:
 372         EXTEND(SP, 3);
 373         mPUSHn(0.5);
 374         mPUSHn(-0.25);
 375         mPUSHn(0.125);
 376         XSRETURN(3);
 377
 378 void
 379 mpushi()
 380         PPCODE:
 381         EXTEND(SP, 3);
 382         mPUSHi(-1);
 383         mPUSHi(2);
 384         mPUSHi(-3);
 385         XSRETURN(3);
 386
 387 void
 388 mpushu()
 389         PPCODE:
 390         EXTEND(SP, 3);
 391         mPUSHu(1);
 392         mPUSHu(2);
 393         mPUSHu(3);
 394         XSRETURN(3);
 395
 396 void
 397 mxpushp()
 398         PPCODE:
 399         mXPUSHp("one", 3);
 400         mXPUSHp("two", 3);
 401         mXPUSHp("three", 5);
 402         XSRETURN(3);
 403
 404 void
 405 mxpushn()
 406         PPCODE:
 407         mXPUSHn(0.5);
 408         mXPUSHn(-0.25);
 409         mXPUSHn(0.125);
 410         XSRETURN(3);
 411
 412 void
 413 mxpushi()
 414         PPCODE:
 415         mXPUSHi(-1);
 416         mXPUSHi(2);
 417         mXPUSHi(-3);
 418         XSRETURN(3);
 419
 420 void
 421 mxpushu()
 422         PPCODE:
 423         mXPUSHu(1);
 424         mXPUSHu(2);
 425         mXPUSHu(3);
 426         XSRETURN(3);
 427
 428
 429 void
 430 call_sv(sv, flags, ...)
 431     SV* sv
 432     I32 flags
 433     PREINIT:
 434         I32 i;
 435     PPCODE:
 436         for (i=0; i<items-2; i++)
 437             ST(i) = ST(i+2); /* pop first two args */
 438         PUSHMARK(SP);
 439         SP += items - 2;
 440         PUTBACK;
 441         i = call_sv(sv, flags);
 442         SPAGAIN;
 443         EXTEND(SP, 1);
 444         PUSHs(sv_2mortal(newSViv(i)));
 445
 446 void
 447 call_pv(subname, flags, ...)
 448     char* subname
 449     I32 flags
 450     PREINIT:
 451         I32 i;
 452     PPCODE:
 453         for (i=0; i<items-2; i++)
 454             ST(i) = ST(i+2); /* pop first two args */
 455         PUSHMARK(SP);
 456         SP += items - 2;
 457         PUTBACK;
 458         i = call_pv(subname, flags);
 459         SPAGAIN;
 460         EXTEND(SP, 1);
 461         PUSHs(sv_2mortal(newSViv(i)));
 462
 463 void
 464 call_method(methname, flags, ...)
 465     char* methname
 466     I32 flags
 467     PREINIT:
 468         I32 i;
 469     PPCODE:
 470         for (i=0; i<items-2; i++)
 471             ST(i) = ST(i+2); /* pop first two args */
 472         PUSHMARK(SP);
 473         SP += items - 2;
 474         PUTBACK;
 475         i = call_method(methname, flags);
 476         SPAGAIN;
 477         EXTEND(SP, 1);
 478         PUSHs(sv_2mortal(newSViv(i)));
 479
 480 void
 481 eval_sv(sv, flags)
 482     SV* sv
 483     I32 flags
 484     PREINIT:
 485         I32 i;
 486     PPCODE:
 487         PUTBACK;
 488         i = eval_sv(sv, flags);
 489         SPAGAIN;
 490         EXTEND(SP, 1);
 491         PUSHs(sv_2mortal(newSViv(i)));
 492
 493 void
 494 eval_pv(p, croak_on_error)
 495     const char* p
 496     I32 croak_on_error
 497     PPCODE:
 498         PUTBACK;
 499         EXTEND(SP, 1);
 500         PUSHs(eval_pv(p, croak_on_error));
 501
 502 void
 503 require_pv(pv)
 504     const char* pv
 505     PPCODE:
 506         PUTBACK;
 507         require_pv(pv);
 508
 509 int
 510 apitest_exception(throw_e)
 511     int throw_e
 512     OUTPUT:
 513         RETVAL
 514
 515 void
 516 mycroak(sv)
 517     SV* sv
 518     CODE:
 519     if (SvOK(sv)) {
 520         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
 521     }
 522     else {
 523         Perl_croak(aTHX_ NULL);
 524     }
 525
 526 SV*
 527 strtab()
 528    CODE:
 529    RETVAL = newRV_inc((SV*)PL_strtab);
 530    OUTPUT:
 531    RETVAL
 532
 533 int
 534 my_cxt_getint()
 535     CODE:
 536         dMY_CXT;
 537         RETVAL = my_cxt_getint_p(aMY_CXT);
 538     OUTPUT:
 539         RETVAL
 540
 541 void
 542 my_cxt_setint(i)
 543     int i;
 544     CODE:
 545         dMY_CXT;
 546         my_cxt_setint_p(aMY_CXT_ i);
 547
 548 void
 549 my_cxt_getsv()
 550     PPCODE:
 551         EXTEND(SP, 1);
 552         ST(0) = my_cxt_getsv_interp();
 553         XSRETURN(1);
 554
 555 void
 556 my_cxt_setsv(sv)
 557     SV *sv;
 558     CODE:
 559         dMY_CXT;
 560         SvREFCNT_dec(MY_CXT.sv);
 561         my_cxt_setsv_p(sv _aMY_CXT);
 562         SvREFCNT_inc(sv);
 563
 564 bool
 565 sv_setsv_cow_hashkey_core()
 566
 567 bool
 568 sv_setsv_cow_hashkey_notcore()
 569
 570 void
 571 BEGIN()
 572     CODE:
 573         sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
 574
 575 void
 576 CHECK()
 577     CODE:
 578         sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
 579
 580 void
 581 UNITCHECK()
 582     CODE:
 583         sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
 584
 585 void
 586 INIT()
 587     CODE:
 588         sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
 589
 590 void
 591 END()
 592     CODE:
 593         sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));