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         SV *output;
 229         STRLEN len;
 230         U32 hash;
 231         char *pvx;
 232         char *p;
 233         INPUT:
 234         SV *input
 235         CODE:
 236         pvx = SvPV(input, len);
 237         PERL_HASH(hash, pvx, len);
 238         p = sharepvn(pvx, len, hash);
 239         RETVAL = newSVpvn(p, len);
 240         unsharepvn(p, len, hash);
 241         OUTPUT:
 242         RETVAL
 243
 244 bool
 245 refcounted_he_exists(key, level=0)
 246         SV *key
 247         IV level
 248         CODE:
 249         if (level) {
 250             croak("level must be zero, not %"IVdf, level);
 251         }
 252         RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 253                                            key, NULL, 0, 0, 0)
 254                   != &PL_sv_placeholder);
 255         OUTPUT:
 256         RETVAL
 257
 258
 259 SV *
 260 refcounted_he_fetch(key, level=0)
 261         SV *key
 262         IV level
 263         CODE:
 264         if (level) {
 265             croak("level must be zero, not %"IVdf, level);
 266         }
 267         RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
 268                                           NULL, 0, 0, 0);
 269         SvREFCNT_inc(RETVAL);
 270         OUTPUT:
 271         RETVAL
 272
 273
 274 =pod
 275
 276 sub TIEHASH  { bless {}, $_[0] }
 277 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 278 sub FETCH    { $_[0]->{$_[1]} }
 279 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 280 sub NEXTKEY  { each %{$_[0]} }
 281 sub EXISTS   { exists $_[0]->{$_[1]} }
 282 sub DELETE   { delete $_[0]->{$_[1]} }
 283 sub CLEAR    { %{$_[0]} = () }
 284
 285 =cut
 286
 287 MODULE = XS::APItest            PACKAGE = XS::APItest
 288
 289 PROTOTYPES: DISABLE
 290
 291 BOOT:
 292 {
 293     MY_CXT_INIT;
 294     MY_CXT.i  = 99;
 295     MY_CXT.sv = newSVpv("initial",0);
 296 }
 297
 298 void
 299 CLONE(...)
 300     CODE:
 301     MY_CXT_CLONE;
 302     MY_CXT.sv = newSVpv("initial_clone",0);
 303
 304 void
 305 print_double(val)
 306         double val
 307         CODE:
 308         printf("%5.3f\n",val);
 309
 310 int
 311 have_long_double()
 312         CODE:
 313 #ifdef HAS_LONG_DOUBLE
 314         RETVAL = 1;
 315 #else
 316         RETVAL = 0;
 317 #endif
 318         OUTPUT:
 319         RETVAL
 320
 321 void
 322 print_long_double()
 323         CODE:
 324 #ifdef HAS_LONG_DOUBLE
 325 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
 326         long double val = 7.0;
 327         printf("%5.3" PERL_PRIfldbl "\n",val);
 328 #   else
 329         double val = 7.0;
 330         printf("%5.3f\n",val);
 331 #   endif
 332 #endif
 333
 334 void
 335 print_int(val)
 336         int val
 337         CODE:
 338         printf("%d\n",val);
 339
 340 void
 341 print_long(val)
 342         long val
 343         CODE:
 344         printf("%ld\n",val);
 345
 346 void
 347 print_float(val)
 348         float val
 349         CODE:
 350         printf("%5.3f\n",val);
 351
 352 void
 353 print_flush()
 354         CODE:
 355         fflush(stdout);
 356
 357 void
 358 mpushp()
 359         PPCODE:
 360         EXTEND(SP, 3);
 361         mPUSHp("one", 3);
 362         mPUSHp("two", 3);
 363         mPUSHp("three", 5);
 364         XSRETURN(3);
 365
 366 void
 367 mpushn()
 368         PPCODE:
 369         EXTEND(SP, 3);
 370         mPUSHn(0.5);
 371         mPUSHn(-0.25);
 372         mPUSHn(0.125);
 373         XSRETURN(3);
 374
 375 void
 376 mpushi()
 377         PPCODE:
 378         EXTEND(SP, 3);
 379         mPUSHi(-1);
 380         mPUSHi(2);
 381         mPUSHi(-3);
 382         XSRETURN(3);
 383
 384 void
 385 mpushu()
 386         PPCODE:
 387         EXTEND(SP, 3);
 388         mPUSHu(1);
 389         mPUSHu(2);
 390         mPUSHu(3);
 391         XSRETURN(3);
 392
 393 void
 394 mxpushp()
 395         PPCODE:
 396         mXPUSHp("one", 3);
 397         mXPUSHp("two", 3);
 398         mXPUSHp("three", 5);
 399         XSRETURN(3);
 400
 401 void
 402 mxpushn()
 403         PPCODE:
 404         mXPUSHn(0.5);
 405         mXPUSHn(-0.25);
 406         mXPUSHn(0.125);
 407         XSRETURN(3);
 408
 409 void
 410 mxpushi()
 411         PPCODE:
 412         mXPUSHi(-1);
 413         mXPUSHi(2);
 414         mXPUSHi(-3);
 415         XSRETURN(3);
 416
 417 void
 418 mxpushu()
 419         PPCODE:
 420         mXPUSHu(1);
 421         mXPUSHu(2);
 422         mXPUSHu(3);
 423         XSRETURN(3);
 424
 425
 426 void
 427 call_sv(sv, flags, ...)
 428     SV* sv
 429     I32 flags
 430     PREINIT:
 431         I32 i;
 432     PPCODE:
 433         for (i=0; i<items-2; i++)
 434             ST(i) = ST(i+2); /* pop first two args */
 435         PUSHMARK(SP);
 436         SP += items - 2;
 437         PUTBACK;
 438         i = call_sv(sv, flags);
 439         SPAGAIN;
 440         EXTEND(SP, 1);
 441         PUSHs(sv_2mortal(newSViv(i)));
 442
 443 void
 444 call_pv(subname, flags, ...)
 445     char* subname
 446     I32 flags
 447     PREINIT:
 448         I32 i;
 449     PPCODE:
 450         for (i=0; i<items-2; i++)
 451             ST(i) = ST(i+2); /* pop first two args */
 452         PUSHMARK(SP);
 453         SP += items - 2;
 454         PUTBACK;
 455         i = call_pv(subname, flags);
 456         SPAGAIN;
 457         EXTEND(SP, 1);
 458         PUSHs(sv_2mortal(newSViv(i)));
 459
 460 void
 461 call_method(methname, flags, ...)
 462     char* methname
 463     I32 flags
 464     PREINIT:
 465         I32 i;
 466     PPCODE:
 467         for (i=0; i<items-2; i++)
 468             ST(i) = ST(i+2); /* pop first two args */
 469         PUSHMARK(SP);
 470         SP += items - 2;
 471         PUTBACK;
 472         i = call_method(methname, flags);
 473         SPAGAIN;
 474         EXTEND(SP, 1);
 475         PUSHs(sv_2mortal(newSViv(i)));
 476
 477 void
 478 eval_sv(sv, flags)
 479     SV* sv
 480     I32 flags
 481     PREINIT:
 482         I32 i;
 483     PPCODE:
 484         PUTBACK;
 485         i = eval_sv(sv, flags);
 486         SPAGAIN;
 487         EXTEND(SP, 1);
 488         PUSHs(sv_2mortal(newSViv(i)));
 489
 490 void
 491 eval_pv(p, croak_on_error)
 492     const char* p
 493     I32 croak_on_error
 494     PPCODE:
 495         PUTBACK;
 496         EXTEND(SP, 1);
 497         PUSHs(eval_pv(p, croak_on_error));
 498
 499 void
 500 require_pv(pv)
 501     const char* pv
 502     PPCODE:
 503         PUTBACK;
 504         require_pv(pv);
 505
 506 int
 507 exception(throw_e)
 508     int throw_e
 509     OUTPUT:
 510         RETVAL
 511
 512 void
 513 mycroak(sv)
 514     SV* sv
 515     CODE:
 516     if (SvOK(sv)) {
 517         Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
 518     }
 519     else {
 520         Perl_croak(aTHX_ NULL);
 521     }
 522
 523 SV*
 524 strtab()
 525    CODE:
 526    RETVAL = newRV_inc((SV*)PL_strtab);
 527    OUTPUT:
 528    RETVAL
 529
 530 int
 531 my_cxt_getint()
 532     CODE:
 533         dMY_CXT;
 534         RETVAL = my_cxt_getint_p(aMY_CXT);
 535     OUTPUT:
 536         RETVAL
 537
 538 void
 539 my_cxt_setint(i)
 540     int i;
 541     CODE:
 542         dMY_CXT;
 543         my_cxt_setint_p(aMY_CXT_ i);
 544
 545 void
 546 my_cxt_getsv()
 547     PPCODE:
 548         EXTEND(SP, 1);
 549         ST(0) = my_cxt_getsv_interp();
 550         XSRETURN(1);
 551
 552 void
 553 my_cxt_setsv(sv)
 554     SV *sv;
 555     CODE:
 556         dMY_CXT;
 557         SvREFCNT_dec(MY_CXT.sv);
 558         my_cxt_setsv_p(sv _aMY_CXT);
 559         SvREFCNT_inc(sv);