In newATTRSUB, clear glob slot before lowering refcount.

(Actually in its subroutine, S_already_defined.)

Otherwise, when newATTRSUB redefines a sub, the previous sub’s DESTROY
can see the same sub still in the typeglob, but without a reference
count, so *typeglob = sub {} frees the sub currently in $_[0].

$ perl5.18.1 -le '
    sub foo{}
    bless \&foo;
    DESTROY {
        print "before: $_[0]"; *foo=sub{}; print "after: $_[0]"
    }
    eval "sub foo{}";
'
before: main=CODE(0x7fa88382d6d8)
before: main=CODE(0x7fa88382d6d8)
after: main=CODE(0x7fa88382d6d8)
after: UNKNOWN(0x7fa88382d6d8)

diff --git a/op.c b/op.c
index 6eee9e0..072d0d0 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7195,7 +7195,8 @@ Perl_op_const_sv(pTHX_ const OP *o)
 
 static bool
 S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
-                       PADNAME * const name, SV ** const const_svp)
+                       PADNAME * const name, SV ** const const_svp,
+                       GV * const gv)
 {
     assert (cv);
     assert (o || name);
@@ -7246,6 +7247,7 @@ S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
 #endif
     {
        /* (PL_madskills unset in used file.) */
+       if (gv) GvCV_set(gv,NULL);
        SvREFCNT_dec(cv);
     }
     return TRUE;
@@ -7370,7 +7372,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
             cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
        /* already defined? */
        if (exists) {
-           if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
+           if (S_already_defined(aTHX_ cv,block,NULL,name,&const_sv,NULL))
                cv = NULL;
            else {
                if (attrs) goto attrs;
@@ -7742,7 +7744,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
             cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
        /* already defined (or promised)? */
        if (exists || GvASSUMECV(gv)) {
-           if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
+           if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv, gv))
                cv = NULL;
            else {
                if (attrs) goto attrs;

diff --git a/t/op/sub.t b/t/op/sub.t
index ec8e211..06b8d07 100644 (file)
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 32 );
+plan( tests => 33 );
 
 sub empty_sub {}
 
@@ -200,3 +200,18 @@ ok !exists $INC{"re.pm"}, 're.pm not loaded yet';
     is $str[1], $str[0],
       'XSUB clobbering sub whose DESTROY assigns to the glob';
 }
+{
+    no warnings 'redefine';
+    sub foo {}
+    bless \&foo, 'newATTRSUBbug';
+    sub newATTRSUBbug::DESTROY {
+        my $str1 = "$_[0]";
+        *foo = sub{}; # GvSV had no refcount, so this freed it
+        my $str2 = "$_[0]";   # used to be UNKNOWN(0x7fdda29310e0)
+        @str = ($str1, $str2);
+    }
+    splice @str;
+    eval "sub foo{}";
+    is $str[1], $str[0],
+      'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob';
+}