Integrate change #9108 from maintperl to mainline.

fix memory leak in C<sub X { sub {} }> arising from a refcount
loop between the outer sub and the inner prototype anonsub

this also enables closures returned by subroutines that
subsequently get redefined to work without generating coredumps :)

completely removed the free_closures() hack--it shouldn't be
needed anymore

p4raw-link: @9108 on //depot/maint-5.6/perl: 1cf1f64f42eb50a67f2427ff9d6d24023a2b9997

p4raw-id: //depot/perl@9109
p4raw-branched: from //depot/maint-5.6/perl@9107 'branch in'
	t/op/anonsub.t
p4raw-integrated: from //depot/maint-5.6/perl@9107 'merge in' sv.c
	(@8871..) embed.h (@8886..) pod/perlapi.pod proto.h (@8993..)
	embed.pl (@8995..) MANIFEST (@9030..) op.c op.h (@9055..)
	pp_ctl.c (@9076..)

10 files changed, 216 insertions, 82 deletions

diff --git a/MANIFEST b/MANIFEST
index 33ee16921d..f2671effeb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1538,6 +1538,7 @@ t/lib/tie-substrhash.t	Test for Tie::SubstrHash
 t/lib/timelocal.t	See if Time::Local works
 t/lib/trig.t		See if Math::Trig works
 t/op/64bitint.t		See if 64 bit integers work
+t/op/anonsub.t		See if anonymous subroutines work
 t/op/append.t		See if . works
 t/op/args.t		See if operations on @_ work
 t/op/arith.t		See if arithmetic works
diff --git a/embed.h b/embed.h
index 125540088d..44ff2fd786 100644
--- a/embed.h
+++ b/embed.h
@@ -982,7 +982,6 @@
 #define dopoptoloop		S_dopoptoloop
 #define dopoptosub		S_dopoptosub
 #define dopoptosub_at		S_dopoptosub_at
-#define free_closures		S_free_closures
 #define save_lines		S_save_lines
 #define doeval			S_doeval
 #define doopen_pmc		S_doopen_pmc
@@ -2465,7 +2464,6 @@
 #define dopoptoloop(a)		S_dopoptoloop(aTHX_ a)
 #define dopoptosub(a)		S_dopoptosub(aTHX_ a)
 #define dopoptosub_at(a,b)	S_dopoptosub_at(aTHX_ a,b)
-#define free_closures()		S_free_closures(aTHX)
 #define save_lines(a,b)		S_save_lines(aTHX_ a,b)
 #define doeval(a,b)		S_doeval(aTHX_ a,b)
 #define doopen_pmc(a,b)		S_doopen_pmc(aTHX_ a,b)
@@ -4806,8 +4804,6 @@
 #define dopoptosub		S_dopoptosub
 #define S_dopoptosub_at		CPerlObj::S_dopoptosub_at
 #define dopoptosub_at		S_dopoptosub_at
-#define S_free_closures		CPerlObj::S_free_closures
-#define free_closures		S_free_closures
 #define S_save_lines		CPerlObj::S_save_lines
 #define save_lines		S_save_lines
 #define S_doeval		CPerlObj::S_doeval
diff --git a/embed.pl b/embed.pl
index f004e2c5ca..4cd8acab26 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2357,7 +2357,6 @@ s	|I32	|dopoptolabel	|char *label
 s	|I32	|dopoptoloop	|I32 startingblock
 s	|I32	|dopoptosub	|I32 startingblock
 s	|I32	|dopoptosub_at	|PERL_CONTEXT* cxstk|I32 startingblock
-s	|void	|free_closures
 s	|void	|save_lines	|AV *array|SV *sv
 s	|OP*	|doeval		|int gimme|OP** startop
 s	|PerlIO *|doopen_pmc	|const char *name|const char *mode
diff --git a/op.c b/op.c
index cca2310cd3..421dc9e69d 100644
--- a/op.c
+++ b/op.c
@@ -4158,14 +4158,19 @@ Perl_cv_undef(pTHX_ CV *cv)
 	SAVEVPTR(PL_curpad);
 	PL_curpad = 0;
 
