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