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.

1 files changed, 17 insertions, 1 deletions

diff --git a/t/op/ref.t b/t/op/ref.t
index 019b47cdce..84cd40eead 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();