-	if (!CvCLONED(cv))
-	    op_free(CvROOT(cv));
+	op_free(CvROOT(cv));
 	CvROOT(cv) = Nullop;
 	LEAVE;
     }
     SvPOK_off((SV*)cv);		/* forget prototype */
     CvGV(cv) = Nullgv;
-    SvREFCNT_dec(CvOUTSIDE(cv));
+    /* Since closure prototypes have the same lifetime as the containing
+     * CV, they don't hold a refcount on the outside CV.  This avoids
+     * the refcount loop between the outer CV (which keeps a refcount to
+     * the closure prototype in the pad entry for pp_anoncode()) and the
+     * closure prototype, and the ensuing memory leak.  --GSAR */
+    if (!CvANON(cv) || CvCLONED(cv))
+	SvREFCNT_dec(CvOUTSIDE(cv));
     CvOUTSIDE(cv) = Nullcv;
     if (CvCONST(cv)) {
 	SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
@@ -4279,7 +4284,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     CvFILE(cv)		= CvFILE(proto);
     CvGV(cv)		= CvGV(proto);
     CvSTASH(cv)		= CvSTASH(proto);
-    CvROOT(cv)		= CvROOT(proto);
+    CvROOT(cv)		= OpREFCNT_inc(CvROOT(proto));
     CvSTART(cv)		= CvSTART(proto);
     if (outside)
 	CvOUTSIDE(cv)	= (CV*)SvREFCNT_inc(outside);
@@ -4675,8 +4680,30 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	CvOUTSIDE(PL_compcv) = 0;
 	CvPADLIST(cv) = CvPADLIST(PL_compcv);
 	CvPADLIST(PL_compcv) = 0;
-	if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
-	    CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
+	/* inner references to PL_compcv must be fixed up ... */
+	{
+	    AV *padlist = CvPADLIST(cv);
+	    AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+	    AV *comppad = (AV*)AvARRAY(padlist)[1];
+	    SV **namepad = AvARRAY(comppad_name);
+	    SV **curpad = AvARRAY(comppad);
+	    for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+		SV *namesv = namepad[ix];
+		if (namesv && namesv != &PL_sv_undef
+		    && *SvPVX(namesv) == '&')
+		{
+		    CV *innercv = (CV*)curpad[ix];
+		    if (CvOUTSIDE(innercv) == PL_compcv) {
+			CvOUTSIDE(innercv) = cv;
+			if (!CvANON(innercv) || CvCLONED(innercv)) {
+			    (void)SvREFCNT_inc(cv);
+			    SvREFCNT_dec(PL_compcv);
+			}
+		    }
+		}
+	    }
+	}
+	/* ... before we throw it away */
 	SvREFCNT_dec(PL_compcv);
     }
     else {
@@ -4779,6 +4806,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	}
     }
 
