This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
stop %^H pointing to being-freed hash; #112326
authorDavid Mitchell <davem@iabyn.com>
Wed, 11 Apr 2012 12:37:09 +0000 (13:37 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 11 Apr 2012 13:20:53 +0000 (14:20 +0100)
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.

scope.c
t/comp/hints.t

diff --git a/scope.c b/scope.c
index cc207c0..1bf79e0 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -1024,8 +1024,9 @@ 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);
@@ -1033,8 +1034,8 @@ Perl_leave_scope(pTHX_ I32 base)
            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:
                   
index 8401ec9..d22b15e 100644 (file)
@@ -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__