ext/XS/APItest/APItest.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 static void throws_exception(int throw_e)
   6 {
   7   if (throw_e)
   8     croak("boo\n");
   9 }
  10
  11 static int exception(int throw_e)
  12 {
  13   dTHR;
  14   dXCPT;
  15   SV *caught = get_sv("XS::APItest::exception_caught", 0);
  16
  17   XCPT_TRY_START {
  18     throws_exception(throw_e);
  19   } XCPT_TRY_END
  20
  21   XCPT_CATCH
  22   {
  23     sv_setiv(caught, 1);
  24     XCPT_RETHROW;
  25   }
  26
  27   sv_setiv(caught, 0);
  28
  29   return 42;
  30 }
  31
  32 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
  33
  34 #define UTF8KLEN(sv, len)   (SvUTF8(sv) ? -(I32)len : (I32)len)
  35
  36 bool
  37 exists(hash, key_sv)
  38         PREINIT:
  39         STRLEN len;
  40         const char *key;
  41         INPUT:
  42         HV *hash
  43         SV *key_sv
  44         CODE:
  45         key = SvPV(key_sv, len);
  46         RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
  47         OUTPUT:
  48         RETVAL
  49
  50 SV *
  51 delete(hash, key_sv)
  52         PREINIT:
  53         STRLEN len;
  54         const char *key;
  55         INPUT:
  56         HV *hash
  57         SV *key_sv
  58         CODE:
  59         key = SvPV(key_sv, len);
  60         /* It's already mortal, so need to increase reference count.  */
  61         RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
  62         OUTPUT:
  63         RETVAL
  64
  65 SV *
  66 store_ent(hash, key, value)
  67         PREINIT:
  68         SV *copy;
  69         HE *result;
  70         INPUT:
  71         HV *hash
  72         SV *key
  73         SV *value
  74         CODE:
  75         copy = newSV(0);
  76         result = hv_store_ent(hash, key, copy, 0);
  77         SvSetMagicSV(copy, value);
  78         if (!result) {
  79             SvREFCNT_dec(copy);
  80             XSRETURN_EMPTY;
  81         }
  82         /* It's about to become mortal, so need to increase reference count.
  83          */
  84         RETVAL = SvREFCNT_inc(HeVAL(result));
  85         OUTPUT:
  86         RETVAL
  87
  88
  89 SV *
  90 store(hash, key_sv, value)
  91         PREINIT:
  92         STRLEN len;
  93         const char *key;
  94         SV *copy;
  95         SV **result;
  96         INPUT:
  97         HV *hash
  98         SV *key_sv
  99         SV *value
 100         CODE:
 101         key = SvPV(key_sv, len);
 102         copy = newSV(0);
 103         result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
 104         SvSetMagicSV(copy, value);
 105         if (!result) {
 106             SvREFCNT_dec(copy);
 107             XSRETURN_EMPTY;
 108         }
 109         /* It's about to become mortal, so need to increase reference count.
 110          */
 111         RETVAL = SvREFCNT_inc(*result);
 112         OUTPUT:
 113         RETVAL
 114
 115
 116 SV *
 117 fetch(hash, key_sv)
 118         PREINIT:
 119         STRLEN len;
 120         const char *key;
 121         SV **result;
 122         INPUT:
 123         HV *hash
 124         SV *key_sv
 125         CODE:
 126         key = SvPV(key_sv, len);
 127         result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
 128         if (!result) {
 129             XSRETURN_EMPTY;
 130         }
 131         /* Force mg_get  */
 132         RETVAL = newSVsv(*result);
 133         OUTPUT:
 134         RETVAL
 135 =pod
 136
 137 sub TIEHASH  { bless {}, $_[0] }
 138 sub STORE    { $_[0]->{$_[1]} = $_[2] }
 139 sub FETCH    { $_[0]->{$_[1]} }
 140 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
 141 sub NEXTKEY  { each %{$_[0]} }
 142 sub EXISTS   { exists $_[0]->{$_[1]} }
 143 sub DELETE   { delete $_[0]->{$_[1]} }
 144 sub CLEAR    { %{$_[0]} = () }
 145
 146 =cut
 147
 148 MODULE = XS::APItest            PACKAGE = XS::APItest
 149
 150 PROTOTYPES: DISABLE
 151
 152 void
 153 print_double(val)
 154         double val
 155         CODE:
 156         printf("%5.3f\n",val);
 157
 158 int
 159 have_long_double()
 160         CODE:
 161 #ifdef HAS_LONG_DOUBLE
 162         RETVAL = 1;
 163 #else
 164         RETVAL = 0;
 165 #endif
 166         OUTPUT:
 167         RETVAL
 168
 169 void
 170 print_long_double()
 171         CODE:
 172 #ifdef HAS_LONG_DOUBLE
 173 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
 174         long double val = 7.0;
 175         printf("%5.3" PERL_PRIfldbl "\n",val);
 176 #   else
 177         double val = 7.0;
 178         printf("%5.3f\n",val);
 179 #   endif
 180 #endif
 181
 182 void
 183 print_int(val)
 184         int val
 185         CODE:
 186         printf("%d\n",val);
 187
 188 void
 189 print_long(val)
 190         long val
 191         CODE:
 192         printf("%ld\n",val);
 193
 194 void
 195 print_float(val)
 196         float val
 197         CODE:
 198         printf("%5.3f\n",val);
 199
 200 void
 201 print_flush()
 202         CODE:
 203         fflush(stdout);
 204
 205 void
 206 mpushp()
 207         PPCODE:
 208         EXTEND(SP, 3);
 209         mPUSHp("one", 3);
 210         mPUSHp("two", 3);
 211         mPUSHp("three", 5);
 212         XSRETURN(3);
 213
 214 void
 215 mpushn()
 216         PPCODE:
 217         EXTEND(SP, 3);
 218         mPUSHn(0.5);
 219         mPUSHn(-0.25);
 220         mPUSHn(0.125);
 221         XSRETURN(3);
 222
 223 void
 224 mpushi()
 225         PPCODE:
 226         EXTEND(SP, 3);
 227         mPUSHi(-1);
 228         mPUSHi(2);
 229         mPUSHi(-3);
 230         XSRETURN(3);
 231
 232 void
 233 mpushu()
 234         PPCODE:
 235         EXTEND(SP, 3);
 236         mPUSHu(1);
 237         mPUSHu(2);
 238         mPUSHu(3);
 239         XSRETURN(3);
 240
 241 void
 242 mxpushp()
 243         PPCODE:
 244         mXPUSHp("one", 3);
 245         mXPUSHp("two", 3);
 246         mXPUSHp("three", 5);
 247         XSRETURN(3);
 248
 249 void
 250 mxpushn()
 251         PPCODE:
 252         mXPUSHn(0.5);
 253         mXPUSHn(-0.25);
 254         mXPUSHn(0.125);
 255         XSRETURN(3);
 256
 257 void
 258 mxpushi()
 259         PPCODE:
 260         mXPUSHi(-1);
 261         mXPUSHi(2);
 262         mXPUSHi(-3);
 263         XSRETURN(3);
 264
 265 void
 266 mxpushu()
 267         PPCODE:
 268         mXPUSHu(1);
 269         mXPUSHu(2);
 270         mXPUSHu(3);
 271         XSRETURN(3);
 272
 273
 274 void
 275 call_sv(sv, flags, ...)
 276     SV* sv
 277     I32 flags
 278     PREINIT:
 279         I32 i;
 280     PPCODE:
 281         for (i=0; i<items-2; i++)
 282             ST(i) = ST(i+2); /* pop first two args */
 283         PUSHMARK(SP);
 284         SP += items - 2;
 285         PUTBACK;
 286         i = call_sv(sv, flags);
 287         SPAGAIN;
 288         EXTEND(SP, 1);
 289         PUSHs(sv_2mortal(newSViv(i)));
 290
 291 void
 292 call_pv(subname, flags, ...)
 293     char* subname
 294     I32 flags
 295     PREINIT:
 296         I32 i;
 297     PPCODE:
 298         for (i=0; i<items-2; i++)
 299             ST(i) = ST(i+2); /* pop first two args */
 300         PUSHMARK(SP);
 301         SP += items - 2;
 302         PUTBACK;
 303         i = call_pv(subname, flags);
 304         SPAGAIN;
 305         EXTEND(SP, 1);
 306         PUSHs(sv_2mortal(newSViv(i)));
 307
 308 void
 309 call_method(methname, flags, ...)
 310     char* methname
 311     I32 flags
 312     PREINIT:
 313         I32 i;
 314     PPCODE:
 315         for (i=0; i<items-2; i++)
 316             ST(i) = ST(i+2); /* pop first two args */
 317         PUSHMARK(SP);
 318         SP += items - 2;
 319         PUTBACK;
 320         i = call_method(methname, flags);
 321         SPAGAIN;
 322         EXTEND(SP, 1);
 323         PUSHs(sv_2mortal(newSViv(i)));
 324
 325 void
 326 eval_sv(sv, flags)
 327     SV* sv
 328     I32 flags
 329     PREINIT:
 330         I32 i;
 331     PPCODE:
 332         PUTBACK;
 333         i = eval_sv(sv, flags);
 334         SPAGAIN;
 335         EXTEND(SP, 1);
 336         PUSHs(sv_2mortal(newSViv(i)));
 337
 338 SV*
 339 eval_pv(p, croak_on_error)
 340     const char* p
 341     I32 croak_on_error
 342     PREINIT:
 343         I32 i;
 344     PPCODE:
 345         PUTBACK;
 346         EXTEND(SP, 1);
 347         PUSHs(eval_pv(p, croak_on_error));
 348
 349 void
 350 require_pv(pv)
 351     const char* pv
 352     PREINIT:
 353         I32 i;
 354     PPCODE:
 355         PUTBACK;
 356         require_pv(pv);
 357
 358 int
 359 exception(throw_e)
 360     int throw_e
 361     OUTPUT:
 362         RETVAL
 363