From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 1 Apr 2006 21:17:46 +0000 (+0000)
Subject: Automatically set HINT_LOCALIZE_HH whenever %^H is modified.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5b9c067131ee63b4afa00d1d71c771377deb6ff9;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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 {