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