+    /* If a potential closure prototype, don't keep a refcount on outer CV.
+     * This is okay as the lifetime of the prototype is tied to the
+     * lifetime of the outer CV.  Avoids memory leak due to reference
+     * loop. --GSAR */
+    if (!name)
+	SvREFCNT_dec(CvOUTSIDE(cv));
+
     if (name || aname) {
 	char *s;
 	char *tname = (name ? name : aname);
diff --git a/op.h b/op.h
index b1b11a511d..6c629427da 100644
--- a/op.h
+++ b/op.h
@@ -413,19 +413,17 @@ struct loop {
 #  define OP_REFCNT_LOCK		MUTEX_LOCK(&PL_op_mutex)
 #  define OP_REFCNT_UNLOCK		MUTEX_UNLOCK(&PL_op_mutex)
 #  define OP_REFCNT_TERM		MUTEX_DESTROY(&PL_op_mutex)
-#  define OpREFCNT_set(o,n)		((o)->op_targ = (n))
-#  define OpREFCNT_inc(o)		((o) ? (++(o)->op_targ, (o)) : Nullop)
-#  define OpREFCNT_dec(o)		(--(o)->op_targ)
 #else
 #  define OP_REFCNT_INIT		NOOP
 #  define OP_REFCNT_LOCK		NOOP
 #  define OP_REFCNT_UNLOCK		NOOP
 #  define OP_REFCNT_TERM		NOOP
-#  define OpREFCNT_set(o,n)		NOOP
-#  define OpREFCNT_inc(o)		(o)
-#  define OpREFCNT_dec(o)		0
 #endif
 
+#define OpREFCNT_set(o,n)		((o)->op_targ = (n))
+#define OpREFCNT_inc(o)			((o) ? (++(o)->op_targ, (o)) : Nullop)
+#define OpREFCNT_dec(o)			(--(o)->op_targ)
+
 /* flags used by Perl_load_module() */
 #define PERL_LOADMOD_DENY		0x1
 #define PERL_LOADMOD_NOIMPORT		0x2
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 1cb3a0c1e9..3454eddfcb 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -1039,7 +1039,7 @@ Tests if some arbitrary number of bytes begins in a valid UTF-8
 character.  Note that an ASCII character is a valid UTF-8 character.
 The actual number of bytes in the UTF-8 character will be returned if
 it is valid, otherwise 0.
- 
+
 	STRLEN	is_utf8_char(U8 *p)
 
 =for hackers
@@ -3268,6 +3268,44 @@ Converts the specified character to uppercase.
 =for hackers
 Found in file handy.h
 
+=item utf8n_to_uvchr
+
+Returns the native character value of the first character in the string C<s>
+which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+length, in bytes, of that character.
+
+Allows length and flags to be passed to low level routine.
+
+	UV	utf8n_to_uvchr(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags)
+
+=for hackers
+Found in file utf8.c
+
+=item utf8n_to_uvuni
+
+Bottom level UTF-8 decode routine.
+Returns the unicode code point value of the first character in the string C<s>
+which is assumed to be in UTF8 encoding and no longer than C<curlen>;
+C<retlen> will be set to the length, in bytes, of that character.
+
+If C<s> does not point to a well-formed UTF8 character, the behaviour
+is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
+it is assumed that the caller will raise a warning, and this function
+will silently just set C<retlen> to C<-1> and return zero.  If the
+C<flags> does not contain UTF8_CHECK_ONLY, warnings about
+malformations will be given, C<retlen> will be set to the expected
+length of the UTF-8 character in bytes, and zero will be returned.
+
+The C<flags> can also contain various flags to allow deviations from
+the strict UTF-8 encoding (see F<utf8.h>).
+
+Most code should use utf8_to_uvchr() rather than call this directly.
+
+	UV	utf8n_to_uvuni(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags)
+
+=for hackers
+Found in file utf8.c
+
 =item utf8_distance
 
 Returns the number of UTF8 characters between the UTF-8 pointers C<a>
@@ -3321,56 +3359,69 @@ removed without notice.
 =for hackers
 Found in file utf8.c
 
-=item utf8_to_uv
+=item utf8_to_uvchr
 
-Returns the character value of the first character in the string C<s>
-which is assumed to be in UTF8 encoding and no longer than C<curlen>;
-C<retlen> will be set to the length, in bytes, of that character.
-
-If C<s> does not point to a well-formed UTF8 character, the behaviour
-is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
-it is assumed that the caller will raise a warning, and this function
-will silently just set C<retlen> to C<-1> and return zero.  If the
-C<flags> does not contain UTF8_CHECK_ONLY, warnings about
-malformations will be given, C<retlen> will be set to the expected
-length of the UTF-8 character in bytes, and zero will be returned.
+Returns the native character value of the first character in the string C<s>
+which is assumed to be in UTF8 encoding; C<retlen> will be set to the
+length, in bytes, of that character.
 
-The C<flags> can also contain various flags to allow deviations from
-the strict UTF-8 encoding (see F<utf8.h>).
+If C<s> does not point to a well-formed UTF8 character, zero is
+returned and retlen is set, if possible, to -1.
 
-	UV	utf8_to_uv(U8 *s, STRLEN curlen, STRLEN* retlen, U32 flags)
+	UV	utf8_to_uvchr(U8 *s, STRLEN* retlen)
 
 =for hackers
 Found in file utf8.c
 
-=item utf8_to_uv_simple
+=item utf8_to_uvuni
 
-Returns the character value of the first character in the string C<s>
+Returns the Unicode code point of the first character in the string C<s>
 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
 length, in bytes, of that character.
 
+This function should only be used when returned UV is considered
+an index into the Unicode semantic tables (e.g. swashes).
+
 If C<s> does not point to a well-formed UTF8 character, zero is
 returned and retlen is set, if possible, to -1.
 
-	UV	utf8_to_uv_simple(U8 *s, STRLEN* retlen)
+	UV	utf8_to_uvuni(U8 *s, STRLEN* retlen)
+
+=for hackers
+Found in file utf8.c
+
+=item uvchr_to_utf8
+
+Adds the UTF8 representation of the Native codepoint C<uv> to the end
+of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
+bytes available. The return value is the pointer to the byte after the
+end of the new character. In other words,
+
+    d = uvchr_to_utf8(d, uv);
+
+is the recommended wide native character-aware way of saying
+
+    *(d++) = uv;
+
+	U8*	uvchr_to_utf8(U8 *d, UV uv)
 
 =for hackers
 Found in file utf8.c
 
-=item uv_to_utf8
+=item uvuni_to_utf8
 
 Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
 of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
 bytes available. The return value is the pointer to the byte after the
-end of the new character. In other words, 
+end of the new character. In other words,
 
-    d = uv_to_utf8(d, uv);
+    d = uvuni_to_utf8(d, uv);
 
 is the recommended Unicode-aware way of saying
 
     *(d++) = uv;
 
-	U8*	uv_to_utf8(U8 *d, UV uv)
+	U8*	uvuni_to_utf8(U8 *d, UV uv)
 
 =for hackers
 Found in file utf8.c
diff --git a/pp_ctl.c b/pp_ctl.c
index 8985cca9a2..ede5abad97 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1380,41 +1380,6 @@ Perl_dounwind(pTHX_ I32 cxix)
     }
 }
 
