Fix memory leak with recursive sub redefinition

See the thread starting at
<20131115042923.7514.qmail@lists-nntp.develooper.com>.

Commits 7004ee4937 and a61818571 changed subroutine redefinition to
null the GvCV slot before freeing the CV, so that destructors won’t
see GvCV without a reference count.  That turns a double free into a
memory leak.

Kent Fredric explains it nice and clearly:

> sub foo{}   # A
> bless \&foo;
> DESTROY { *foo = sub {}  # C }
> eval "sub foo{} "; # B
>
> Previous behaviour was:
>
> B replaces A, triggers DESTROY, which triggers C replacing A, and this
> invoked a double free, because C , triggering the removal of A,
> happened while A still existed ( ?? )
>
> So the change fixes this, so that A is removed from the symbol table
> before DESTROY triggers , so that C is creating a "new" symbol,
> effectively, and the problem is that C is then clobbered by the B
> replacing the slot, after the DESTROY.

So C leaks.

This commit fixes it by changing the SvREFCNT_dec into SAVEFREESV,
essentially delaying the DESTROY until after the subroutine redefini-
tion is complete.

This does mean that C is what ends up in the glob afterwards; but as
long as perl’s own bookkeeping is thrown off, we can leave it to the
user (the Perl programmer) to handle the consequences of naughty
destructors.

2 files changed, 16 insertions, 6 deletions

diff --git a/op.c b/op.c
index 09af08a2f0..3355a65e20 100644
--- a/op.c
+++ b/op.c
@@ -7249,8 +7249,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);
+	SAVEFREESV(cv);
     }
     return TRUE;
 }
@@ -8115,6 +8114,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
 			   U32 flags)
 {
     CV *cv;
+    bool interleave = FALSE;
 
     PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
 
@@ -8144,8 +8144,9 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
                                         ),
                                         cv, const_svp);
                 }
-                GvCV_set(gv,NULL);
-                SvREFCNT_dec_NN(cv);
+                interleave = TRUE;
+                ENTER;
+                SAVEFREESV(cv);
                 cv = NULL;
             }
         }
@@ -8180,6 +8181,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
 	CvDYNFILE_on(cv);
     }
     sv_setpv(MUTABLE_SV(cv), proto);
+    if (interleave) LEAVE;
     return cv;
 }
 
diff --git a/t/op/svleak.t b/t/op/svleak.t
index f7fc0abb38..b1f923abcc 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
 
 use Config;
 
-plan tests => 125;
+plan tests => 126;
 
 # run some code N times. If the number of SVs at the end of loop N is
 # greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -87,7 +87,7 @@ eleak(2, 0, "$all /\$\\ /", '/$\ / with fatal warnings');
 eleak(2, 0, "$all s//\\1/", 's//\1/ with fatal warnings');
 eleak(2, 0, "$all qq|\\i|", 'qq|\i| with fatal warnings');
 eleak(2, 0, "$f 'digit'; qq|\\o{9}|", 'qq|\o{9}| with fatal warnings');
-eleak(2, 0, "$f 'misc'; sub foo{} sub foo:lvalue",
+eleak(3, 1, "$f 'misc'; sub foo{} sub foo:lvalue",
      'ignored :lvalue with fatal warnings');
 eleak(2, 0, "no warnings; use feature ':all'; $f 'misc';
              my sub foo{} sub foo:lvalue",
@@ -296,6 +296,14 @@ leak(2, 0, sub { sub { local $_[0]; shift }->(1) },
 leak(2, 0, sub { sub { local $_[0]; \@_ }->(1) },
     'local $_[0] on surreal @_, followed by reification');
 
+sub recredef {}
+sub Recursive::Redefinition::DESTROY {
+    *recredef = sub { CORE::state $x } # state makes it cloneable
+}
+leak(2, 0, sub {
+    bless \&recredef, "Recursive::Redefinition"; eval "sub recredef{}"
+}, 'recursive sub redefinition');
+
 # Syntax errors
 eleak(2, 0, '"${<<END}"
                  ', 'unterminated here-doc in quotes in multiline eval');