In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/2653c1e3b10f71430de1ab8ab0417ca5b048ab19?hp=629e8f5e3a9b318b663e6fbb0025a6b0c03deffe>
- Log ----------------------------------------------------------------- commit 2653c1e3b10f71430de1ab8ab0417ca5b048ab19 Author: David Mitchell <[email protected]> Date: Wed Apr 11 13:37:09 2012 +0100 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. ----------------------------------------------------------------------- Summary of changes: scope.c | 7 ++++--- t/comp/hints.t | 25 +++++++++++++++++++++++-- 2 files changed, 27 insertions(+), 5 deletions(-) diff --git a/scope.c b/scope.c index cc207c0..1bf79e0 100644 --- 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: diff --git a/t/comp/hints.t b/t/comp/hints.t index 8401ec9..d22b15e 100644 --- a/t/comp/hints.t +++ b/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__ -- Perl5 Master Repository
