add hv_copy_hints_hv and save_hints to the API

diff --git a/MANIFEST b/MANIFEST
index 5450c21..5492753 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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);
     }