ext/XS-APItest/t/Block.pm Helper for ./blockhooks.t
ext/XS-APItest/t/caller.t XS::APItest: tests for caller_cx
ext/XS-APItest/t/call.t XS::APItest extension
+ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API
ext/XS-APItest/t/exception.t XS::APItest extension
ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs
ext/XS-APItest/t/Markers.pm Helper for ./blockhooks.t
ext/XS-APItest/t/ptr_table.t Test ptr_table_* APIs
ext/XS-APItest/t/push.t XS::APItest extension
ext/XS-APItest/t/rmagical.t XS::APItest extension
+ext/XS-APItest/t/savehints.t test SAVEHINTS() API
ext/XS-APItest/t/svpeek.t XS::APItest extension
ext/XS-APItest/t/svsetsv.t Test behaviour of sv_setsv with/without PERL_CORE
ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temps
Apd |HV* |gv_stashsv |NN SV* sv|I32 flags
Apd |void |hv_clear |NULLOK HV *hv
: used in SAVEHINTS() and op.c
-poM |HV * |hv_copy_hints_hv|NULLOK HV *const ohv
+ApdR |HV * |hv_copy_hints_hv|NULLOK HV *const ohv
Ap |void |hv_delayfree_ent|NN HV *hv|NULLOK HE *entry
Abmd |SV* |hv_delete |NULLOK HV *hv|NN const char *key|I32 klen \
|I32 flags
Ap |void |save_shared_pvref|NN char** str
Ap |void |save_gp |NN GV* gv|I32 empty
Ap |HV* |save_hash |NN GV* gv
-p |void |save_hints
+Ap |void |save_hints
Amp |void |save_helem |NN HV *hv|NN SV *key|NN SV **sptr
Ap |void |save_helem_flags|NN HV *hv|NN SV *key|NN SV **sptr|const U32 flags
Ap |void |save_hptr |NN HV** hptr
#define gv_stashpvn Perl_gv_stashpvn
#define gv_stashsv Perl_gv_stashsv
#define hv_clear Perl_hv_clear
+#define hv_copy_hints_hv Perl_hv_copy_hints_hv
#define hv_delayfree_ent Perl_hv_delayfree_ent
#define hv_common Perl_hv_common
#define hv_common_key_len Perl_hv_common_key_len
#define save_shared_pvref Perl_save_shared_pvref
#define save_gp Perl_save_gp
#define save_hash Perl_save_hash
-#ifdef PERL_CORE
#define save_hints Perl_save_hints
-#endif
#define save_helem_flags Perl_save_helem_flags
#define save_hptr Perl_save_hptr
#define save_I16 Perl_save_I16
#define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c)
#define gv_stashsv(a,b) Perl_gv_stashsv(aTHX_ a,b)
#define hv_clear(a) Perl_hv_clear(aTHX_ a)
-#ifdef PERL_CORE
-#endif
+#define hv_copy_hints_hv(a) Perl_hv_copy_hints_hv(aTHX_ a)
#define hv_delayfree_ent(a,b) Perl_hv_delayfree_ent(aTHX_ a,b)
#define hv_common(a,b,c,d,e,f,g,h) Perl_hv_common(aTHX_ a,b,c,d,e,f,g,h)
#define hv_common_key_len(a,b,c,d,e,f) Perl_hv_common_key_len(aTHX_ a,b,c,d,e,f)
#define save_shared_pvref(a) Perl_save_shared_pvref(aTHX_ a)
#define save_gp(a,b) Perl_save_gp(aTHX_ a,b)
#define save_hash(a) Perl_save_hash(aTHX_ a)
-#ifdef PERL_CORE
#define save_hints() Perl_save_hints(aTHX)
-#endif
#define save_helem_flags(a,b,c,d) Perl_save_helem_flags(aTHX_ a,b,c,d)
#define save_hptr(a) Perl_save_hptr(aTHX_ a)
#define save_I16(a) Perl_save_I16(aTHX_ a)
if (on)
av_clear(MY_CXT.bhkav);
+void
+test_savehints()
+ PREINIT:
+ SV **svp, *sv;
+ CODE:
+#define store_hint(KEY, VALUE) \
+ sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), KEY, 1), (VALUE))
+#define hint_ok(KEY, EXPECT) \
+ ((svp = hv_fetchs(GvHV(PL_hintgv), KEY, 0)) && \
+ (sv = *svp) && SvIV(sv) == (EXPECT) && \
+ (sv = cop_hints_fetchpvs(&PL_compiling, KEY)) && \
+ SvIV(sv) == (EXPECT))
+#define check_hint(KEY, EXPECT) \
+ do { if (!hint_ok(KEY, EXPECT)) croak("fail"); } while(0)
+ PL_hints |= HINT_LOCALIZE_HH;
+ ENTER;
+ SAVEHINTS();
+ PL_hints &= HINT_INTEGER;
+ store_hint("t0", 123);
+ store_hint("t1", 456);
+ if (PL_hints & HINT_INTEGER) croak("fail");
+ check_hint("t0", 123); check_hint("t1", 456);
+ ENTER;
+ SAVEHINTS();
+ if (PL_hints & HINT_INTEGER) croak("fail");
+ check_hint("t0", 123); check_hint("t1", 456);
+ PL_hints |= HINT_INTEGER;
+ store_hint("t0", 321);
+ if (!(PL_hints & HINT_INTEGER)) croak("fail");
+ check_hint("t0", 321); check_hint("t1", 456);
+ LEAVE;
+ if (PL_hints & HINT_INTEGER) croak("fail");
+ check_hint("t0", 123); check_hint("t1", 456);
+ ENTER;
+ SAVEHINTS();
+ if (PL_hints & HINT_INTEGER) croak("fail");
+ check_hint("t0", 123); check_hint("t1", 456);
+ store_hint("t1", 654);
+ if (PL_hints & HINT_INTEGER) croak("fail");
+ check_hint("t0", 123); check_hint("t1", 654);
+ LEAVE;
+ if (PL_hints & HINT_INTEGER) croak("fail");
+ check_hint("t0", 123); check_hint("t1", 456);
+ LEAVE;
+#undef store_hint
+#undef hint_ok
+#undef check_hint
+
+void
+test_copyhints()
+ PREINIT:
+ HV *a, *b;
+ CODE:
+ PL_hints |= HINT_LOCALIZE_HH;
+ ENTER;
+ SAVEHINTS();
+ sv_setiv_mg(*hv_fetchs(GvHV(PL_hintgv), "t0", 1), 123);
+ if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
+ a = newHVhv(GvHV(PL_hintgv));
+ sv_2mortal((SV*)a);
+ sv_setiv_mg(*hv_fetchs(a, "t0", 1), 456);
+ if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 123) croak("fail");
+ b = hv_copy_hints_hv(a);
+ sv_2mortal((SV*)b);
+ sv_setiv_mg(*hv_fetchs(b, "t0", 1), 789);
+ if (SvIV(cop_hints_fetchpvs(&PL_compiling, "t0")) != 789) croak("fail");
+ LEAVE;
+
BOOT:
{
HV* stash;
--- /dev/null
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+BEGIN { XS::APItest::test_copyhints(); }
+ok 1;
+
+1;
--- /dev/null
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+BEGIN { XS::APItest::test_savehints(); }
+ok 1;
+
+1;
Perl_gv_stashpvn
Perl_gv_stashsv
Perl_hv_clear
+Perl_hv_copy_hints_hv
Perl_hv_delayfree_ent
Perl_hv_delete
Perl_hv_delete_ent
Perl_save_shared_pvref
Perl_save_gp
Perl_save_hash
+Perl_save_hints
Perl_save_helem_flags
Perl_save_hptr
Perl_save_I16
return hv;
}
-/* A rather specialised version of newHVhv for copying %^H, ensuring all the
- magic stays on it. */
+/*
+=for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
+
+A specialised version of L</newHVhv> for copying C<%^H>. I<ohv> must be
+a pointer to a hash (which may have C<%^H> magic, but should be generally
+non-magical), or C<NULL> (interpreted as an empty hash). The content
+of I<ohv> is copied to a new hash, which has the C<%^H>-specific magic
+added to it. A pointer to the new hash is returned.
+
+=cut
+*/
+
HV *
Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
{
if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up. */
OP *hhop = newSVOP(OP_HINTSEVAL, 0,
- MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
+ MUTABLE_SV(hv_copy_hints_hv(GvHV(PL_hintgv))));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
}
{
dVAR;
dSP;
- mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
+ mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
RETURN;
}
assert(sv)
PERL_CALLCONV void Perl_hv_clear(pTHX_ HV *hv);
-PERL_CALLCONV HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv);
+PERL_CALLCONV HV * Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
+ __attribute__warn_unused_result__;
+
PERL_CALLCONV void Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_HV_DELAYFREE_ENT \
if (PL_hints & HINT_LOCALIZE_HH) {
save_pushptri32ptr(GvHV(PL_hintgv), PL_hints,
PL_compiling.cop_hints_hash, SAVEt_HINTS);
- GvHV(PL_hintgv) = Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv));
+ GvHV(PL_hintgv) = hv_copy_hints_hv(GvHV(PL_hintgv));
} else {
save_pushi32ptr(PL_hints, PL_compiling.cop_hints_hash, SAVEt_HINTS);
}