[perl #121242] Fix crash in gp_free when gv is freed

Commit 4571f4a caused the gp to have a refcount of 1, not 0, in
gp_free when the contents of the glob are freed.  This makes
gv_try_downgrade see the gv as a candidate for downgrading in
this example:

sub Fred::AUTOLOAD { $Fred::AUTOLOAD }
undef *{"Fred::AUTOLOAD"};

When the glob is undefined, the sub inside it is freed, and the
gvop ($Fred::AUTOLOAD), when freed, tries to downgrade the glob
(*Fred::AUTOLOAD).  Since it is empty, it deletes it completely from
the containing stash, so the GV is freed out from under gp_free, which
is still using it, causing an assertion failure.

We can trigger a similar condition more explicitly:

$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = bless []; undef *{"foo"}'

This bug is nothing new.  On a non-debugging 5.18.2, I get this:

$ perl5.18.2 -e 'DESTROY{delete $::{foo}} ${"foo"} = bless []; undef *{"foo"}'
Attempt to free unreferenced glob pointers at -e line 1.
Segmentation fault: 11

That crashes in pp_undef after the call to gp_free, becaues pp_undef
continues to manipulate the GV.

The problem occurs not only with pp_undef, but also with other func-
tions calling gp_free:

sv_setsv_flags:
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = bless []; *{"foo"}="bar"'

glob_assign_glob:
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = bless []; *{"foo"}=*bar'

sv_unglob, reached through various paths:
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = do {local *bar}; $${"foo"} = bless []; ${"foo"} = 3'
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = do {local *bar}; $${"foo"} = bless []; utf8::encode(${"foo"})'
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = do {local *bar}; $${"foo"} = bless []; open bar, "t/TEST"; ${"foo"} .= <bar>'
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = do {local *bar}; $${"foo"} = bless []; ${"foo"}++'
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = do {local *bar}; $${"foo"} = bless []; undef ${"foo"}'
$ ./miniperl -e 'DESTROY{delete $::{foo}} ${"foo"} = 3; ${"foo"} =~ s/3/${"foo"} = do {local *bar}; $${"foo"} = bless []; 4/e'

And there are probably more ways to trigger this through sv_unglob.
(I stopped looking when I thought of the fix.)

This patch fixes the problem by protecting the GV using the mortals
stack in functions that call gp_free.  I did not change gp_free
itself, since it is an API function that as yet does not touch the
mortals stack, and I am not sure that should change.  All of its
callers that this patch touches already do sv_2mortal in some cir-
cumstances.

diff --git a/pp.c b/pp.c
index a5ce2a8..4d7ff09 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1024,6 +1024,7 @@ PP(pp_undef)
                 else stash = NULL;
             }
 
+           SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
            gp_free(MUTABLE_GV(sv));
            Newxz(gp, 1, GP);
            GvGP_set(sv, gp_ref(gp));

diff --git a/sv.c b/sv.c
index 48f5dc7..4c6f9ad 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3773,6 +3773,8 @@ S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
                     );
             }
         }
+
+        SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
     }
 
     gp_free(MUTABLE_GV(dstr));
@@ -4312,8 +4314,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
                    reset_isa = TRUE;
                }
 
-               if (GvGP(dstr))
+               if (GvGP(dstr)) {
+                   SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
                    gp_free(MUTABLE_GV(dstr));
+               }
                GvGP_set(dstr, gp_ref(GvGP(gv)));
 
                if (reset_isa) {
@@ -9940,6 +9944,7 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags)
     if (!(flags & SV_COW_DROP_PV))
        gv_efullname3(temp, MUTABLE_GV(sv), "*");
 
+    SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
     if (GvGP(sv)) {
         if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
           && HvNAME_get(stash))

diff --git a/t/op/gv.t b/t/op/gv.t
index e1c9fad..6b90864 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use warnings;
 
-plan( tests => 259 );
+plan( tests => 271 );
 
 # type coercion on assignment
 $foo = 'foo';
@@ -962,6 +962,63 @@ sub Undefiner::DESTROY {
       'undeffing a gv in DESTROY triggered by undeffing the same gv'
 }
 
+# [perl #121242]
+# More gp_free madness.  gp_free could call a destructor that frees the gv
+# whose gp is being freed.
+sub Fred::AUTOLOAD { $Fred::AUTOLOAD }
+undef *{"Fred::AUTOLOAD"};
+pass 'no crash from gp_free triggering gv_try_downgrade';
+sub _121242::DESTROY { delete $_121242::{$_[0][0]} };
+${"_121242::foo"} = bless ["foo"], _121242::;
+undef *{"_121242::foo"};
+pass 'no crash from pp_undef/gp_free freeing the gv';
+${"_121242::bar"} = bless ["bar"], _121242::;
+*{"_121242::bar"} = "bar";
+pass 'no crash from sv_setsv/gp_free freeing the gv';
+${"_121242::baz"} = bless ["baz"], _121242::;
+*{"_121242::baz"} = *foo;
+pass 'no crash from glob_assign_glob/gp_free freeing the gv';
+{
+    my $foo;
+    undef *_121242::DESTROY;
+    *_121242::DESTROY = sub { undef $foo };
+    my $set_up_foo = sub {
+        # Make $$foo into a fake glob whose array slot holds a blessed
+        # array that undefines $foo, freeing the fake glob.
+        $foo = undef;
+        $$foo = do {local *bar};
+        *$$foo = bless [], _121242::;
+    };
+    &$set_up_foo;
+    $$foo = 3;
+    pass 'no crash from sv_setsv/sv_unglob/gp_free freeing the gv';
+    &$set_up_foo;
+    utf8::encode $$foo;
+    pass 'no crash from sv_utf8_encode/sv_unglob/gp_free freeing the gv';
+    &$set_up_foo;
+    open BAR, "TEST";
+    $$foo .= <BAR>;
+    pass 'no crash from do_readline/sv_unglob/gp_free freeing the gv';
+    close BAR;
+    &$set_up_foo;
+    $$foo .= 3;
+    pass 'no crash from pp_concat/sv_unglob/gp_free freeing the gv';
+    &$set_up_foo;
+    no warnings;
+    $$foo++;
+    pass 'no crash from sv_inc/sv_unglob/gp_free freeing the gv';
+    &$set_up_foo;
+    $$foo--;
+    pass 'no crash from sv_dec/sv_unglob/gp_free freeing the gv';
+    &$set_up_foo;
+    undef $$foo;
+    pass 'no crash from pp_undef/sv_unglob/gp_free freeing the gv';
+    $foo = undef;
+    $$foo = 3;
+    $$foo =~ s/3/$$foo = do {local *bar}; *$$foo = bless [],_121242::; 4/e;
+    pass 'no crash from pp_substcont/sv_unglob/gp_free freeing the gv';
+}
+
 # *{undef}
 eval { *{my $undef} = 3 };
 like $@, qr/^Can't use an undefined value as a symbol reference at /,