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