In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/defdfed5e6b9e2f8b9451febd0406ed351042bb9?hp=b28e2c3cb7448b983edc991b66c9eb650488d89b>
- Log -----------------------------------------------------------------
commit defdfed5e6b9e2f8b9451febd0406ed351042bb9
Author: Zefram <zef...@fysh.org>
Date: Wed Sep 15 00:21:16 2010 +0100
add hv_copy_hints_hv and save_hints to the API
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 2 +
embed.fnc | 4 +-
embed.h | 8 +----
ext/XS-APItest/APItest.xs | 68 ++++++++++++++++++++++++++++++++++++++++++
ext/XS-APItest/t/copyhints.t | 10 ++++++
ext/XS-APItest/t/savehints.t | 10 ++++++
global.sym | 2 +
hv.c | 14 +++++++-
op.c | 2 +-
pp_ctl.c | 2 +-
proto.h | 4 ++-
scope.c | 2 +-
12 files changed, 114 insertions(+), 14 deletions(-)
create mode 100644 ext/XS-APItest/t/copyhints.t
create mode 100644 ext/XS-APItest/t/savehints.t
diff --git a/MANIFEST b/MANIFEST
index 5450c21..5492753 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3332,6 +3332,7 @@ ext/XS-APItest/t/blockhooks.t XS::APItest: tests for
PL_blockhooks
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
@@ -3344,6 +3345,7 @@ ext/XS-APItest/t/printf.t XS::APItest extension
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
diff --git a/embed.fnc b/embed.fnc
index 4f3690c..0f666d7 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -455,7 +455,7 @@ Apd |HV* |gv_stashpvn |NN const char* name|U32
namelen|I32 flags
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
@@ -1046,7 +1046,7 @@ Ap |void |save_generic_pvref|NN char** str
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
diff --git a/embed.h b/embed.h
index e7fbcf3..9e43d48 100644
--- a/embed.h
+++ b/embed.h
@@ -309,6 +309,7 @@
#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
@@ -853,9 +854,7 @@
#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
@@ -2763,8 +2762,7 @@
#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)
@@ -3311,9 +3309,7 @@
#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)
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 5ce9bfa..f8033e8 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1145,6 +1145,74 @@ bhk_record(bool on)
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;
diff --git a/ext/XS-APItest/t/copyhints.t b/ext/XS-APItest/t/copyhints.t
new file mode 100644
index 0000000..cf6abfd
--- /dev/null
+++ b/ext/XS-APItest/t/copyhints.t
@@ -0,0 +1,10 @@
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+BEGIN { XS::APItest::test_copyhints(); }
+ok 1;
+
+1;
diff --git a/ext/XS-APItest/t/savehints.t b/ext/XS-APItest/t/savehints.t
new file mode 100644
index 0000000..b6b21f3
--- /dev/null
+++ b/ext/XS-APItest/t/savehints.t
@@ -0,0 +1,10 @@
+use warnings;
+use strict;
+use Test::More tests => 1;
+
+use XS::APItest;
+
+BEGIN { XS::APItest::test_savehints(); }
+ok 1;
+
+1;
diff --git a/global.sym b/global.sym
index 4734a33..4ff4ea0 100644
--- a/global.sym
+++ b/global.sym
@@ -164,6 +164,7 @@ Perl_gv_stashpv
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
@@ -496,6 +497,7 @@ Perl_save_generic_pvref
Perl_save_shared_pvref
Perl_save_gp
Perl_save_hash
+Perl_save_hints
Perl_save_helem_flags
Perl_save_hptr
Perl_save_I16
diff --git a/hv.c b/hv.c
index 9f3ecd5..ade7e8c 100644
--- a/hv.c
+++ b/hv.c
@@ -1382,8 +1382,18 @@ Perl_newHVhv(pTHX_ HV *ohv)
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)
{
diff --git a/op.c b/op.c
index 8aa1cae..75a52c3 100644
--- a/op.c
+++ b/op.c
@@ -7018,7 +7018,7 @@ Perl_ck_eval(pTHX_ OP *o)
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;
}
diff --git a/pp_ctl.c b/pp_ctl.c
index 155313e..099d2ae 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3770,7 +3770,7 @@ PP(pp_hintseval)
{
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;
}
diff --git a/proto.h b/proto.h
index 4951a73..e581699 100644
--- a/proto.h
+++ b/proto.h
@@ -1017,7 +1017,9 @@ PERL_CALLCONV HV* Perl_gv_stashsv(pTHX_ SV* sv, I32 flags)
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 \
diff --git a/scope.c b/scope.c
index 046b338..95fe5f7 100644
--- a/scope.c
+++ b/scope.c
@@ -608,7 +608,7 @@ Perl_save_hints(pTHX)
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);
}
--
Perl5 Master Repository
