From 95cf23680e00af63884a0f886d7434eb1b930377 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Tue, 20 Dec 2011 15:25:18 -0800
Subject: =?UTF-8?q?[perl=20#106282]=20Don=E2=80=99t=20crash=20cloning=20ti?=
 =?UTF-8?q?ed=20%^H?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

When hv_iternext_flags is called on a tied hash, the hash entry (HE)
that it returns has no value.  Perl_hv_copy_hints_hv, added in commit
5b9c067131, was assuming that it would have a value and calling
sv_magic on it, resulting in a crash.

Commit b50b205 made namespace::clean’s test suite crash, because
strict.pm started using %^H.  It was already possible to crash
namespace::clean with other hh-using pragmata, like sort:

    # namespace::clean 0.21 only uses ties in the absence of B:H:EOS
    use Devel::Hide 'B::Hooks::EndOfScope';
    use sort "stable";
    use namespace::clean;
    use sort "stable";
    {;}

It was possible to trigger the crash with no modules like this:

    package namespace::clean::_TieHintHash;

    sub TIEHASH  { bless[] }
    sub STORE    { $_[0][0]{$_[1]} = $_[2] }
    sub FETCH    { $_[0][0]{$_[1]} }
    sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
    sub NEXTKEY  { each %{$_[0][0]} }

    package main;

    BEGIN {
	$^H{foo} = "bar";
	tie( %^H, 'namespace::clean::_TieHintHash' );
	$^H{foo} = "bar";
    }
    { ; }

This commit puts in a simple null check before calling sv_magic.  Tied
hint hashes still do not work, but they now only work as badly as in
5.8 (i.e., they don’t crash).

I don’t think tied hint hashes can ever be made to work properly, even
if we do make Perl_hv_copy_hints_hv copy the hash properly, because in
the scope where %^H is tied, the tie magic takes precedence over hint
magic, preventing the underlying he chain from being updated.  So
hints set in that scope will just not stick.
---
 hv.c           |  2 +-
 t/comp/hints.t | 27 +++++++++++++++++++++++++--
 2 files changed, 26 insertions(+), 3 deletions(-)

diff --git a/hv.c b/hv.c
index 27ce6a5759..7ce8048075 100644
--- a/hv.c
+++ b/hv.c
@@ -1465,7 +1465,7 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
 	while ((entry = hv_iternext_flags(ohv, 0))) {
 	    SV *const sv = newSVsv(HeVAL(entry));
 	    SV *heksv = newSVhek(HeKEY_hek(entry));
-	    sv_magic(sv, NULL, PERL_MAGIC_hintselem,
+	    if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
 		     (char *)heksv, HEf_SVKEY);
 	    SvREFCNT_dec(heksv);
 	    (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
diff --git a/t/comp/hints.t b/t/comp/hints.t
index 7796727aee..b70f15eab1 100644
--- a/t/comp/hints.t
+++ b/t/comp/hints.t
@@ -6,7 +6,7 @@ BEGIN {
     @INC = qw(. ../lib);
 }
 
-BEGIN { print "1..24\n"; }
+BEGIN { print "1..25\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -128,6 +128,29 @@ BEGIN {
 	"ok 23 - \$^H{foo} correct after /unicode/i (res=$res)\n";
 }
 
+# [perl #106282] Crash when tying %^H
+# Tying %^H does not and cannot work, but it should not crash.
+eval q`
+    # Do something naughty enough, and you get your module mentioned in the
+    # test suite. :-)
+    package namespace::clean::_TieHintHash;
+
+    sub TIEHASH  { bless[] }
+    sub STORE    { $_[0][0]{$_[1]} = $_[2] }
+    sub FETCH    { $_[0][0]{$_[1]} }
+    sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
+    sub NEXTKEY  { each %{$_[0][0]} }
+
+    package main;
+
+    BEGIN {
+	$^H{foo} = "bar"; # activate localisation magic
+	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";
 
 
 # Add new tests above this require, in case it fails.
@@ -139,7 +162,7 @@ my $result = runperl(
     stderr => 1
 );
 print "not " if length $result;
-print "ok 24 - double-freeing hints hash\n";
+print "ok 25 - double-freeing hints hash\n";
 print "# got: $result\n" if length $result;
 
 __END__
-- 
cgit v1.2.1