-/*
- * Closures mentioned at top level of eval cannot be referenced
- * again, and their presence indirectly causes a memory leak.
- * (Note that the fact that compcv and friends are still set here
- * is, AFAIK, an accident.)  --Chip
- *
- * XXX need to get comppad et al from eval's cv rather than
- * relying on the incidental global values.
- */
-STATIC void
-S_free_closures(pTHX)
-{
-    SV **svp = AvARRAY(PL_comppad_name);
-    I32 ix;
-    for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
-	SV *sv = svp[ix];
-	if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
-	    SvREFCNT_dec(sv);
-	    svp[ix] = &PL_sv_undef;
-
-	    sv = PL_curpad[ix];
-	    if (CvCLONE(sv)) {
-		SvREFCNT_dec(CvOUTSIDE(sv));
-		CvOUTSIDE(sv) = Nullcv;
-	    }
-	    else {
-		SvREFCNT_dec(sv);
-		sv = NEWSV(0,0);
-		SvPADTMP_on(sv);
-		PL_curpad[ix] = sv;
-	    }
-	}
-    }
-}
-
 void
 Perl_qerror(pTHX_ SV *err)
 {
@@ -1951,8 +1916,6 @@ PP(pp_return)
 	POPEVAL(cx);
 	if (CxTRYBLOCK(cx))
 	    break;
-	if (AvFILLp(PL_comppad_name) >= 0)
-	    free_closures();
 	lex_end();
 	if (optype == OP_REQUIRE &&
 	    (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
@@ -3507,9 +3470,6 @@ PP(pp_leaveeval)
     }
     PL_curpm = newpm;	/* Don't pop $1 et al till now */
 
-    if (AvFILLp(PL_comppad_name) >= 0)
-	free_closures();
-
 #ifdef DEBUGGING
     assert(CvDEPTH(PL_compcv) == 1);
 #endif
diff --git a/proto.h b/proto.h
index 7a426be3e4..4e8abe016d 100644
--- a/proto.h
+++ b/proto.h
@@ -1095,7 +1095,6 @@ STATIC I32	S_dopoptolabel(pTHX_ char *label);
 STATIC I32	S_dopoptoloop(pTHX_ I32 startingblock);
 STATIC I32	S_dopoptosub(pTHX_ I32 startingblock);
 STATIC I32	S_dopoptosub_at(pTHX_ PERL_CONTEXT* cxstk, I32 startingblock);
-STATIC void	S_free_closures(pTHX);
 STATIC void	S_save_lines(pTHX_ AV *array, SV *sv);
 STATIC OP*	S_doeval(pTHX_ int gimme, OP** startop);
 STATIC PerlIO *	S_doopen_pmc(pTHX_ const char *name, const char *mode);
diff --git a/sv.c b/sv.c
index 0a2c2c07b9..36735ae085 100644
--- a/sv.c
+++ b/sv.c
@@ -8179,7 +8179,10 @@ dup_pvcv:
 	}
 	else
 	    CvPADLIST(dstr)	= av_dup_inc(CvPADLIST(sstr));
-	CvOUTSIDE(dstr)	= cv_dup_inc(CvOUTSIDE(sstr));
+	if (!CvANON(sstr) || CvCLONED(sstr))
+	    CvOUTSIDE(dstr)	= cv_dup_inc(CvOUTSIDE(sstr));
+	else
+	    CvOUTSIDE(dstr)	= cv_dup(CvOUTSIDE(sstr));
 	CvFLAGS(dstr)	= CvFLAGS(sstr);
 	break;
     default:
diff --git a/t/op/anonsub.t b/t/op/anonsub.t
new file mode 100755
index 0000000000..17889d9d2f
--- /dev/null
+++ b/t/op/anonsub.t
@@ -0,0 +1,93 @@
+#!./perl
+
+chdir 't' if -d 't';
+@INC = '../lib';
+$Is_VMS = $^O eq 'VMS';
+$Is_MSWin32 = $^O eq 'MSWin32';
+$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "asubtmp000";
+1 while -f ++$tmpfile;
+END { if ($tmpfile) { 1 while unlink $tmpfile; } }
+
+for (@prgs){
+    my $switch = "";
+    if (s/^\s*(-\w+)//){
+       $switch = $1;
+    }
+    my($prog,$expected) = split(/\nEXPECT\n/, $_);
+    open TEST, ">$tmpfile";
+    print TEST "$prog\n";
+    close TEST;
+    my $results = $Is_VMS ?
+                  `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
+		      $Is_MSWin32 ?  
+			  `.\\perl -I../lib $switch $tmpfile 2>&1` :
+			      `./perl $switch $tmpfile 2>&1`;
+    my $status = $?;
+    $results =~ s/\n+$//;
+    # allow expected output to be written as if $prog is on STDIN
+    $results =~ s/runltmp\d+/-/g;
+    $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
+    $expected =~ s/\n+$//;
+    if ($results ne $expected) {
+       print STDERR "PROG: $switch\n$prog\n";
+       print STDERR "EXPECTED:\n$expected\n";
+       print STDERR "GOT:\n$results\n";
+       print "not ";
+    }
+    print "ok ", ++$i, "\n";
+}
+
+__END__
+sub X {
+    my $n = "ok 1\n";
+    sub { print $n };
+}
+my $x = X();
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X {
+    my $n = "ok 1\n";
+    sub {
+        my $dummy = $n;	# eval can't close on $n without internal reference
+	eval 'print $n';
+	die $@ if $@;
+    };
+}
+my $x = X();
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X {
+    my $n = "ok 1\n";
+    eval 'sub { print $n }';
+}
+my $x = X();
+die $@ if $@;
+undef &X;
+$x->();
+EXPECT
+ok 1
+########
+sub X;
+sub X {
+    my $n = "ok 1\n";
+    eval 'sub Y { my $p = shift; $p->() }';
+    die $@ if $@;
+    Y(sub { print $n });
+}
+X();
+EXPECT
+ok 1