source: trunk/essentials/dev-lang/perl/ext/XS/APItest/APItest.xs@ 3212

Last change on this file since 3212 was 3181, checked in by bird, 19 years ago

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