[perl #106282] Don’t crash cloning tied %^H

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.

diff --git a/hv.c b/hv.c
index 27ce6a5..7ce8048 100644 (file)
--- 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 7796727..b70f15e 100644 (file)
--- 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__