Skip Menu |
Report information
Id: 123788
Status: resolved
Priority: 0/
Queue: perl5

Owner: Nobody
Requestors: me [at] xenu.tk
Cc:
AdminCc:

Operating System: mswin32
PatchStatus: (no value)
Severity: critical
Type: core
Perl Version: 5.20.1
Fixed In: (no value)



From: Tomasz Konojacki <me [...] xenu.tk>
Date: Wed, 11 Feb 2015 00:09:18 +0100
To: perlbug [...] perl.org
Subject: Unloading Mouse class crashes Perl on 32-bit MSWin32
Download (untitled) / with headers
text/plain 3.5k
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 ######## [Please do not change anything below this line] ----------------------------------------------------------------- --- 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)
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.2k
On Tue Feb 10 15:09:35 2015, me@xenu.tk wrote: Show quoted text
> > 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.1k
On Tue Feb 10 21:59:52 2015, sprout wrote: Show quoted text
> > 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 2.6k
On Wed Feb 11 03:03:02 2015, mauke- wrote: Show quoted text
> > 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. :-)
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 451b
On Wed Feb 11 03:38:51 2015, mauke- wrote: Show quoted text
> 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 663b
On Wed Feb 11 09:20:30 2015, sprout wrote: Show quoted text
> 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
Date: Wed, 04 Mar 2015 07:40:49 +0100
From: Lukas Mai <plokinom [...] gmail.com>
Subject: Re: [perl #123788] Unloading Mouse class crashes Perl on 32-bit MSWin32
To: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 672b
Am 04.03.2015 um 07:16 schrieb Tony Cook via RT: Show quoted text
> 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>
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 756b
On Tue Mar 03 22:41:30 2015, plokinom@gmail.com wrote: Show quoted text
> 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
Subject: 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
RT-Send-CC: perl5-porters [...] perl.org
On Tue Mar 03 22:16:48 2015, tonyc wrote: Show quoted text
> I still need to write tests for it.
Tests. Tony
Subject: 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
Subject: 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1002b
On Tue Mar 03 22:16:48 2015, tonyc wrote: Show quoted text
> 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
Subject: 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
Subject: 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
RT-Send-CC: perl5-porters [...] perl.org
Download (untitled) / with headers
text/plain 1.2k
On Wed Jun 03 23:42:11 2015, tonyc wrote: Show quoted text
> 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 5c8e69ec416d40935c4c2d1f240cdd70f076929e and 6146d9e1c87d449f5c7e9c953a2e9051e32b1696 with some comment fixes. Tony
Download (untitled) / with headers
text/plain 252b
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


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org