ext/XS/APItest/APItest.xs

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