Automatically set HINT_LOCALIZE_HH whenever %^H is modified.

p4raw-id: //depot/perl@27666

diff --git a/embed.fnc b/embed.fnc
index af21a14..d3cb75d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -285,6 +285,7 @@ Apd |HV*    |gv_stashpv     |NN const char* name|I32 create
 Apd    |HV*    |gv_stashpvn    |NN const char* name|U32 namelen|I32 create
 Apd    |HV*    |gv_stashsv     |NULLOK SV* sv|I32 create
 Apd    |void   |hv_clear       |NULLOK HV* tb
+poM    |HV *   |hv_copy_hints_hv|NN HV *const ohv
 Ap     |void   |hv_delayfree_ent|NN HV* hv|NULLOK HE* entry
 Apd    |SV*    |hv_delete      |NULLOK HV* tb|NN const char* key|I32 klen|I32 flags
 Apd    |SV*    |hv_delete_ent  |NULLOK HV* tb|NN SV* key|I32 flags|U32 hash

diff --git a/embed.h b/embed.h
index b8c279f..febc317 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -2438,6 +2438,8 @@
 #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_delayfree_ent(a,b)  Perl_hv_delayfree_ent(aTHX_ a,b)
 #define hv_delete(a,b,c,d)     Perl_hv_delete(aTHX_ a,b,c,d)
 #define hv_delete_ent(a,b,c,d) Perl_hv_delete_ent(aTHX_ a,b,c,d)

diff --git a/hv.c b/hv.c
index 4565cc0..fe74e87 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -1491,6 +1491,39 @@ Perl_newHVhv(pTHX_ HV *ohv)
     return hv;
 }
 
