Fix CvOUTSIDE assert/refcnt bugs with sub redefinition

my $sub = sub { 4 };
*foo = $sub;
*bar = *foo;
undef &$sub;
eval "sub bar { 3 }";
undef *foo;
undef *bar;

As of 5.8.4, this script produces:

Attempt to free unreferenced scalar: SV 0x8002c4.

As of 5.14.0:

panic: del_backref.

Or, undef debugging builds:

Assertion failed: (!CvWEAKOUTSIDE(cv)), function Perl_newATTRSUB_flags, file op.c, line 7045.

Commit 5c41a5fa918 (backported to 5.8.4 in commit 7a565e5d) caused the
first bug:

commit 5c41a5fa918d32924e1ac2f02418d5d7f465ef26
Author: Dave Mitchell <davem@fdisolutions.com>
Date:   Sun Jan 25 02:04:23 2004 +0000

    Remove small memory leak in newATTRSUB that manifested as a
    leaking scalar after the interpeter was cloned

    p4raw-id: //depot/perl@22209

diff --git a/op.c b/op.c
index b902fed..5fd21bf 100644
--- a/op.c
+++ b/op.c
@@ -4165,6 +4165,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	/* transfer PL_compcv to cv */
 	cv_undef(cv);
 	CvFLAGS(cv) = CvFLAGS(PL_compcv);
+	if (!CvWEAKOUTSIDE(cv))
+	    SvREFCNT_dec(CvOUTSIDE(cv));
 	CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
 	CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
 	CvOUTSIDE(PL_compcv) = 0;

Checking the flags right after clobbering them can’t be a good idea.

Commit 437388a93 caused the panics and assertion failures.  See com-
mit f6894bc for detail.

Commit f6894bc fixed the panics and assertion failures involving CvGV.

One remaining assertion (!CvWEAKOUTSIDE) added by 437388a93 is still
incorrect.  It’s not true that CvWEAKOUTSIDE is never set on a re-
used stub.

In both cases (5c41a5fa’s code and 437388a93’s code), the weakness
of CvOUTSIDE is ignored and the outside sub (the eval) is freed
prematurely.

It could be that this type of redefinition should be disallowed (des-
pite its usefulness), but that is a separate issue.  This used to
work.  And pure-Perl code should not be triggering assertion failures
or freeing scalars twice.

diff --git a/op.c b/op.c
index 578dbb3..276dbd8 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7039,11 +7039,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
            AV *const temp_av = CvPADLIST(cv);
            CV *const temp_cv = CvOUTSIDE(cv);
-           const cv_flags_t slabbed = CvSLABBED(cv);
+           const cv_flags_t other_flags =
+               CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
            OP * const cvstart = CvSTART(cv);
 
-           assert(!CvWEAKOUTSIDE(cv));
-
            CvGV_set(cv,gv);
            assert(!CvCVGV_RC(cv));
            assert(CvGV(cv) == gv);
@@ -7057,8 +7056,8 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            CvPADLIST(PL_compcv) = temp_av;
            CvSTART(cv) = CvSTART(PL_compcv);
            CvSTART(PL_compcv) = cvstart;
-           if (slabbed) CvSLABBED_on(PL_compcv);
-           else CvSLABBED_off(PL_compcv);
+           CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+           CvFLAGS(PL_compcv) |= other_flags;
 
            if (CvFILE(cv) && CvDYNFILE(cv)) {
                Safefree(CvFILE(cv));

diff --git a/t/op/sub.t b/t/op/sub.t
index 6463e95..c4121df 100644 (file)
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 15 );
+plan( tests => 16 );
 
 sub empty_sub {}
 
@@ -72,3 +72,16 @@ fresh_perl_is
 eval 'sub bar { print +(caller 0)[3], "\n" }';
 bar();
 end
+
+fresh_perl_is
+  <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub';
+my $sub = sub { 4 };
+*foo = $sub;
+*bar = *foo;
+undef &$sub;
+eval 'sub bar { print +(caller 0)[3], "\n" }';
+&$sub;
+undef *foo;
+undef *bar;
+print "ok\n";
+end