In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/7fcb412668d2fa3df241491ee985370bed3a3018?hp=07600c147206f87bb71e342e64acb1cb7789fe1c>
- Log ----------------------------------------------------------------- commit 7fcb412668d2fa3df241491ee985370bed3a3018 Author: Father Chrysostomos <[email protected]> Date: Mon Sep 15 14:28:22 2014 -0700 Fix assertion failure with undef &my_sub/&anon $ ./perl -Ilib -le 'use experimental lexical_subs; my sub x; undef &x;' Assertion failed: (isGV_with_GP(_gvname_hek)), function Perl_leave_scope, file scope.c, line 1035. Abort trap: 6 pp_undef undefines a subroutine via cv_undef, which wipes out the name, and then restores the name again afterwards. For subs with GVs, it would call CvGV_set afterwards with the same gv. But cv_undef could have freed the GV, if the CV held the only refer- ence count. I caused this for lexical subs a few commits ago in ae77754ae (because CvGV will always return non-null; in fact the CvNAME_HEK code in pp_undef is no longer exercised, but I will address that soon). For anonymous subs it is older: $ perl5.14.4 -e '$_ = sub{}; delete $::{__ANON__}; undef &$_; use Devel::Peek; Dump $_' SV = IV(0x7fed9982f9c0) at 0x7fed9982f9d0 REFCNT = 1 FLAGS = (ROK) RV = 0x7fed9982f9e8 SV = PVCV(0x7fed9982e290) at 0x7fed9982f9e8 REFCNT = 2 FLAGS = (PADMY,WEAKOUTSIDE,CVGV_RC) COMP_STASH = 0x7fed99806b68 "main" ROOT = 0x0 GVGV::GV = 0x7fed9982fa48Assertion failed: (isGV_with_GP(_gvname_hek)), function Perl_do_gvgv_dump, file dump.c, line 1477. Abort trap: 6 (Probably commit 803f2748.) Presumably that could be made to crash in other ways than introspec- tion, but it is much harder. This commit fixes the problem by fiddling with reference counts. But this is only a temporary fix. I think I plan to stop cv_undef from removing the name (gv/hek) when called from pp_undef. M pp.c M t/op/anonsub.t M t/op/lexsub.t commit a6de8fc77bb1ac413d5a5868104c8b2c555ce6d8 Author: Father Chrysostomos <[email protected]> Date: Mon Sep 15 09:35:50 2014 -0700 Peek.t needs to know about the prev. change M ext/Devel-Peek/t/Peek.t commit be108a016385ee2de75d92fc5b823e024301789e Author: Father Chrysostomos <[email protected]> Date: Mon Sep 15 09:34:41 2014 -0700 dump.c: Donât dump GvFLAGS as part of GP The flags are not actually stored in the GP. Dumping them as part of it implies that they are shared between globs that share the same GP, which is not the case. M dump.c ----------------------------------------------------------------------- Summary of changes: dump.c | 2 +- ext/Devel-Peek/t/Peek.t | 3 ++- pp.c | 1 + t/op/anonsub.t | 13 +++++++++++++ t/op/lexsub.t | 10 +++++++++- 5 files changed, 26 insertions(+), 3 deletions(-) diff --git a/dump.c b/dump.c index 015bc49..bc455f4 100644 --- a/dump.c +++ b/dump.c @@ -2030,6 +2030,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv)); do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv)); Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv))); if (!GvGP(sv)) break; @@ -2043,7 +2044,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv)); Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv)); Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv)); do_gv_dump (level, file, " EGV", GvEGV(sv)); break; case SVt_PVIO: diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 492b8ed..643ff45 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -493,6 +493,7 @@ do_test('typeglob', NAME = "a" NAMELEN = 1 GvSTASH = $ADDR\\t"main" + FLAGS = $ADDR # $] >=5.021004 GP = $ADDR SV = $ADDR REFCNT = 1 @@ -505,7 +506,7 @@ do_test('typeglob', GPFLAGS = 0x0 # $] < 5.009 LINE = \\d+ FILE = ".*\\b(?i:peek\\.t)" - FLAGS = $ADDR + FLAGS = $ADDR # $] < 5.021004 EGV = $ADDR\\t"a"'); if (ord('A') == 193) { diff --git a/pp.c b/pp.c index ea05bb4..0750ea0 100644 --- a/pp.c +++ b/pp.c @@ -1006,6 +1006,7 @@ PP(pp_undef) GV* const gv = CvGV((const CV *)sv); HEK * const hek = CvNAME_HEK((CV *)sv); if (hek) share_hek_hek(hek); + if (gv) SvREFCNT_inc_void_NN(sv_2mortal((SV *)gv)); cv_undef(MUTABLE_CV(sv)); if (gv) CvGV_set(MUTABLE_CV(sv), gv); else if (hek) { diff --git a/t/op/anonsub.t b/t/op/anonsub.t index ceb8d09..d65acfe 100644 --- a/t/op/anonsub.t +++ b/t/op/anonsub.t @@ -98,3 +98,16 @@ print __ANON__; sub(){3}; EXPECT 42 +######## +# NAME undef &anon giving it a freed GV +$_ = sub{}; +delete $::{__ANON__}; +undef &$_; # SvREFCNT_dec + inc on a GV with a refcnt of 1 + # so now SvTYPE(CvGV(anon)) is 0xff == freed +if (!eval { require B }) { # miniperl, presumably + print "__ANON__\n"; +} else { + print B::svref_2object($_)->GV->NAME, "\n"; +} +EXPECT +__ANON__ diff --git a/t/op/lexsub.t b/t/op/lexsub.t index 1efcf1c..d2edb79 100644 --- a/t/op/lexsub.t +++ b/t/op/lexsub.t @@ -7,7 +7,7 @@ BEGIN { *bar::is = *is; *bar::like = *like; } -plan 133; +plan 135; # -------------------- Errors with feature disabled -------------------- # @@ -376,6 +376,10 @@ like runperl( 'state subs and DB::sub under -d' ); } +# This used to fail an assertion, but only as a standalone script +is runperl(switches => ['-lXMfeature=:all'], + prog => 'state sub x {}; undef &x; print defined &x', + stderr => 1), "\n", 'undefining state sub'; # -------------------- my -------------------- # @@ -719,6 +723,10 @@ pass "pad taking ownership once more of packagified my-sub"; 'my subs and DB::sub under -d' ); } +# This used to fail an assertion, but only as a standalone script +is runperl(switches => ['-lXMfeature=:all'], + prog => 'my sub x {}; undef &x; print defined &x', + stderr => 1), "\n", 'undefining my sub'; # -------------------- Interactions (and misc tests) -------------------- # -- Perl5 Master Repository