+/* A rather specialised version of newHVhv for copying %^H, ensuring all the
+   magic stays on it.  */
+HV *
+Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
+{
+    HV * const hv = newHV();
+    STRLEN hv_fill;
+
+    if (ohv && (hv_fill = HvFILL(ohv))) {
+       STRLEN hv_max = HvMAX(ohv);
+       HE *entry;
+       const I32 riter = HvRITER_get(ohv);
+       HE * const eiter = HvEITER_get(ohv);
+
+       while (hv_max && hv_max + 1 >= hv_fill * 2)
+           hv_max = hv_max / 2;
+       HvMAX(hv) = hv_max;
+
+       hv_iterinit(ohv);
+       while ((entry = hv_iternext_flags(ohv, 0))) {
+           SV *const sv = newSVsv(HeVAL(entry));
+           sv_magic(sv, NULL, PERL_MAGIC_hintselem,
+                    (char *)newSVhek (HeKEY_hek(entry)), HEf_SVKEY);
+           hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
+                          sv, HeHASH(entry), HeKFLAGS(entry));
+       }
+       HvRITER_set(ohv, riter);
+       HvEITER_set(ohv, eiter);
+    }
+    hv_magic(hv, NULL, PERL_MAGIC_hints);
+    return hv;
+}
+
 void
 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
 {

diff --git a/lib/feature.pm b/lib/feature.pm
index 4f03329..d4975e4 100644 (file)
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -1,7 +1,6 @@
 package feature;
 
 our $VERSION = '1.00';
-$feature::hint_bits = 0x00020000; # HINT_LOCALIZE_HH
 
 # (feature name) => (internal name, used in %^H)
 my %feature = (
@@ -93,8 +92,6 @@ to C<use feature qw(switch ~~ say err)>.
 =cut
 
 sub import {
-    $^H |= $feature::hint_bits;        # Need this or %^H won't work
-
     my $class = shift;
     if (@_ == 0) {
        require Carp;

diff --git a/lib/sort.pm b/lib/sort.pm
index 326724b..529077e 100644 (file)
--- a/lib/sort.pm
+++ b/lib/sort.pm
@@ -5,8 +5,6 @@ our $VERSION = '2.00';
 # The hints for pp_sort are now stored in $^H{sort}; older versions
 # of perl used the global variable $sort::hints. -- rjh 2005-12-19
 
-$sort::hint_bits = 0x00020000; # HINT_LOCALIZE_HH
-
 $sort::quicksort_bit   = 0x00000001;
 $sort::mergesort_bit   = 0x00000002;
 $sort::sort_bits       = 0x000000FF; # allow 256 different ones

diff --git a/mg.c b/mg.c
index 615a273..d8f4e0e 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2857,6 +2857,10 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
        it's NULL. If needed for threads, the alternative could lock a mutex,
        or take other more complex action.  */
 
+    /* Something changed in %^H, so it will need to be restored on scope exit.
+       Doing this here saves a lot of doing it manually in perl code (and
+       forgetting to do it, and consequent subtle errors.  */
+    PL_hints |= HINT_LOCALIZE_HH;
     PL_compiling.cop_hints
        = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
                                 (SV *)mg->mg_ptr, newSVsv(sv));
@@ -2876,6 +2880,7 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
     dVAR;
     assert(mg->mg_len == HEf_SVKEY);
 
+    PL_hints |= HINT_LOCALIZE_HH;
     PL_compiling.cop_hints
        = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
                                 (SV *)mg->mg_ptr, &PL_sv_placeholder);

diff --git a/op.c b/op.c
index 0d77f62..31b8e8d 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5937,7 +5937,8 @@ Perl_ck_eval(pTHX_ OP *o)
     o->op_targ = (PADOFFSET)PL_hints;
     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_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
+       OP *hhop = newSVOP(OP_CONST, 0,
+                          (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
        cUNOPo->op_first->op_sibling = hhop;
        o->op_private |= OPpEVAL_HAS_HH;
     }

diff --git a/proto.h b/proto.h
index 2be599e..e9a2a7b 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -657,6 +657,9 @@ PERL_CALLCONV HV*   Perl_gv_stashpvn(pTHX_ const char* name, U32 namelen, I32 crea
 
 PERL_CALLCONV HV*      Perl_gv_stashsv(pTHX_ SV* sv, I32 create);
 PERL_CALLCONV void     Perl_hv_clear(pTHX_ HV* tb);
+PERL_CALLCONV HV *     Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
+                       __attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV void     Perl_hv_delayfree_ent(pTHX_ HV* hv, HE* entry)
                        __attribute__nonnull__(pTHX_1);
 

diff --git a/scope.c b/scope.c
index 5e4193a..b4ecd65 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -895,8 +895,28 @@ Perl_leave_scope(pTHX_ I32 base)
            if (PL_hints & HINT_LOCALIZE_HH) {
                SvREFCNT_dec((SV*)GvHV(PL_hintgv));
                GvHV(PL_hintgv) = (HV*)SSPOPPTR;
+               assert(GvHV(PL_hintgv));
+           } else if (!GvHV(PL_hintgv)) {
+               /* Need to add a new one manually, else gv_fetchpv() can
+                  add one in this code:
+                  
+                  if (SvTYPE(gv) == SVt_PVGV) {
+                      if (add) {
+                      GvMULTI_on(gv);
+                      gv_init_sv(gv, sv_type);
+                      if (*name=='!' && sv_type == SVt_PVHV && len==1)
+                          require_errno(gv);
+                      }
+                      return gv;
+                  }
+
+                  and it won't have the magic set.  */
+
+               HV *const hv = newHV();
+               hv_magic(hv, NULL, PERL_MAGIC_hints);
+               GvHV(PL_hintgv) = hv;
            }
-                   
+           assert(GvHV(PL_hintgv));
            break;
        case SAVEt_COMPPAD:
            PL_comppad = (PAD*)SSPOPPTR;

diff --git a/scope.h b/scope.h
index debae28..74ab22b 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -153,7 +153,7 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
        SSCHECK(4);                                     \
        if (PL_hints & HINT_LOCALIZE_HH) {              \
            SSPUSHPTR(GvHV(PL_hintgv));                 \
-           GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv)); \
+           GvHV(PL_hintgv) = Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)); \
        }                                               \
        if (PL_compiling.cop_hints) {                   \
            PL_compiling.cop_hints->refcounted_he_refcnt++;     \

diff --git a/t/lib/mypragma.pm b/t/lib/mypragma.pm
index d1f52c6..45244f6 100644 (file)
--- a/t/lib/mypragma.pm
+++ b/t/lib/mypragma.pm
@@ -31,7 +31,6 @@ use warnings;
 
 sub import {
     $^H{mypragma} = 1;
-    $^H |= 0x00020000;
 }
 
 sub unimport {