1 #define PERL_IN_XS_APITEST
9 /* A routine to test hv_delayfree_ent
10 (which itself is tested by testing on hv_free_ent */
12 typedef void (freeent_function)(pTHX_ HV *, register HE *);
15 test_freeent(freeent_function *f) {
18 HV *test_hash = newHV();
25 victim = (HE*)safemalloc(sizeof(HE));
27 /* Storing then deleting something should ensure that a hash entry is
29 hv_store(test_hash, "", 0, &PL_sv_yes, 0);
30 hv_delete(test_hash, "", 0, 0);
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 */
34 if (!PL_body_roots[HE_SVSLOT])
35 croak("PL_he_root is 0");
36 victim = PL_body_roots[HE_SVSLOT];
37 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
40 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
42 test_scalar = newSV(0);
43 SvREFCNT_inc(test_scalar);
44 victim->hent_val = test_scalar;
46 /* Need this little game else we free the temps on the return stack. */
47 results[0] = SvREFCNT(test_scalar);
49 results[1] = SvREFCNT(test_scalar);
50 f(aTHX_ test_hash, victim);
51 results[2] = SvREFCNT(test_scalar);
53 results[3] = SvREFCNT(test_scalar);
58 } while (++i < sizeof(results)/sizeof(results[0]));
60 /* Goodbye to our extra reference. */
61 SvREFCNT_dec(test_scalar);
64 MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
66 #define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
77 key = SvPV(key_sv, len);
78 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
91 key = SvPV(key_sv, len);
92 /* It's already mortal, so need to increase reference count. */
93 RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
98 store_ent(hash, key, value)
108 result = hv_store_ent(hash, key, copy, 0);
109 SvSetMagicSV(copy, value);
114 /* It's about to become mortal, so need to increase reference count.
116 RETVAL = SvREFCNT_inc(HeVAL(result));
122 store(hash, key_sv, value)
133 key = SvPV(key_sv, len);
135 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
136 SvSetMagicSV(copy, value);
141 /* It's about to become mortal, so need to increase reference count.
143 RETVAL = SvREFCNT_inc(*result);
158 key = SvPV(key_sv, len);
159 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
164 RETVAL = newSVsv(*result);
171 test_freeent(&Perl_hv_free_ent);
175 test_hv_delayfree_ent()
177 test_freeent(&Perl_hv_delayfree_ent);
182 sub TIEHASH { bless {}, $_[0] }
183 sub STORE { $_[0]->{$_[1]} = $_[2] }
184 sub FETCH { $_[0]->{$_[1]} }
185 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
186 sub NEXTKEY { each %{$_[0]} }
187 sub EXISTS { exists $_[0]->{$_[1]} }
188 sub DELETE { delete $_[0]->{$_[1]} }
189 sub CLEAR { %{$_[0]} = () }
193 MODULE = XS::APItest PACKAGE = XS::APItest
201 printf("%5.3f\n",val);
206 #ifdef HAS_LONG_DOUBLE
217 #ifdef HAS_LONG_DOUBLE
218 # if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
219 long double val = 7.0;
220 printf("%5.3" PERL_PRIfldbl "\n",val);
223 printf("%5.3f\n",val);
243 printf("%5.3f\n",val);
320 call_sv(sv, flags, ...)
326 for (i=0; i<items-2; i++)
327 ST(i) = ST(i+2); /* pop first two args */
331 i = call_sv(sv, flags);
334 PUSHs(sv_2mortal(newSViv(i)));
337 call_pv(subname, flags, ...)
343 for (i=0; i<items-2; i++)
344 ST(i) = ST(i+2); /* pop first two args */
348 i = call_pv(subname, flags);
351 PUSHs(sv_2mortal(newSViv(i)));
354 call_method(methname, flags, ...)
360 for (i=0; i<items-2; i++)
361 ST(i) = ST(i+2); /* pop first two args */
365 i = call_method(methname, flags);
368 PUSHs(sv_2mortal(newSViv(i)));
378 i = eval_sv(sv, flags);
381 PUSHs(sv_2mortal(newSViv(i)));
384 eval_pv(p, croak_on_error)
390 PUSHs(eval_pv(p, croak_on_error));
409 Perl_croak(aTHX_ "%s", pv);
414 RETVAL = newRV_inc((SV*)PL_strtab);