Don’t double-free hint hash if copying dies

In this horrendous piece of code, the attempt to clone GvHV(PL_hintgv)
in save_hints dies because the NEXTKEY method cannot be found.  But
that happens while GvHV(PL_hintgv) still points to the old value.  So
the old hash gets freed in the new scope (when it unwinds due to the
error in trying to find NEXTKEY) and then gets freed in the outer
scope, too, resulting in the dreaded ‘Attempt to free unrefer-
enced scalar’.

    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]} }
  # Intentionally commented out:
  #  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

The solution is to set GvHV(PL_hintgv) to NULL when copying it.

diff --git a/scope.c b/scope.c
index 53bc9df..fbd92a9 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -594,8 +594,10 @@ Perl_save_hints(pTHX)
     dVAR;
     COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
     if (PL_hints & HINT_LOCALIZE_HH) {
-       save_pushptri32ptr(GvHV(PL_hintgv), PL_hints, save_cophh, SAVEt_HINTS);
-       GvHV(PL_hintgv) = hv_copy_hints_hv(GvHV(PL_hintgv));
+       HV *oldhh = GvHV(PL_hintgv);
+       save_pushptri32ptr(oldhh, PL_hints, save_cophh, SAVEt_HINTS);
+       GvHV(PL_hintgv) = NULL; /* in case copying dies */
+       GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
     } else {
        save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS);
     }

diff --git a/t/comp/hints.t b/t/comp/hints.t
index 15fbc5a..835e1e2 100644 (file)
--- a/t/comp/hints.t
+++ b/t/comp/hints.t
@@ -6,7 +6,7 @@ BEGIN {
     @INC = qw(. ../lib);
 }
 
-BEGIN { print "1..27\n"; }
+BEGIN { print "1..28\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -171,6 +171,33 @@ eval q`
 ` or warn $@;
 print "ok 26 - no crash when cloning a tied hint hash\n";
 
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w = shift };
+    eval q`
+       package namespace::clean::_TieHintHasi;
+    
+       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]} }
+      # Intentionally commented out:
+      #  sub NEXTKEY  { each %{$_[0][0]} }
+    
+       package main;
+    
+       BEGIN {
+           $^H{foo} = "bar"; # activate localisation magic
+           tie( %^H, 'namespace::clean::_TieHintHasi' ); # sabotage %^H
+           $^H{foo} = "bar"; # create an element in the tied hash
+       }
+       { ; } # clone the tied hint hash
+    `;
+    print "not " if $w;
+    print "ok 27 - double-freeing explosive tied hints hash\n";
+    print "# got: $w" if $w;
+}
+
 
 # Add new tests above this require, in case it fails.
 require './test.pl';
@@ -181,7 +208,7 @@ my $result = runperl(
     stderr => 1
 );
 print "not " if length $result;
-print "ok 27 - double-freeing hints hash\n";
+print "ok 28 - double-freeing hints hash\n";
 print "# got: $result\n" if length $result;
 
 __END__