handle freed backref array in global cleanup

[perl #88330]

If a thinggy is heavily leaked, so that it takes multiple passes through
Perl_sv_clean_all to get its refcount to zero, then if it has weak refs to
it, its backref array may get freed before it.  We already set the
refcount of the array to 2 to preserve it across one pass of
Perl_sv_clean_all, but I can't think of a way of protecting it more
generally (short of using a private array structure rather than an AV).

In the past, this caused a scary assertion failure.

Now instead, just skip if we're in global cleanup and the array is freed.
This isn't ideal, but its reasonably robust, as we don't reuse freed SVs
once in global cleanup (so the freed AV hangs around to be identified as
such).

diff --git a/sv.c b/sv.c
index 447c2bc..69cdfa9 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5719,6 +5719,17 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
     if (!av)
        return;
 
+    /* after multiple passes through Perl_sv_clean_all() for a thinngy
+     * that has badly leaked, the backref array may have gotten freed,
+     * since we only protect it against 1 round of cleanup */
+    if (SvIS_FREED(av)) {
+       if (PL_in_clean_all) /* All is fair */
+           return;
+       Perl_croak(aTHX_
+                  "panic: magic_killbackrefs (freed backref AV/SV)");
+    }
+
+
     is_array = (SvTYPE(av) == SVt_PVAV);
     if (is_array) {
        assert(!SvIS_FREED(av));

diff --git a/t/op/ref.t b/t/op/ref.t
index ab1fe5c..ea5bd2e 100644 (file)
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -8,7 +8,7 @@ BEGIN {
 
 use strict qw(refs subs);
 
-plan(213);
+plan(217);
 
 # Test glob operations.
 
@@ -692,6 +692,60 @@ is (runperl(
  eval { my $foo; !%$foo ? 1 : 0;    }; ok !$@, '!%$undef ? 1 : 0';
 }
 
+# RT #88330
+# Make sure that a leaked thinggy with multiple weak references to
+# it doesn't trigger a panic with multiple rounds of global cleanup
+# (Perl_sv_clean_all).
+
+SKIP: {
+    skip_if_miniperl('no Scalar::Util under miniperl', 4);
+
+    local $ENV{PERL_DESTRUCT_LEVEL} = 2;
+
+    # we do all permutations of array/hash, 1ref/2ref, to account
+    # for the different way backref magic is stored
+
+    fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 1 weak ref');
+use Scalar::Util qw(weaken);
+my $r = [];
+Internals::SvREFCNT(@$r, 9);
+my $r1 = $r;
+weaken($r1);
+print "ok";
+EOF
+
+    fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'array with 2 weak refs');
+use Scalar::Util qw(weaken);
+my $r = [];
+Internals::SvREFCNT(@$r, 9);
+my $r1 = $r;
+weaken($r1);
+my $r2 = $r;
+weaken($r2);
+print "ok";
+EOF
+
+    fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 1 weak ref');
+use Scalar::Util qw(weaken);
+my $r = {};
+Internals::SvREFCNT(%$r, 9);
+my $r1 = $r;
+weaken($r1);
+print "ok";
+EOF
+
+    fresh_perl_is(<<'EOF', 'ok', { stderr => 1 }, 'hash with 2 weak refs');
+use Scalar::Util qw(weaken);
+my $r = {};
+Internals::SvREFCNT(%$r, 9);
+my $r1 = $r;
+weaken($r1);
+my $r2 = $r;
+weaken($r2);
+print "ok";
+EOF
+
+}
 
 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
 $test = curr_test();