This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Prevent destructors called from gp_free from seeing freed SVs
authorFather Chrysostomos <sprout@cpan.org>
Thu, 10 Feb 2011 22:04:54 +0000 (14:04 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 10 Feb 2011 22:04:54 +0000 (14:04 -0800)
perl5.13.9 -e 'local *foo; $foo = bless[]; (); DESTROY { use Devel::Peek; Dump $foo; }'

This prints:
SV = UNKNOWN(0xff) (0x8044dc) at 0x8044e0
  REFCNT = 0
  FLAGS = ()

If I do anything with $foo inside the destructor, such as
‘local $foo’, it crashes, of course.

gp_free (called when *foo is being unlocalised on scope exit) does
SvREFCNT_dec(gp->gp_xv) on each of its slots.

SvREFCNT_dec(gp->gp_sv) lowers the refcount of $foo to zero, which
causes the object it references to be destroyed, too. The objects
destructor sees the same $foo still there in the typeglob.

This commit changes gp_free to use a loop, the way S_hfreeentries
(in hv.c) does, checking that everything has been freed before exit-
ing the loop.

(The one-liner above is a reduced version of

perl -MWWW::Scripter -e '$w = new WWW::Scripter; $w->use_plugin(JavaScript); $w->get(q|data:text/html,<a href onclick="throw new Error(&quot;XMLHttpRequest&quot;)">|); $w->document->links->[0]->click'

which involved *@ and a destructor localising $@.)

gv.c
pod/perldiag.pod
t/op/gv.t

diff --git a/gv.c b/gv.c
index 9a259e0..5ddfb56 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1694,6 +1694,7 @@ Perl_gp_free(pTHX_ GV *gv)
 {
     dVAR;
     GP* gp;
+    int attempts = 100;
 
     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
        return;
@@ -1710,22 +1711,58 @@ Perl_gp_free(pTHX_ GV *gv)
         return;
     }
 
-    if (gp->gp_file_hek)
-       unshare_hek(gp->gp_file_hek);
-    SvREFCNT_dec(gp->gp_sv);
-    SvREFCNT_dec(gp->gp_av);
-    /* FIXME - another reference loop GV -> symtab -> GV ?
-       Somehow gp->gp_hv can end up pointing at freed garbage.  */
-    if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
-       const char *hvname = HvNAME_get(gp->gp_hv);
+    while (1) {
+      /* Copy and null out all the glob slots, so destructors do not see
+         freed SVs. */
+      HEK * const file_hek = gp->gp_file_hek;
+      SV  * const sv       = gp->gp_sv;
+      AV  * const av       = gp->gp_av;
+      HV  * const hv       = gp->gp_hv;
+      IO  * const io       = gp->gp_io;
+      CV  * const cv       = gp->gp_cv;
+      CV  * const form     = gp->gp_form;
+
+      gp->gp_file_hek = NULL;
+      gp->gp_sv       = NULL;
+      gp->gp_av       = NULL;
+      gp->gp_hv       = NULL;
+      gp->gp_io       = NULL;
+      gp->gp_cv       = NULL;
+      gp->gp_form     = NULL;
+
+      if (file_hek)
+       unshare_hek(file_hek);
+
+      SvREFCNT_dec(sv);
+      SvREFCNT_dec(av);
+      /* FIXME - another reference loop GV -> symtab -> GV ?
+         Somehow gp->gp_hv can end up pointing at freed garbage.  */
+      if (hv && SvTYPE(hv) == SVt_PVHV) {
+       const char *hvname = HvNAME_get(hv);
        if (PL_stashcache && hvname)
-           (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
+           (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(hv),
                      G_DISCARD);
-       SvREFCNT_dec(gp->gp_hv);
+       SvREFCNT_dec(hv);
+      }
+      SvREFCNT_dec(io);
+      SvREFCNT_dec(cv);
+      SvREFCNT_dec(form);
+
+      if (!gp->gp_file_hek
+       && !gp->gp_sv
+       && !gp->gp_av
+       && !gp->gp_hv
+       && !gp->gp_io
+       && !gp->gp_cv
+       && !gp->gp_form) break;
+
+      if (--attempts == 0) {
+       Perl_die(aTHX_
+         "panic: gp_free failed to free glob pointer - "
+         "something is repeatedly re-creating entries"
+       );
+      }
     }
-    SvREFCNT_dec(gp->gp_io);
-    SvREFCNT_dec(gp->gp_cv);
-    SvREFCNT_dec(gp->gp_form);
 
     Safefree(gp);
     GvGP_set(gv, NULL);
index 3d35b1c..b3d02c4 100644 (file)
@@ -3439,6 +3439,13 @@ failure was caught.
 (P) We popped the context stack to a context with the specified label,
 and then discovered it wasn't a context we know how to do a goto in.
 
+=item panic: gp_free failed to free glob pointer
+
+(P) The internal routine used to clear a typeglob's entries tried
+repeatedly, but each time something re-created entries in the glob. Most
+likely the glob contains an object with a reference back to the glob and a
+destructor that adds a new object to the glob.
+
 =item panic: hfreeentries failed to free hash
 
 (P) The internal routine used to clear a hashes entries tried repeatedly,
index c1d5f83..7b785e9 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use warnings;
 
-plan( tests => 231 );
+plan( tests => 232 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -874,6 +874,26 @@ ok eval {
   }
 }
 
+# This code causes gp_free to call a destructor when a glob is being
+# restored on scope exit. The destructor used to see SVs with a refcount of
+# zero inside the glob, which could result in crashes (though not in this
+# test case, which just panics).
+{
+ no warnings 'once';
+ my $survived;
+ *Trit::DESTROY = sub {
+   $thwext = 42;  # panic
+   $survived = 1;
+ };
+ {
+  local *thwext;
+  $thwext = bless[],'Trit';
+  ();
+ }
+ ok $survived,
+  'no error when gp_free calls a destructor that assigns to the gv';
+}
+
 __END__
 Perl
 Rules