This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add simple exception handling macros for XS writers.
[perl5.git] / 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