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