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