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