stop %^H pointing to being-freed hash; #112326

The leave_scope() action SAVEt_HINTS does the following to
GvHV(PL_hintgv): first it SvREFCNT_dec()'s it, then sets it to NULL.
If the current %^H contains a destructor, then that will be
executed while %^H still points to the hash being freed.
This can cause bad things to happen, like iterating over the hash being
freed.

Instead, setGvHV(PL_hintgv) to NULL first, *then* free the hash.

Author: iabyn

scope.c

@@ -1024,17 +1024,18 @@ Perl_leave_scope(pTHX_ I32 base)
 	    break;
 	case SAVEt_HINTS:
 	    if ((PL_hints & HINT_LOCALIZE_HH) && GvHV(PL_hintgv)) {
-		SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
+		HV *hv = GvHV(PL_hintgv);
 		GvHV(PL_hintgv) = NULL;
+		SvREFCNT_dec(MUTABLE_SV(hv));
 	    }
 	    cophh_free(CopHINTHASH_get(&PL_compiling));
 	    CopHINTHASH_set(&PL_compiling, (COPHH*)SSPOPPTR);
 	    *(I32*)&PL_hints = (I32)SSPOPINT;
 	    if (PL_hints & HINT_LOCALIZE_HH) {
 		SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
 		GvHV(PL_hintgv) = MUTABLE_HV(SSPOPPTR);
-		assert(GvHV(PL_hintgv));
-	    } else if (!GvHV(PL_hintgv)) {
+	    }
+	    if (!GvHV(PL_hintgv)) {
 		/* Need to add a new one manually, else gv_fetchpv() can
 		   add one in this code:
 		   

t/comp/hints.t

@@ -6,7 +6,7 @@ BEGIN {
     @INC = qw(. ../lib);
 }
 
-BEGIN { print "1..29\n"; }
+BEGIN { print "1..30\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -216,6 +216,27 @@ print "ok 26 - no crash when cloning a tied hint hash\n";
           "setting \${^WARNING_BITS} to its own value has no effect\n";
 }
 
+# [perl #112326]
+# this code could cause a crash, due to PL_hints continuing to point to th
+# hints hash currently being freed
+
+{
+    package Foo;
+    my @h = qw(a 1 b 2);
+    BEGIN {
+	$^H{FOO} = bless {};
+    }
+    sub DESTROY {
+	@h = %^H;
+	delete $INC{strict}; require strict; # boom!
+    }
+    my $h = join ':', %h;
+    # this isn't the main point of the test; the main point is that
+    # it doesn't crash!
+    print "not " if $h ne '';
+    print "ok 29 - #112326\n";
+}
+
 
 # Add new tests above this require, in case it fails.
 require './test.pl';
@@ -226,7 +247,7 @@ my $result = runperl(
     stderr => 1
 );
 print "not " if length $result;
-print "ok 29 - double-freeing hints hash\n";
+print "ok 30 - double-freeing hints hash\n";
 print "# got: $result\n" if length $result;
 
 __END__