stop do_clean_named_objs() leaving dangling refs
authorDavid Mitchell <davem@iabyn.com>
Sat, 18 Sep 2010 22:01:54 +0000 (23:01 +0100)
committerDavid Mitchell <davem@iabyn.com>
Mon, 20 Sep 2010 07:16:12 +0000 (08:16 +0100)
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
sv.c
t/op/ref.t

index 0fd956d..4a7d867 100644 (file)
@@ -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 (file)
--- 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;
 }
 
index 019b47c..84cd40e 100644 (file)
@@ -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();