From cb1f05e8fe9a1c7a7e2de8048f1404df951311b0 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Wed, 21 Dec 2011 12:29:12 -0800
Subject: [PATCH] Copy hints from tied hh to inner compile scopes
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

Entries from a tied %^H were not being copied to inner compile-time
scopes, resulting in %^H appearing empty in BEGIN blocks, even
though the underlying he chain *was* being propagated properly (so
(caller)[10] at run time still worked.

I was surprised that, in writing tests for this, I produced another
crash.  I thought I had fixed them with 95cf23680 and 7ef9d42ce.  It
turns out that pp_helem doesn’t support hashes with null values.
(That’s a separate bug that needs fixing, since the XS API allows for
them.)  For now, cloning the hh properly stops pp_helem from getting a
null value.
---
 hv.c           |  4 ++--
 t/comp/hints.t | 31 +++++++++++++++++++++++++------
 2 files changed, 27 insertions(+), 8 deletions(-)

diff --git a/hv.c b/hv.c
index 28ddcd0..7d58438 100644
--- a/hv.c
+++ b/hv.c
@@ -1450,7 +1450,7 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
 {
     HV * const hv = newHV();
 
-    if (ohv && HvTOTALKEYS(ohv)) {
+    if (ohv) {
 	STRLEN hv_max = HvMAX(ohv);
 	STRLEN hv_fill = HvFILL(ohv);
 	HE *entry;
@@ -1463,7 +1463,7 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
 
 	hv_iterinit(ohv);
 	while ((entry = hv_iternext_flags(ohv, 0))) {
-	    SV *const sv = newSVsv(HeVAL(entry));
+	    SV *const sv = newSVsv(hv_iterval(ohv,entry));
 	    SV *heksv = HeSVKEY(entry);
 	    if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
 	    if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
diff --git a/t/comp/hints.t b/t/comp/hints.t
index b70f15e..15fbc5a 100644
--- a/t/comp/hints.t
+++ b/t/comp/hints.t
@@ -6,7 +6,7 @@ BEGIN {
     @INC = qw(. ../lib);
 }
 
-BEGIN { print "1..25\n"; }
+BEGIN { print "1..27\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -129,7 +129,9 @@ BEGIN {
 }
 
 # [perl #106282] Crash when tying %^H
-# Tying %^H does not and cannot work, but it should not crash.
+# Tying %^H should not result in a crash when the hint hash is cloned.
+# Hints should also be copied properly to inner scopes.  See also
+# [rt.cpan.org #73402].
 eval q`
     # Do something naughty enough, and you get your module mentioned in the
     # test suite. :-)
@@ -148,9 +150,26 @@ eval q`
 	tie( %^H, 'namespace::clean::_TieHintHash' ); # sabotage %^H
 	$^H{foo} = "bar"; # create an element in the tied hash
     }
-    { ; } # clone the tied hint hash
-`;
-print "ok 24 - no crash when cloning a tied hint hash\n";
+    { # clone the tied hint hash on scope entry
+	BEGIN {
+	    print "not " x ($^H{foo} ne 'bar'),
+		  "ok 24 - tied hint hash is copied to inner scope\n";
+	    %^H = ();
+	    tie( %^H, 'namespace::clean::_TieHintHash' );
+	    $^H{foo} = "bar";
+	}
+	{
+	    BEGIN{
+		print
+		  "not " x ($^H{foo} ne 'bar'),
+		  "ok 25 - tied empty hint hash is copied to inner scope\n"
+	    }    
+	}
+	1;
+    }
+    1;
+` or warn $@;
+print "ok 26 - no crash when cloning a tied hint hash\n";
 
 
 # Add new tests above this require, in case it fails.
@@ -162,7 +181,7 @@ my $result = runperl(
     stderr => 1
 );
 print "not " if length $result;
-print "ok 25 - double-freeing hints hash\n";
+print "ok 27 - double-freeing hints hash\n";
 print "# got: $result\n" if length $result;
 
 __END__
-- 
2.7.4