Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Unloading Mouse class crashes Perl on 32-bit MSWin32 #14492

Closed
p5pRT opened this issue Feb 10, 2015 · 20 comments
Closed

Unloading Mouse class crashes Perl on 32-bit MSWin32 #14492

p5pRT opened this issue Feb 10, 2015 · 20 comments

Comments

@p5pRT
Copy link

p5pRT commented Feb 10, 2015

Migrated from rt.perl.org#123788 (status was 'resolved')

Searchable as RT123788$

@p5pRT
Copy link
Author

p5pRT commented Feb 10, 2015

From @xenu

Created by @xenu

While I wasn't able to reproduce this without using Mouse and Class​::Unload, I
strongly suspect that it's a bug in Perl core because Class​::Unload is
pure-perl module and it crashes even when Mouse is loaded with MOUSE_PUREPERL=1
env variable, so it is pure-perl too. AFAIK perl should never crash if there
are no XS modules loaded.

Problem occurs on 32-bit perl on MSWin32 (both ActiveState and Strawberry),
nothing wrong happens on 64-bit MSWin32.

I'm sorry that I don't have more minimal snippet of code, I hope that someone
here will be able to do better job in isolating this problem than me.

Following code crashes Perl​:

### file a.pl​:

use ABC;

use Mouse;
use Class​::Unload;

Class​::Unload->unload('ABC');
require ABC; # crashes here

### file ABC.pm

package ABC;

use Mouse;

