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