This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix assertion failure with undef &my_sub/&anon
authorFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 21:28:22 +0000 (14:28 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 15 Sep 2014 21:49:18 +0000 (14:49 -0700)
$ ./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.

pp.c
t/op/anonsub.t
t/op/lexsub.t

diff --git a/pp.c b/pp.c
index ea05bb4..0750ea0 100644 (file)
--- 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);
            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) {
            cv_undef(MUTABLE_CV(sv));
            if (gv) CvGV_set(MUTABLE_CV(sv), gv);
            else if (hek) {
index ceb8d09..d65acfe 100644 (file)
@@ -98,3 +98,16 @@ print __ANON__;
 sub(){3};
 EXPECT
 42
 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__
index 1efcf1c..d2edb79 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
     *bar::is = *is;
     *bar::like = *like;
 }
     *bar::is = *is;
     *bar::like = *like;
 }
-plan 133;
+plan 135;
 
 # -------------------- Errors with feature disabled -------------------- #
 
 
 # -------------------- Errors with feature disabled -------------------- #
 
@@ -376,6 +376,10 @@ like runperl(
     'state subs and DB::sub under -d'
   );
 }
     '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 -------------------- #
 
 
 # -------------------- my -------------------- #
 
@@ -719,6 +723,10 @@ pass "pad taking ownership once more of packagified my-sub";
     'my subs and DB::sub under -d'
   );
 }
     '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) -------------------- #
 
 
 # -------------------- Interactions (and misc tests) -------------------- #