q/ :-( /;

######## END OF CODE ########

Perl Info

Flags:
    category=core
    severity=critical

Site configuration information for perl 5.20.1:

Configured by gecko at Wed Oct 15 22:04:55 2014.

Summary of my perl5 (revision 5 version 20 subversion 1) configuration:
   
  Platform:
    osname=MSWin32, osvers=5.2, archname=MSWin32-x86-multi-thread-64int
    uname=''
    config_args='undef'
    hint=recommended, useposix=true, d_sigaction=undef
    useithreads=define, usemultiplicity=define
    use64bitint=define, use64bitall=undef, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='undef', ccflags =' -s -O2 -DWIN32 -DPERL_TEXTMODE_SCRIPTS -DUSE_SITECUSTOMIZE -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS -DUSE_PERLIO -fwrapv -fno-strict-aliasing -mms-bitfields',
    optimize='-s -O2',
    cppflags='-DWIN32'
    ccversion='', gccversion='4.6.3', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long long', ivsize=8, nvtype='double', nvsize=8, Off_t='long long', lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='undef', ldflags ='-s -static-libgcc -static-libstdc++ -L"C:\Perl\lib\CORE" -L"C:\MinGW\i686-w64-mingw32\lib"'
    libpth=C:\MinGW\i686-w64-mingw32\lib
    libs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
    perllibs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
    libc=, so=dll, useshrplib=true, libperl=libperl520.a
    gnulibc_version=''
  Dynamic Linking:
    dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' '
    cccdlflags=' ', lddlflags='-mdll -s -static-libgcc -static-libstdc++ -L"C:\Perl\lib\CORE" -L"C:\MinGW\i686-w64-mingw32\lib"'

Locally applied patches:
    ActivePerl Build 2000 [298557]


@INC for perl 5.20.1:
    C:/Perl/site/lib
    C:/Perl/lib
    .


Environment for perl 5.20.1:
    HOME (unset)
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=C:\Perl\site\bin;C:\Perl\bin;C:\Windows\system32;C:\Windows;C:\Windows\System32\Wbem;C:\Windows\System32\WindowsPowerShell\v1.0\;C:\Program Files (x86)\AMD\ATI.ACE\Core-Static
    PERL_BADLANG (unset)
    SHELL (unset)



@p5pRT
Copy link
Author

p5pRT commented Feb 11, 2015

From @cpansprout

On Tue Feb 10 15​:09​:35 2015, me@​xenu.tk wrote​:

This is a bug report for perl from me@​xenu.tk,
generated with the help of perlbug 1.40 running under perl 5.20.1.

-----------------------------------------------------------------
[Please describe your issue here]

While I wasn't able to reproduce this without using Mouse and
Class​::Unload, I
strongly suspect that it's a bug in Perl core because Class​::Unload is
pure-perl module and it crashes even when Mouse is loaded with
MOUSE_PUREPERL=1
env variable, so it is pure-perl too. AFAIK perl should never crash if
there
are no XS modules loaded.

Problem occurs on 32-bit perl on MSWin32 (both ActiveState and
Strawberry),
nothing wrong happens on 64-bit MSWin32.

I'm sorry that I don't have more minimal snippet of code, I hope that
someone
here will be able to do better job in isolating this problem than me.

Following code crashes Perl​:

### file a.pl​:

use ABC;

use Mouse;
use Class​::Unload;

Class​::Unload->unload('ABC');
require ABC; # crashes here

### file ABC.pm

package ABC;

use Mouse;

q/ :-( /;

######## END OF CODE ########

Reduced case​:

$ ./perl -Ilib -e '$x = \@​{"Foo​::ISA"}; delete $Foo​::{ISA}; @​$x = "Bar"'
Segmentation fault​: 11

--

Father Chrysostomos

@p5pRT
Copy link
Author

p5pRT commented Feb 11, 2015

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Feb 11, 2015

From @mauke

On Tue Feb 10 21​:59​:52 2015, sprout wrote​:

Reduced case​:

$ ./perl -Ilib -e '$x = \@​{"Foo​::ISA"}; delete $Foo​::{ISA}; @​$x = "Bar"'
Segmentation fault​: 11

Also crashes a debugging 5.20.0​:

perl​: mg.c​:1682​: Perl_magic_clearisa​: Assertion `((((_gvstash)->sv_flags & (0x00004000|0x00008000)) == 0x00008000) && (((svtype)((_gvstash)->sv_flags & 0xff)) == SVt_PVGV || ((svtype)((_gvstash)->sv_flags & 0xff)) == SVt_PVLV))' failed.

Program received signal SIGABRT, Aborted.
0xb7fdcbac in __kernel_vsyscall ()
(gdb) bt
#0 0xb7fdcbac in __kernel_vsyscall ()
#1 0xb7d85ca7 in raise () from /usr/lib/libc.so.6
#2 0xb7d872e9 in abort () from /usr/lib/libc.so.6
#3 0xb7d7edd7 in __assert_fail_base () from /usr/lib/libc.so.6
#4 0xb7d7ee5b in __assert_fail () from /usr/lib/libc.so.6
#5 0x081076e5 in Perl_magic_clearisa (sv=0x0, mg=<optimized out>) at mg.c​:1682
#6 0x08104a72 in Perl_mg_set (sv=0x8331308) at mg.c​:279
#7 0x08123a70 in Perl_pp_aassign () at pp_hot.c​:1083
#8 0x080fb509 in Perl_runops_debug () at dump.c​:2428
#9 0x08089d7e in S_run_body (oldscope=1) at perl.c​:2456
#10 perl_run (my_perl=0x832f008) at perl.c​:2372
#11 0x080615a7 in main (argc=3, argv=0xbffff6c4, env=0xbffff6d4) at perlmain.c​:114

@p5pRT
Copy link
Author

p5pRT commented Feb 11, 2015

From @mauke

On Wed Feb 11 03​:03​:02 2015, mauke- wrote​:

Also crashes a debugging 5.20.0​:

perl​: mg.c​:1682​: Perl_magic_clearisa​: Assertion `((((_gvstash)-

sv_flags & (0x00004000|0x00008000)) == 0x00008000) &&
(((svtype)((_gvstash)->sv_flags & 0xff)) == SVt_PVGV ||
((svtype)((_gvstash)->sv_flags & 0xff)) == SVt_PVLV))' failed.

Using a perl built from git​:

gdb --args ./perl -Ilib -e '$x = \@​{"Foo​::ISA"}; delete $Foo​::{ISA}; @​$x = "Bar"'
...
(gdb) r
...
perl​: mg.c​:1712​: Perl_magic_clearisa​: Assertion `((((_gvstash)->sv_flags & (0x00004000|0x00008000)) == 0x00008000) && (((svtype)((_gvstash)->sv_flags & 0xff)) == SVt_PVGV || ((svtype)((_gvstash)->sv_flags & 0xff)) == SVt_PVLV))' failed.

Program received signal SIGABRT, Aborted.
0xb7fdcbac in __kernel_vsyscall ()
(gdb) bt
#0 0xb7fdcbac in __kernel_vsyscall ()
#1 0xb7d68ca7 in raise () from /usr/lib/libc.so.6
#2 0xb7d6a2e9 in abort () from /usr/lib/libc.so.6
#3 0xb7d61dd7 in __assert_fail_base () from /usr/lib/libc.so.6
#4 0xb7d61e5b in __assert_fail () from /usr/lib/libc.so.6
#5 0x081177d9 in Perl_magic_clearisa (sv=0x0, mg=<optimized out>) at mg.c​:1712
#6 0x08114b12 in Perl_mg_set (sv=0x8358308) at mg.c​:277
#7 0x08133da4 in Perl_pp_aassign () at pp_hot.c​:1123
#8 0x0810b119 in Perl_runops_debug () at dump.c​:2231
#9 0x08091ab7 in S_run_body (oldscope=1) at perl.c​:2423
#10 perl_run (my_perl=0x8356008) at perl.c​:2346
#11 0x08062cb7 in main (argc=4, argv=0xbffff6f4, env=0xbffff708) at perlmain.c​:116
(gdb) frame 5
#5 0x081177d9 in Perl_magic_clearisa (sv=0x0, mg=<optimized out>) at mg.c​:1712
1712 stash = GvSTASH((GV *)*svp++);
(gdb) p svp
$1 = (SV **) 0x8368ec4
(gdb) p *svp
$2 = (SV *) 0x0
(gdb) p svp[-1]
$3 = (SV *) 0x8358d98
(gdb) p (GV *)svp[-1]
$4 = (GV *) 0x8358d98
(gdb) p *(GV *)svp[-1]
$5 = {sv_any = 0x8358f30, sv_refcnt = 1, sv_flags = 268452867, sv_u = {svu_pv = 0x836ac74 "Foo", svu_iv = 137800820, svu_uv = 137800820,
  svu_rv = 0x836ac74, svu_rx = 0x836ac74, svu_array = 0x836ac74, svu_hash = 0x836ac74, svu_gp = 0x836ac74, svu_fp = 0x836ac74}}
(gdb) p ((GV *)svp[-1])->sv_flags & (0x00004000|0x00008000)
$7 = 16384
(gdb) p 0x00004000
$11 = 16384

The failing assert is in GvSTASH​:
# define GvSTASH(gv) \
  (*({ GV * const _gvstash = (GV *) (gv); \
  assert(isGV_with_GP(_gvstash)); \
  assert(SvTYPE(_gvstash) == SVt_PVGV || SvTYPE(_gvstash) >= SVt_PVLV); \
  &(GvXPVGV(_gvstash)->xnv_u.xgv_stash); \
  }))

where isGV_with_GP is defined as​:
#define isGV_with_GP(pwadak) \
  (((SvFLAGS(pwadak) & (SVp_POK|SVpgv_GP)) == SVpgv_GP) \
  && (SvTYPE(pwadak) == SVt_PVGV || SvTYPE(pwadak) == SVt_PVLV))

So it looks like this GV has SVp_POK set, but not SVpgv_GP. I have no idea what any of this means. :-)

@p5pRT
Copy link
Author

p5pRT commented Feb 11, 2015

From @cpansprout

On Wed Feb 11 03​:38​:51 2015, mauke- wrote​:

So it looks like this GV has SVp_POK set, but not SVpgv_GP. I have no
idea what any of this means. :-)

I think it means the @​ISA array has a weak pointer to the GV that goes stale when the GV is freed. So by the time the magic triggers, the GV’s SV head may have been reused for a string. (I didn’t look at any of the code when writing this, though, so it may be wrong.)

--

Father Chrysostomos

@p5pRT
Copy link
Author

p5pRT commented Mar 4, 2015

From @tonycoz

On Wed Feb 11 09​:20​:30 2015, sprout wrote​:

On Wed Feb 11 03​:38​:51 2015, mauke- wrote​:

So it looks like this GV has SVp_POK set, but not SVpgv_GP. I have no
idea what any of this means. :-)

I think it means the @​ISA array has a weak pointer to the GV that goes
stale when the GV is freed. So by the time the magic triggers, the
GV’s SV head may have been reused for a string. (I didn’t look at any
of the code when writing this, though, so it may be wrong.)

Pretty much.

The attached patch seems to fix the problem.

This pushes the edge of my internals knowledge, so I'd appreciate reviews.

I still need to write tests for it.

Tony

@p5pRT
Copy link
Author

p5pRT commented Mar 4, 2015

From @mauke

Am 04.03.2015 um 07​:16 schrieb Tony Cook via RT​:

On Wed Feb 11 09​:20​:30 2015, sprout wrote​:

On Wed Feb 11 03​:38​:51 2015, mauke- wrote​:

So it looks like this GV has SVp_POK set, but not SVpgv_GP. I have no
idea what any of this means. :-)

I think it means the @​ISA array has a weak pointer to the GV that goes
stale when the GV is freed. So by the time the magic triggers, the
GV’s SV head may have been reused for a string. (I didn’t look at any
of the code when writing this, though, so it may be wrong.)

Pretty much.

The attached patch seems to fix the problem.

You forgot your attachment.

--
Lukas Mai <plokinom@​gmail.com>

@p5pRT
Copy link
Author

p5pRT commented Mar 4, 2015

From @tonycoz

On Tue Mar 03 22​:41​:30 2015, plokinom@​gmail.com wrote​:

Am 04.03.2015 um 07​:16 schrieb Tony Cook via RT​:

On Wed Feb 11 09​:20​:30 2015, sprout wrote​:

On Wed Feb 11 03​:38​:51 2015, mauke- wrote​:

So it looks like this GV has SVp_POK set, but not SVpgv_GP. I have no
idea what any of this means. :-)

I think it means the @​ISA array has a weak pointer to the GV that goes
stale when the GV is freed. So by the time the magic triggers, the
GV’s SV head may have been reused for a string. (I didn’t look at any
of the code when writing this, though, so it may be wrong.)

Pretty much.

The attached patch seems to fix the problem.

You forgot your attachment.

Attached this time, thanks.

Tony

@p5pRT
Copy link
Author

p5pRT commented Mar 4, 2015

From @tonycoz

0001-perl-123788-update-isa-magic-stash-records-when-ISA-.patch
From 587adb9e458c28b4778c7b5fcb6a6dbb90771c22 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 4 Mar 2015 17:06:02 +1100
Subject: [perl #123788] update isa magic stash records when *ISA is deleted

---
 hv.c |   43 ++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 42 insertions(+), 1 deletion(-)

diff --git a/hv.c b/hv.c
index 5195ca2..80b9874 100644
--- a/hv.c
+++ b/hv.c
@@ -1162,8 +1162,49 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 			 sv_2mortal((SV *)gv)
 			);
 		}
-		else if (klen == 3 && strnEQ(key, "ISA", 3))
+		else if (klen == 3 && strnEQ(key, "ISA", 3) && GvAV(gv)) {
+                    MAGIC *mg = mg_find((SV*)GvAV(gv), PERL_MAGIC_isa);
+
 		    mro_changes = 1;
+                    if (mg) {
+                        if (mg->mg_obj == (SV*)gv) {
+                            /* this is the only stash this ISA was used for */
+                            mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
+                        }
+                        else {
+                            /* mg_obj is an array of stashes */
+                            AV *av = (AV*)mg->mg_obj;
+                            SV **svp, **arrayp;
+                            SSize_t index;
+                            SSize_t items;
+
+                            assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
+
+                            /* remove the stash from the magic array */
+                            arrayp = svp = AvARRAY(av);
+                            items = AvFILLp(av) + 1;
+                            if (items == 1) {
+                                assert(*arrayp == (SV *)gv);
+                                mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
+                                SvREFCNT_dec_NN(av);
+                            }
+                            else {
+                                while (items--) {
+                                    if (*svp == (SV*)gv)
+                                        break;
+                                    ++svp;
+                                }
+                                index = svp - arrayp;
+                                assert(index >= 0 && index <= AvFILLp(av));
+                                if (index < AvFILLp(av)) {
+                                    arrayp[index] = arrayp[AvFILLp(av)];
+                                }
+                                arrayp[AvFILLp(av)] = NULL;
+                                --AvFILLp(av);
+                            }
+                        }
+                    }
+                }
 	}
 
 	sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
-- 
1.7.10.4

@p5pRT
Copy link
Author

p5pRT commented Mar 5, 2015

From @tonycoz

On Tue Mar 03 22​:16​:48 2015, tonyc wrote​:

I still need to write tests for it.

Tests.

Tony

@p5pRT
Copy link
Author

p5pRT commented Mar 5, 2015

From @tonycoz

0001-perl-123788-tests-for-making-in-in-use-ISA-not-an-IS.patch
From a841a30e791bbaf02130b61bda38b8f5e638bfef Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 5 Mar 2015 15:17:41 +1100
Subject: [perl 123788] tests for making in in-use @ISA not an @ISA anymore

---
 t/mro/basic.t |   38 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)

diff --git a/t/mro/basic.t b/t/mro/basic.t
index 3b7f9e8..fb12136 100644
--- a/t/mro/basic.t
+++ b/t/mro/basic.t
@@ -9,7 +9,7 @@ BEGIN {
 use strict;
 use warnings;
 
-plan(tests => 61);
+plan(tests => 64);
 
 require mro;
 
@@ -396,3 +396,39 @@ undef *UNIVERSAL::DESTROY;
     $#_119433::ISA++;
     pass "no crash when ISA contains nonexistent elements";
 }
+
+{ # 123788
+    local $::TODO = "crashes";
+    fresh_perl_is(<<'PROG', "ok", {}, "don't crash when deleting ISA");
+$x = \@{q(Foo::ISA)};
+delete $Foo::{ISA};
+@$x = "Bar";
+print "ok\n";
+PROG
+
+    # when there are multiple references to an ISA array, the mg_obj
+    # turns into an AV of globs, which is a different code path
+    # this test only crashes on -DDEBUGGING builds
+    fresh_perl_is(<<'PROG', "ok", {}, "a case with multiple refs to ISA");
+$x = \@{q(Foo::ISA)};
+*Bar::ISA = $x;
+delete $Bar::{ISA};
+delete $Foo::{ISA};
+++$y;
+@$x = "Bar";
+print "ok\n";
+PROG
+
+    # reverse order of delete to exercise removing from the other end
+    # of the array
+    # again, may only crash on -DDEBUGGING builds
+    fresh_perl_is(<<'PROG', "ok", {}, "a case with multiple refs to ISA");
+$x = \@{q(Foo::ISA)};
+*Bar::ISA = $x;
+delete $Foo::{ISA};
+delete $Bar::{ISA};
+++$y;
+@$x = "Bar";
+print "ok\n";
+PROG
+}
-- 
1.7.10.4

@p5pRT
Copy link
Author

p5pRT commented Mar 5, 2015

From @tonycoz

0002-perl-123788-update-isa-magic-stash-records-when-ISA-.patch
From 7fdb5352f2c4a777c4d305de66ca4030e548b1be Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 5 Mar 2015 15:14:21 +1100
Subject: [perl #123788] update isa magic stash records when *ISA is deleted

---
 hv.c          |   45 ++++++++++++++++++++++++++++++++++++++++++++-
 t/mro/basic.t |    1 -
 2 files changed, 44 insertions(+), 2 deletions(-)

diff --git a/hv.c b/hv.c
index c11566f..55d0381 100644
--- a/hv.c
+++ b/hv.c
@@ -1162,8 +1162,51 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 			 sv_2mortal((SV *)gv)
 			);
 		}
-		else if (klen == 3 && strnEQ(key, "ISA", 3))
+		else if (klen == 3 && strnEQ(key, "ISA", 3) && GvAV(gv)) {
+                    MAGIC *mg = mg_find((SV*)GvAV(gv), PERL_MAGIC_isa);
+
 		    mro_changes = 1;
+                    if (mg) {
+                        if (mg->mg_obj == (SV*)gv) {
+                            /* this is the only stash this ISA was used for */
+                            mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
+                        }
+                        else {
+                            /* mg_obj is an array of stashes */
+                            AV *av = (AV*)mg->mg_obj;
+                            SV **svp, **arrayp;
+                            SSize_t index;
+                            SSize_t items;
+
+                            assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
+
+                            /* remove the stash from the magic array */
+                            arrayp = svp = AvARRAY(av);
+                            items = AvFILLp(av) + 1;
+                            if (items == 1) {
+                                assert(*arrayp == (SV *)gv);
+                                mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
+                                /* avoid a double free on the last stash */
+                                AvFILLp(av) = -1;
+                                SvREFCNT_dec_NN(av);
+                            }
+                            else {
+                                while (items--) {
+                                    if (*svp == (SV*)gv)
+                                        break;
+                                    ++svp;
+                                }
+                                index = svp - arrayp;
+                                assert(index >= 0 && index <= AvFILLp(av));
+                                if (index < AvFILLp(av)) {
+                                    arrayp[index] = arrayp[AvFILLp(av)];
+                                }
+                                arrayp[AvFILLp(av)] = NULL;
+                                --AvFILLp(av);
+                            }
+                        }
+                    }
+                }
 	}
 
 	sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
diff --git a/t/mro/basic.t b/t/mro/basic.t
index fb12136..df85012 100644
--- a/t/mro/basic.t
+++ b/t/mro/basic.t
@@ -398,7 +398,6 @@ undef *UNIVERSAL::DESTROY;
 }
 
 { # 123788
-    local $::TODO = "crashes";
     fresh_perl_is(<<'PROG', "ok", {}, "don't crash when deleting ISA");
 $x = \@{q(Foo::ISA)};
 delete $Foo::{ISA};
-- 
1.7.10.4

@p5pRT
Copy link
Author

p5pRT commented Jun 4, 2015

From @tonycoz

On Tue Mar 03 22​:16​:48 2015, tonyc wrote​:

On Wed Feb 11 09​:20​:30 2015, sprout wrote​:

On Wed Feb 11 03​:38​:51 2015, mauke- wrote​:

So it looks like this GV has SVp_POK set, but not SVpgv_GP. I have no
idea what any of this means. :-)

I think it means the @​ISA array has a weak pointer to the GV that goes
stale when the GV is freed. So by the time the magic triggers, the
GV’s SV head may have been reused for a string. (I didn’t look at any
of the code when writing this, though, so it may be wrong.)

Pretty much.

The attached patch seems to fix the problem.

This pushes the edge of my internals knowledge, so I'd appreciate reviews.

It turned out to have at least one issue​:

It left the magic on the @​ISA elements, this would cause an assertion in magic_clearisa() if an @​ISA element was modified.

Just setting mg_obj to NULL wasn't a solution, since both magic_clearisa() and sv.c​:S_glob_assign_glob() both assume mg_obj is non-NULL.

Tony

@p5pRT
Copy link
Author

p5pRT commented Jun 4, 2015

From @tonycoz

0001-perl-123788-tests-for-making-in-in-use-ISA-not-an-IS.patch
From b8e7e6abdd02614a4e3cdcef324b67cb7b5ecc27 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 5 Mar 2015 15:17:41 +1100
Subject: [perl #123788] tests for making in in-use @ISA not an @ISA anymore

---
 t/mro/basic.t |   40 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 39 insertions(+), 1 deletion(-)

diff --git a/t/mro/basic.t b/t/mro/basic.t
index 3b7f9e8..a037781 100644
--- a/t/mro/basic.t
+++ b/t/mro/basic.t
@@ -9,7 +9,7 @@ BEGIN {
 use strict;
 use warnings;
 
-plan(tests => 61);
+plan(tests => 64);
 
 require mro;
 
@@ -396,3 +396,41 @@ undef *UNIVERSAL::DESTROY;
     $#_119433::ISA++;
     pass "no crash when ISA contains nonexistent elements";
 }
+
+{ # 123788
+    local $::TODO = "crashes";
+    fresh_perl_is(<<'PROG', "ok", {}, "don't crash when deleting ISA");
+$x = \@{q(Foo::ISA)};
+delete $Foo::{ISA};
+@$x = "Bar";
+print "ok\n";
+PROG
+
+    # when there are multiple references to an ISA array, the mg_obj
+    # turns into an AV of globs, which is a different code path
+    # this test only crashes on -DDEBUGGING builds
+    fresh_perl_is(<<'PROG', "ok", {}, "a case with multiple refs to ISA");
+@Foo::ISA = qw(Abc Def);
+$x = \@{q(Foo::ISA)};
+*Bar::ISA = $x;
+delete $Bar::{ISA};
+delete $Foo::{ISA};
+++$y;
+$x->[1] = "Ghi";
+@$x = "Bar";
+print "ok\n";
+PROG
+
+    # reverse order of delete to exercise removing from the other end
+    # of the array
+    # again, may only crash on -DDEBUGGING builds
+    fresh_perl_is(<<'PROG', "ok", {}, "a case with multiple refs to ISA");
+$x = \@{q(Foo::ISA)};
+*Bar::ISA = $x;
+delete $Foo::{ISA};
+delete $Bar::{ISA};
+++$y;
+@$x = "Bar";
+print "ok\n";
+PROG
+}
-- 
1.7.10.4

@p5pRT
Copy link
Author

p5pRT commented Jun 4, 2015

From @tonycoz

0002-perl-123788-update-isa-magic-stash-records-when-ISA-.patch
From 7ec38ae36c0a86ef8f2cdb31ecad0270cf1fdd01 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 5 Mar 2015 15:14:21 +1100
Subject: [perl #123788] update isa magic stash records when *ISA is deleted

---
 hv.c          |   62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 t/mro/basic.t |    1 -
 2 files changed, 61 insertions(+), 2 deletions(-)

diff --git a/hv.c b/hv.c
index e5bf629..c503925 100644
--- a/hv.c
+++ b/hv.c
@@ -1162,8 +1162,68 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 			 sv_2mortal((SV *)gv)
 			);
 		}
-		else if (klen == 3 && strnEQ(key, "ISA", 3))
+		else if (klen == 3 && strnEQ(key, "ISA", 3) && GvAV(gv)) {
+                    AV *isa = GvAV(gv);
+                    MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa);
+
 		    mro_changes = 1;
+                    if (mg) {
+                        if (mg->mg_obj == (SV*)gv) {
+                            /* This is the only stash this ISA was used for.
+                             * The isaelem magic asserts if there's no
+                             * isa magic on the array, so explicitly
+                             * remove the magic on both the array and its
+                             * elements.  @ISA shouldn't /too/ large.
+                             */
+                            SV **svp, **end;
+                        strip_magic:
+                            svp = AvARRAY(isa);
+                            end = svp + AvFILLp(isa)+1;
+                            while (svp < end) {
+                                if (*svp)
+                                    mg_free_type(*svp, PERL_MAGIC_isaelem);
+                                ++svp;
+                            }
+                            mg_free_type((SV*)GvAV(gv), PERL_MAGIC_isa);
+                        }
+                        else {
+                            /* mg_obj is an array of stashes */
+                            AV *av = (AV*)mg->mg_obj;
+                            SV **svp, **arrayp;
+                            SSize_t index;
+                            SSize_t items;
+
+                            assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
+
+                            /* remove the stash from the magic array */
+                            arrayp = svp = AvARRAY(av);
+                            items = AvFILLp(av) + 1;
+                            if (items == 1) {
+                                assert(*arrayp == (SV *)gv);
+                                mg->mg_obj = NULL;
+                                /* avoid a double free on the last stash */
+                                AvFILLp(av) = -1;
+                                /* no, the magic isn't MGf_REFCOUNTED */
+                                SvREFCNT_dec_NN(av);
+                                goto strip_magic;
+                            }
+                            else {
+                                while (items--) {
+                                    if (*svp == (SV*)gv)
+                                        break;
+                                    ++svp;
+                                }
+                                index = svp - arrayp;
+                                assert(index >= 0 && index <= AvFILLp(av));
+                                if (index < AvFILLp(av)) {
+                                    arrayp[index] = arrayp[AvFILLp(av)];
+                                }
+                                arrayp[AvFILLp(av)] = NULL;
+                                --AvFILLp(av);
+                            }
+                        }
+                    }
+                }
 	}
 
 	sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
diff --git a/t/mro/basic.t b/t/mro/basic.t
index a037781..d5663f4 100644
--- a/t/mro/basic.t
+++ b/t/mro/basic.t
@@ -398,7 +398,6 @@ undef *UNIVERSAL::DESTROY;
 }
 
 { # 123788
-    local $::TODO = "crashes";
     fresh_perl_is(<<'PROG', "ok", {}, "don't crash when deleting ISA");
 $x = \@{q(Foo::ISA)};
 delete $Foo::{ISA};
-- 
1.7.10.4

@p5pRT
Copy link
Author

p5pRT commented Jan 11, 2016

From @tonycoz

On Wed Jun 03 23​:42​:11 2015, tonyc wrote​:

On Tue Mar 03 22​:16​:48 2015, tonyc wrote​:

On Wed Feb 11 09​:20​:30 2015, sprout wrote​:

On Wed Feb 11 03​:38​:51 2015, mauke- wrote​:

So it looks like this GV has SVp_POK set, but not SVpgv_GP. I
have no
idea what any of this means. :-)

I think it means the @​ISA array has a weak pointer to the GV that
goes
stale when the GV is freed. So by the time the magic triggers, the
GV’s SV head may have been reused for a string. (I didn’t look at
any
of the code when writing this, though, so it may be wrong.)

Pretty much.

The attached patch seems to fix the problem.

This pushes the edge of my internals knowledge, so I'd appreciate
reviews.

It turned out to have at least one issue​:

It left the magic on the @​ISA elements, this would cause an assertion
in magic_clearisa() if an @​ISA element was modified.

Just setting mg_obj to NULL wasn't a solution, since both
magic_clearisa() and sv.c​:S_glob_assign_glob() both assume mg_obj is
non-NULL.

Patches applied as 5c8e69e and 6146d9e with some comment fixes.

Tony

@p5pRT
Copy link
Author

p5pRT commented Jan 11, 2016

@tonycoz - Status changed from 'open' to 'pending release'

@p5pRT
Copy link
Author

p5pRT commented May 13, 2016

From @khwilliamson

Thank you for submitting this report. You have helped make Perl better.
 
With the release of Perl 5.24.0 on May 9, 2016, this and 149 other issues have been resolved.

Perl 5.24.0 may be downloaded via https://metacpan.org/release/RJBS/perl-5.24.0

@p5pRT
Copy link
Author

p5pRT commented May 13, 2016

@khwilliamson - Status changed from 'pending release' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant