1 #define PERL_IN_XS_APITEST
9 #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION
18 /* indirect functions to test the [pa]MY_CXT macros */
21 my_cxt_getint_p(pMY_CXT)
27 my_cxt_setint_p(pMY_CXT_ int i)
33 my_cxt_getsv_interp(void)
35 #ifdef PERL_IMPLICIT_CONTEXT
37 dMY_CXT_INTERP(my_perl);
45 my_cxt_setsv_p(SV* sv _pMY_CXT)
51 /* from exception.c */
54 /* from core_or_not.inc */
55 bool sv_setsv_cow_hashkey_core(void);
56 bool sv_setsv_cow_hashkey_notcore(void);
58 /* A routine to test hv_delayfree_ent
59 (which itself is tested by testing on hv_free_ent */
61 typedef void (freeent_function)(pTHX_ HV *, register HE *);
64 test_freeent(freeent_function *f) {
67 HV *test_hash = newHV();
74 victim = (HE*)safemalloc(sizeof(HE));
76 /* Storing then deleting something should ensure that a hash entry is
78 hv_store(test_hash, "", 0, &PL_sv_yes, 0);
79 hv_delete(test_hash, "", 0, 0);
81 /* We need to "inline" new_he here as it's static, and the functions we
82 test expect to be able to call del_HE on the HE */
83 if (!PL_body_roots[HE_SVSLOT])
84 croak("PL_he_root is 0");
85 victim = (HE*) PL_body_roots[HE_SVSLOT];
86 PL_body_roots[HE_SVSLOT] = HeNEXT(victim);
89 victim->hent_hek = Perl_share_hek(aTHX_ "", 0, 0);
91 test_scalar = newSV(0);
92 SvREFCNT_inc(test_scalar);
93 HeVAL(victim) = test_scalar;
95 /* Need this little game else we free the temps on the return stack. */
96 results[0] = SvREFCNT(test_scalar);
98 results[1] = SvREFCNT(test_scalar);
99 f(aTHX_ test_hash, victim);
100 results[2] = SvREFCNT(test_scalar);
102 results[3] = SvREFCNT(test_scalar);
107 } while (++i < sizeof(results)/sizeof(results[0]));
109 /* Goodbye to our extra reference. */
110 SvREFCNT_dec(test_scalar);
113 MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash
115 #define UTF8KLEN(sv, len) (SvUTF8(sv) ? -(I32)len : (I32)len)
126 key = SvPV(key_sv, len);
127 RETVAL = hv_exists(hash, key, UTF8KLEN(key_sv, len));
140 key = SvPV(key_sv, len);
141 /* It's already mortal, so need to increase reference count. */
142 RETVAL = SvREFCNT_inc(hv_delete(hash, key, UTF8KLEN(key_sv, len), 0));
147 store_ent(hash, key, value)
157 result = hv_store_ent(hash, key, copy, 0);
158 SvSetMagicSV(copy, value);
163 /* It's about to become mortal, so need to increase reference count.
165 RETVAL = SvREFCNT_inc(HeVAL(result));
171 store(hash, key_sv, value)
182 key = SvPV(key_sv, len);
184 result = hv_store(hash, key, UTF8KLEN(key_sv, len), copy, 0);
185 SvSetMagicSV(copy, value);
190 /* It's about to become mortal, so need to increase reference count.
192 RETVAL = SvREFCNT_inc(*result);
207 key = SvPV(key_sv, len);
208 result = hv_fetch(hash, key, UTF8KLEN(key_sv, len), 0);
213 RETVAL = newSVsv(*result);
220 test_freeent(&Perl_hv_free_ent);
224 test_hv_delayfree_ent()
226 test_freeent(&Perl_hv_delayfree_ent);
230 test_share_unshare_pvn(input)
239 pvx = SvPV(input, len);
240 PERL_HASH(hash, pvx, len);
241 p = sharepvn(pvx, len, hash);
242 RETVAL = newSVpvn(p, len);
243 unsharepvn(p, len, hash);
248 refcounted_he_exists(key, level=0)
253 croak("level must be zero, not %"IVdf, level);
255 RETVAL = (Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
257 != &PL_sv_placeholder);
263 refcounted_he_fetch(key, level=0)
268 croak("level must be zero, not %"IVdf, level);
270 RETVAL = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, key,
272 SvREFCNT_inc(RETVAL);
279 sub TIEHASH { bless {}, $_[0] }
280 sub STORE { $_[0]->{$_[1]} = $_[2] }
281 sub FETCH { $_[0]->{$_[1]} }
282 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
283 sub NEXTKEY { each %{$_[0]} }
284 sub EXISTS { exists $_[0]->{$_[1]} }
285 sub DELETE { delete $_[0]->{$_[1]} }
286 sub CLEAR { %{$_[0]} = () }
290 MODULE = XS::APItest PACKAGE = XS::APItest
298 MY_CXT.sv = newSVpv("initial",0);
305 MY_CXT.sv = newSVpv("initial_clone",0);
311 printf("%5.3f\n",val);
316 #ifdef HAS_LONG_DOUBLE
327 #ifdef HAS_LONG_DOUBLE
328 # if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
329 long double val = 7.0;
330 printf("%5.3" PERL_PRIfldbl "\n",val);
333 printf("%5.3f\n",val);
353 printf("%5.3f\n",val);
430 call_sv(sv, flags, ...)
436 for (i=0; i<items-2; i++)
437 ST(i) = ST(i+2); /* pop first two args */
441 i = call_sv(sv, flags);
444 PUSHs(sv_2mortal(newSViv(i)));
447 call_pv(subname, flags, ...)
453 for (i=0; i<items-2; i++)
454 ST(i) = ST(i+2); /* pop first two args */
458 i = call_pv(subname, flags);
461 PUSHs(sv_2mortal(newSViv(i)));
464 call_method(methname, flags, ...)
470 for (i=0; i<items-2; i++)
471 ST(i) = ST(i+2); /* pop first two args */
475 i = call_method(methname, flags);
478 PUSHs(sv_2mortal(newSViv(i)));
488 i = eval_sv(sv, flags);
491 PUSHs(sv_2mortal(newSViv(i)));
494 eval_pv(p, croak_on_error)
500 PUSHs(eval_pv(p, croak_on_error));
520 Perl_croak(aTHX_ "%s", SvPV_nolen(sv));
523 Perl_croak(aTHX_ NULL);
529 RETVAL = newRV_inc((SV*)PL_strtab);
537 RETVAL = my_cxt_getint_p(aMY_CXT);
546 my_cxt_setint_p(aMY_CXT_ i);
552 ST(0) = my_cxt_getsv_interp();
560 SvREFCNT_dec(MY_CXT.sv);
561 my_cxt_setsv_p(sv _aMY_CXT);
565 sv_setsv_cow_hashkey_core()
568 sv_setsv_cow_hashkey_notcore()