This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: encoding neutral unpack
[perl5.git] / ext / XS / APItest / APItest.xs
CommitLineData
3e61d65a
JH
1#include "EXTERN.h"
2#include "perl.h"
3#include "XSUB.h"
4
0ca3a874
MHM
5static void throws_exception(int throw_e)
6{
7 if (throw_e)
8 croak("boo\n");
9}
10
11static 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}
0314122a
NC
31
32MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
33
028f8eaa
MHM
34#define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
35
0314122a
NC
36bool
37exists(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);
028f8eaa 46 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
0314122a
NC
47 OUTPUT:
48 RETVAL
49
b60cf05a
NC
50SV *
51delete(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. */
028f8eaa 61 RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
b60cf05a
NC
62 OUTPUT:
63 RETVAL
64
65SV *
858117f8
NC
66store_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
89SV *
b60cf05a
NC
90store(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);
028f8eaa 103 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
858117f8 104 SvSetMagicSV(copy, value);
b60cf05a
NC
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
116SV *
117fetch(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);
028f8eaa 127 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
b60cf05a
NC
128 if (!result) {
129 XSRETURN_EMPTY;
130 }
131 /* Force mg_get */
132 RETVAL = newSVsv(*result);
133 OUTPUT:
134 RETVAL
0314122a
NC
135=pod
136
137sub TIEHASH { bless {}, $_[0] }
138sub STORE { $_[0]->{$_[1]} = $_[2] }
139sub FETCH { $_[0]->{$_[1]} }
140sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
141sub NEXTKEY { each %{$_[0]} }
142sub EXISTS { exists $_[0]->{$_[1]} }
143sub DELETE { delete $_[0]->{$_[1]} }
144sub CLEAR { %{$_[0]} = () }
145
146=cut
147
3e61d65a
JH
148MODULE = XS::APItest PACKAGE = XS::APItest
149
150PROTOTYPES: DISABLE
151
152void
153print_double(val)
154 double val
155 CODE:
156 printf("%5.3f\n",val);
157
158int
159have_long_double()
160 CODE:
161#ifdef HAS_LONG_DOUBLE
162 RETVAL = 1;
163#else
164 RETVAL = 0;
165#endif
cabb36f0
CN
166 OUTPUT:
167 RETVAL
3e61d65a
JH
168
169void
170print_long_double()
171 CODE:
172#ifdef HAS_LONG_DOUBLE
fc0bf671 173# if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
3e61d65a
JH
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
182void
3e61d65a
JH
183print_int(val)
184 int val
185 CODE:
186 printf("%d\n",val);
187
188void
189print_long(val)
190 long val
191 CODE:
192 printf("%ld\n",val);
193
194void
195print_float(val)
196 float val
197 CODE:
198 printf("%5.3f\n",val);
9d911683
NIS
199
200void
201print_flush()
202 CODE:
203 fflush(stdout);
d4b90eee
SH
204
205void
206mpushp()
207 PPCODE:
208 EXTEND(SP, 3);
209 mPUSHp("one", 3);
210 mPUSHp("two", 3);
211 mPUSHp("three", 5);
212 XSRETURN(3);
213
214void
215mpushn()
216 PPCODE:
217 EXTEND(SP, 3);
218 mPUSHn(0.5);
219 mPUSHn(-0.25);
220 mPUSHn(0.125);
221 XSRETURN(3);
222
223void
224mpushi()
225 PPCODE:
226 EXTEND(SP, 3);
d75b63cf
MHM
227 mPUSHi(-1);
228 mPUSHi(2);
229 mPUSHi(-3);
d4b90eee
SH
230 XSRETURN(3);
231
232void
233mpushu()
234 PPCODE:
235 EXTEND(SP, 3);
d75b63cf
MHM
236 mPUSHu(1);
237 mPUSHu(2);
238 mPUSHu(3);
d4b90eee
SH
239 XSRETURN(3);
240
241void
242mxpushp()
243 PPCODE:
244 mXPUSHp("one", 3);
245 mXPUSHp("two", 3);
246 mXPUSHp("three", 5);
247 XSRETURN(3);
248
249void
250mxpushn()
251 PPCODE:
252 mXPUSHn(0.5);
253 mXPUSHn(-0.25);
254 mXPUSHn(0.125);
255 XSRETURN(3);
256
257void
258mxpushi()
259 PPCODE:
d75b63cf
MHM
260 mXPUSHi(-1);
261 mXPUSHi(2);
262 mXPUSHi(-3);
d4b90eee
SH
263 XSRETURN(3);
264
265void
266mxpushu()
267 PPCODE:
d75b63cf
MHM
268 mXPUSHu(1);
269 mXPUSHu(2);
270 mXPUSHu(3);
d4b90eee 271 XSRETURN(3);
d1f347d7
DM
272
273
274void
275call_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
291void
292call_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
308void
309call_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
325void
326eval_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
338SV*
339eval_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
349void
350require_pv(pv)
351 const char* pv
352 PREINIT:
353 I32 i;
354 PPCODE:
355 PUTBACK;
356 require_pv(pv);
357
0ca3a874
MHM
358int
359exception(throw_e)
360 int throw_e
361 OUTPUT:
362 RETVAL
d1f347d7 363