From 57ef47cc7bcd1b57927d5010f363ccaa10f1d990 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Sat, 18 Sep 2010 23:01:54 +0100 Subject: [PATCH] stop do_clean_named_objs() leaving dangling refs Currently perl does 3 major scans of the SV arenas, so the action of perl_destroy() is a bit like this: for (all arena SVs) { if (its a ref to an object) undef the ref (and thus probably free the object) } for (all arena SVs) { if (it's a typeglob and at least one of its slots holds an object) { set SVf_BREAK on the gv SvREFCNT_dec(gv) } } return if $PERL_DESTRUCT_LEVEL < 1; PL_in_clean_all = 1 for (all arena SVs) { set SVf_BREAK on the sv SvREFCNT_dec(sv) } The second scan is problematic, in that by randomly zapping GVs, it can leave dangling pointers to freed GVs. This is while perl-level destructors may still be called, meaning perl users can see corrupted state. Note also that at this point PL_in_clean_all hasn't been set, so sv_free() may put out 'Attempt to free unreferenced scalar' warnings. This commit fixes this by only freeing the affected slots of the GV, rather than freeing the GV itself. Thus makes it more like the first pass, which undefs RVs, and ensures no dangling refs. --- intrpvar.h | 2 +- sv.c | 57 +++++++++++++++++++++++++++++++++++++++------------------ t/op/ref.t | 18 +++++++++++++++++- 3 files changed, 57 insertions(+), 20 deletions(-) diff --git a/intrpvar.h b/intrpvar.h index 0fd956d..4a7d867 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -465,7 +465,7 @@ PERLVAR(IDBcv, CV *) /* from perl.c */ PERLVARI(Igeneration, int, 100) /* from op.c */ PERLVARI(Iin_clean_objs,bool, FALSE) /* from sv.c */ -PERLVARI(Iin_clean_all, bool, FALSE) /* from sv.c */ +PERLVARI(Iin_clean_all, bool, FALSE) /* ptrs to freed SVs now legal */ PERLVAR(Inomemok, bool) /* let malloc context handle nomem */ PERLVARI(Isavebegin, bool, FALSE) /* save BEGINs for compiler */ diff --git a/sv.c b/sv.c index 1f7c760..2930d04 100644 --- a/sv.c +++ b/sv.c @@ -481,25 +481,47 @@ static void do_clean_named_objs(pTHX_ SV *const sv) { dVAR; + SV *obj; assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); - if (GvGP(sv)) { - if (( -#ifdef PERL_DONT_CREATE_GVSV - GvSV(sv) && -#endif - SvOBJECT(GvSV(sv))) || - (GvAV(sv) && SvOBJECT(GvAV(sv))) || - (GvHV(sv) && SvOBJECT(GvHV(sv))) || - /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */ - (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) || - (GvCV(sv) && SvOBJECT(GvCV(sv))) ) - { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); - } - } + if (!GvGP(sv)) + return; + + /* freeing GP entries may indirectly free the current GV; + * hold onto it while we mess with the GP slots */ + SvREFCNT_inc(sv); + + if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob SV object:\n "), sv_dump(obj))); + GvSV(sv) = NULL; + SvREFCNT_dec(obj); + } + if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob AV object:\n "), sv_dump(obj))); + GvAV(sv) = NULL; + SvREFCNT_dec(obj); + } + if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob HV object:\n "), sv_dump(obj))); + GvHV(sv) = NULL; + SvREFCNT_dec(obj); + } + if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob CV object:\n "), sv_dump(obj))); + GvCV(sv) = NULL; + SvREFCNT_dec(obj); + } + if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob IO object:\n "), sv_dump(obj))); + GvIOp(sv) = NULL; + SvREFCNT_dec(obj); + } + SvREFCNT_dec(sv); /* undo the inc above */ } #endif @@ -556,7 +578,6 @@ Perl_sv_clean_all(pTHX) I32 cleaned; PL_in_clean_all = TRUE; cleaned = visit(do_clean_all, 0,0); - PL_in_clean_all = FALSE; return cleaned; } diff --git a/t/op/ref.t b/t/op/ref.t index 019b47c..84cd40e 100644 --- a/t/op/ref.t +++ b/t/op/ref.t @@ -9,7 +9,7 @@ require 'test.pl'; use strict qw(refs subs); use re (); -plan(196); +plan(197); # Test glob operations. @@ -626,6 +626,22 @@ is( runperl(stderr => 1, prog => $hushed . 'for $a (3) {@b=sort {die} 4,5}'), "D # bug 57564 is( runperl(stderr => 1, prog => 'my $i;for $i (1) { for $i (2) { } }'), ""); +# The mechanism for freeing objects in globs used to leave dangling +# pointers to freed SVs. To test this, we construct this nested structure: +# GV => blessed(AV) => RV => GV => blessed(SV) +# all with a refcnt of 1, and hope that the second GV gets processed first +# by do_clean_named_objs. Then when the first GV is processed, it mustn't +# find anything nastly left by the previous GV processing. +# The eval is stop things in the main body of the code holding a reference +# to a GV, and the print at the end seems to bee necessary to ensure +# the correct freeing order of *x and *y (no, I don't know why - DAPM). + +is (runperl( + prog => 'eval q[bless \@y; bless \$x; $y[0] = \*x; $z = \*y; ]; ' + . 'delete $::{x}; delete $::{y}; print "ok\n";', + stderr => 1), + "ok\n", 'freeing freed glob in global destruction'); + # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves. $test = curr_test(); -- 1.8.3.1