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()
  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 exception(int);
  53
  54 /* A routine to test hv_delayfree_ent
  55    (which itself is tested by testing on hv_free_ent  */
  56
  57 typedef void (freeent_function)(pTHX_ HV *, register HE *);
  58
  59 void
  60 test_freeent(freeent_function *f) {
  61     dTHX;
  62     dSP;
  63     HV *test_hash = newHV();
  64     HE *victim;
  65     SV *test_scalar;
  66     U32 results[4];
  67     int i;
  68
  69 #ifdef PURIFY
  70     victim = (HE*)safemalloc(sizeof(HE));
  71 #else
  72     /* Storing then deleting something should ensure that a hash entry is
  73        available.  */
  74     hv_store(test_hash, "", 0, &PL_sv_yes, 0);
  75     hv_delete(test_hash, "", 0, 0);
  76
  77     /* We need to "inline" new_he here as it's static, and the functions we
  78        test expect to be able to call del_HE on the HE  */
  79     if (!PL_body_roots[HE_SVSLOT])
  80         croak("PL_he_root is 0");
  81     victim = PL_body_roots[HE_SVSLOT];
  82     PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
  83 #endif
  84
  85     victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
  86
  87     test_scalar = newSV(0);
  88     SvREFCNT_inc(test_scalar);
  89     HeVAL(victim) = test_scalar;
  90
  91     /* Need this little game else we free the temps on the return stack.  */
  92     results[0] = SvREFCNT(test_scalar);
  93     SAVETMPS;
  94     results[1] = SvREFCNT(test_scalar);
  95     f(aTHX_ test_hash, victim);
  96     results[2] = SvREFCNT(test_scalar);
  97     FREETMPS;
  98     results[3] = SvREFCNT(test_scalar);
  99
 100     i = 0;
 101     do {
 102         mPUSHu(results[i]);
 103     } while (++i < sizeof(results)/sizeof(results[0]));
 104
 105     /* Goodbye to our extra reference.  */
 106     SvREFCNT_dec(test_scalar);
 107 }
 108
 109 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
 110
 111 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
 112
 113 bool
 114 exists(hash, key_sv)
 115         PREINIT:
 116         STRLEN len;
 117         const char *key;
 118         INPUT:
 119         HV *hash
 120         SV *key_sv
 121         CODE:
 122         key = SvPV(key_sv, len);
 123         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
 124         OUTPUT:
 125         RETVAL
 126
 127 SV *
 128 delete(hash, key_sv)
 129         PREINIT:
 130         STRLEN len;
 131         const char *key;
 132         INPUT:
 133         HV *hash
 134         SV *key_sv
 135         CODE:
 136         key = SvPV(key_sv, len);
 137         /* It's already mortal, so need to increase reference count.  */
 138         RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
 139         OUTPUT:
 140         RETVAL
 141
 142 SV *
 143 store_ent(hash, key, value)
 144         PREINIT:
 145         SV *copy;
 146         HE *result;
 147         INPUT:
 148         HV *hash
 149         SV *key
 150         SV *value
 151         CODE:
 152         copy = newSV(0);
 153         result = hv_store_ent(hash, key, copy, 0);
 154         SvSetMagicSV(copy, value);
 155         if (!result) {
 156             SvREFCNT_dec(copy);
 157             XSRETURN_EMPTY;
 158         }
 159         /* It's about to become mortal, so need to increase reference count.
 160          */
 161         RETVAL = SvREFCNT_inc(HeVAL(result));
 162         OUTPUT:
 163         RETVAL
 164
 165
 166 SV *
 167 store(hash, key_sv, value)
 168         PREINIT:
 169         STRLEN len;
 170         const char *key;
 171         SV *copy;
 172         SV **result;
 173         INPUT:
 174         HV *hash
 175         SV *key_sv
 176         SV *value
 177         CODE:
 178         key = SvPV(key_sv, len);
 179         copy = newSV(0);
 180         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
 181         SvSetMagicSV(copy, value);
 182         if (!result) {
 183             SvREFCNT_dec(copy);
 184             XSRETURN_EMPTY;
 185         }
 186         /* It's about to become mortal, so need to increase reference count.
 187          */
 188         RETVAL = SvREFCNT_inc(*result);
 189         OUTPUT:
 190         RETVAL
 191
 192
 193 SV *
 194 fetch(hash, key_sv)
 195         PREINIT:
 196         STRLEN len;
 197         const char *key;
 198         SV **result;
 199         INPUT:
 200         HV *hash
 201         SV *key_sv
 202         CODE:
 203         key = SvPV(key_sv, len);
 204         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
 205         if (!result) {
 206             XSRETURN_EMPTY;
 207         }
 208         /* Force mg_get  */
 209         RETVAL = newSVsv(*result);
 210         OUTPUT:
 211         RETVAL
 212
 213 void
 214 test_hv_free_ent()
 215         PPCODE:
 216         test_freeent(&Perl_hv_free_ent);
 217         XSRETURN(4);
 218
 219 void
 220 test_hv_delayfree_ent()
 221         PPCODE:
 222         test_freeent(&Perl_hv_delayfree_ent);
 223         XSRETURN(4);
 224
 225 SV *
 226 test_share_unshare_pvn(input)
 227         PREINIT:
 228         STRLEN len;
 229         U32 hash;
 230         char *pvx;
 231         char *p;
 232         INPUT:
 233         SV *input
 234         CODE:
 235         pvx = SvPV(input, len);
 236         PERL_HASH(hash, pvx, len);
 237         p = sharepvn(pvx, len, hash);
 238         RETVAL = newSVpvn(p, len);
 239         unsharepvn(p, len, hash);
 240         OUTPUT:
 241         RETVAL
 242
 243 bool
 244 refcounted_he_exists(key, level=0)
 245         SV *key
 246         IV level
 247         CODE:
 248         if (level) {
 249             croak("level must be zero, not %"IVdf, level);
 250         }
 251         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 252                                            key, NULL, 0, 0, 0)
 253                   != &PL_sv_placeholder);
 254         OUTPUT:
 255         RETVAL
 256
 257
 258 SV *
 259 refcounted_he_fetch(key, level=0)
 260         SV *key
 261         IV level
 262         CODE:
 263         if (level) {
 264             croak("level must be zero, not %"IVdf, level);
 265         }
 266         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
 267                                           NULL, 0, 0, 0);
 268         SvREFCNT_inc(RETVAL);
 269         OUTPUT:
 270         RETVAL
 271
 272
 273 =pod
 274
 275 sub TIEHASH  { bless {}, $_[0] }
 276 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 277 sub FETCH    { $_[0]->{$_[1]} }
 278 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 279 sub NEXTKEY  { each %{$_[0]} }
 280 sub EXISTS   { exists $_[0]->{$_[1]} }
 281 sub DELETE   { delete $_[0]->{$_[1]} }
 282 sub CLEAR    { %{$_[0]} = () }
 283
 284 =cut
 285
 286 MODULE = XS::APItest            PACKAGE = XS::APItest
 287
 288 PROTOTYPES: DISABLE
 289
 290 BOOT:
 291 {
 292     MY_CXT_INIT;
 293     MY_CXT.i  = 99;
 294     MY_CXT.sv = newSVpv("initial",0);
 295 }
 296
 297 void
 298 CLONE(...)
 299     CODE:
 300     MY_CXT_CLONE;
 301     MY_CXT.sv = newSVpv("initial_clone",0);
 302
 303 void
 304 print_double(val)
 305         double val
 306         CODE:
 307         printf("%5.3f\n",val);
 308
 309 int
 310 have_long_double()
 311         CODE:
 312 #ifdef HAS_LONG_DOUBLE
 313         RETVAL = 1;
 314 #else
 315         RETVAL = 0;
 316 #endif
 317         OUTPUT:
 318         RETVAL
 319
 320 void
 321 print_long_double()
 322         CODE:
 323 #ifdef HAS_LONG_DOUBLE
 324 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
 325         long double val = 7.0;
 326         printf("%5.3" PERL_PRIfldbl "\n",val);
 327 #   else
 328         double val = 7.0;
 329         printf("%5.3f\n",val);
 330 #   endif
 331 #endif
 332
 333 void
 334 print_int(val)
 335         int val
 336         CODE:
 337         printf("%d\n",val);
 338
 339 void
 340 print_long(val)
 341         long val
 342         CODE:
 343         printf("%ld\n",val);
 344
 345 void
 346 print_float(val)
 347         float val
 348         CODE:
 349         printf("%5.3f\n",val);
 350
 351 void
 352 print_flush()
 353         CODE:
 354         fflush(stdout);
 355
 356 void
 357 mpushp()
 358         PPCODE:
 359         EXTEND(SP, 3);
 360         mPUSHp("one", 3);
 361         mPUSHp("two", 3);
 362         mPUSHp("three", 5);
 363         XSRETURN(3);
 364
 365 void
 366 mpushn()
 367         PPCODE:
 368         EXTEND(SP, 3);
 369         mPUSHn(0.5);
 370         mPUSHn(-0.25);
 371         mPUSHn(0.125);
 372         XSRETURN(3);
 373
 374 void
 375 mpushi()
 376         PPCODE:
 377         EXTEND(SP, 3);
 378         mPUSHi(-1);
 379         mPUSHi(2);
 380         mPUSHi(-3);
 381         XSRETURN(3);
 382
 383 void
 384 mpushu()
 385         PPCODE:
 386         EXTEND(SP, 3);
 387         mPUSHu(1);
 388         mPUSHu(2);
 389         mPUSHu(3);
 390         XSRETURN(3);
 391
 392 void
 393 mxpushp()
 394         PPCODE:
 395         mXPUSHp("one", 3);
 396         mXPUSHp("two", 3);
 397         mXPUSHp("three", 5);
 398         XSRETURN(3);
 399
 400 void
 401 mxpushn()
 402         PPCODE:
 403         mXPUSHn(0.5);
 404         mXPUSHn(-0.25);
 405         mXPUSHn(0.125);
 406         XSRETURN(3);
 407
 408 void
 409 mxpushi()
 410         PPCODE:
 411         mXPUSHi(-1);
 412         mXPUSHi(2);
 413         mXPUSHi(-3);
 414         XSRETURN(3);
 415
 416 void
 417 mxpushu()
 418         PPCODE:
 419         mXPUSHu(1);
 420         mXPUSHu(2);
 421         mXPUSHu(3);
 422         XSRETURN(3);
 423
 424
 425 void
 426 call_sv(sv, flags, ...)
 427     SV* sv
 428     I32 flags
 429     PREINIT:
 430         I32 i;
 431     PPCODE:
 432         for (i=0; i<items-2; i++)
 433             ST(i) = ST(i+2); /* pop first two args */
 434         PUSHMARK(SP);
 435         SP += items - 2;
 436         PUTBACK;
 437         i = call_sv(sv, flags);
 438         SPAGAIN;
 439         EXTEND(SP, 1);
 440         PUSHs(sv_2mortal(newSViv(i)));
 441
 442 void
 443 call_pv(subname, flags, ...)
 444     char* subname
 445     I32 flags
 446     PREINIT:
 447         I32 i;
 448     PPCODE:
 449         for (i=0; i<items-2; i++)
 450             ST(i) = ST(i+2); /* pop first two args */
 451         PUSHMARK(SP);
 452         SP += items - 2;
 453         PUTBACK;
 454         i = call_pv(subname, flags);
 455         SPAGAIN;
 456         EXTEND(SP, 1);
 457         PUSHs(sv_2mortal(newSViv(i)));
 458
 459 void
 460 call_method(methname, flags, ...)
 461     char* methname
 462     I32 flags
 463     PREINIT:
 464         I32 i;
 465     PPCODE:
 466         for (i=0; i<items-2; i++)
 467             ST(i) = ST(i+2); /* pop first two args */
 468         PUSHMARK(SP);
 469         SP += items - 2;
 470         PUTBACK;
 471         i = call_method(methname, flags);
 472         SPAGAIN;
 473         EXTEND(SP, 1);
 474         PUSHs(sv_2mortal(newSViv(i)));
 475
 476 void
 477 eval_sv(sv, flags)
 478     SV* sv
 479     I32 flags
 480     PREINIT:
 481         I32 i;
 482     PPCODE:
 483         PUTBACK;
 484         i = eval_sv(sv, flags);
 485         SPAGAIN;
 486         EXTEND(SP, 1);
 487         PUSHs(sv_2mortal(newSViv(i)));
 488
 489 void
 490 eval_pv(p, croak_on_error)
 491     const char* p
 492     I32 croak_on_error
 493     PPCODE:
 494         PUTBACK;
 495         EXTEND(SP, 1);
 496         PUSHs(eval_pv(p, croak_on_error));
 497
 498 void
 499 require_pv(pv)
 500     const char* pv
 501     PPCODE:
 502         PUTBACK;
 503         require_pv(pv);
 504
 505 int
 506 exception(throw_e)
 507     int throw_e
 508     OUTPUT:
 509         RETVAL
 510
 511 void
 512 mycroak(sv)
 513     SV* sv
 514     CODE:
 515     if (SvOK(sv)) {
 516         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
 517     }
 518     else {
 519         Perl_croak(aTHX_ NULL);
 520     }
 521
 522 SV*
 523 strtab()
 524    CODE:
 525    RETVAL = newRV_inc((SV*)PL_strtab);
 526    OUTPUT:
 527    RETVAL
 528
 529 int
 530 my_cxt_getint()
 531     CODE:
 532         dMY_CXT;
 533         RETVAL = my_cxt_getint_p(aMY_CXT);
 534     OUTPUT:
 535         RETVAL
 536
 537 void
 538 my_cxt_setint(i)
 539     int i;
 540     CODE:
 541         dMY_CXT;
 542         my_cxt_setint_p(aMY_CXT_ i);
 543
 544 void
 545 my_cxt_getsv()
 546     PPCODE:
 547         EXTEND(SP, 1);
 548         ST(0) = my_cxt_getsv_interp();
 549         XSRETURN(1);
 550
 551 void
 552 my_cxt_setsv(sv)
 553     SV *sv;
 554     CODE:
 555         dMY_CXT;
 556         SvREFCNT_dec(MY_CXT.sv);
 557         my_cxt_setsv_p(sv _aMY_CXT);
 558         SvREFCNT_inc(sv);