fix deeply nested closures that have no references to lexical in

intervening subs

p4raw-id: //depot/perl@4834

5 files changed, 66 insertions, 22 deletions

diff --git a/embed.h b/embed.h
index 2d5c36b7a5..61ffadfd5a 100644
--- a/embed.h
+++ b/embed.h
@@ -858,6 +858,7 @@
 #define too_many_arguments	S_too_many_arguments
 #define op_clear		S_op_clear
 #define null			S_null
+#define pad_addlex		S_pad_addlex
 #define pad_findlex		S_pad_findlex
 #define newDEFSVOP		S_newDEFSVOP
 #define new_logop		S_new_logop
@@ -2270,6 +2271,7 @@
 #define too_many_arguments(a,b)	S_too_many_arguments(aTHX_ a,b)
 #define op_clear(a)		S_op_clear(aTHX_ a)
 #define null(a)			S_null(aTHX_ a)
+#define pad_addlex(a)		S_pad_addlex(aTHX_ a)
 #define pad_findlex(a,b,c,d,e,f,g)	S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
 #define newDEFSVOP()		S_newDEFSVOP(aTHX)
 #define new_logop(a,b,c,d)	S_new_logop(aTHX_ a,b,c,d)
@@ -4439,6 +4441,8 @@
 #define op_clear		S_op_clear
 #define S_null			CPerlObj::S_null
 #define null			S_null
+#define S_pad_addlex		CPerlObj::S_pad_addlex
+#define pad_addlex		S_pad_addlex
 #define S_pad_findlex		CPerlObj::S_pad_findlex
 #define pad_findlex		S_pad_findlex
 #define S_newDEFSVOP		CPerlObj::S_newDEFSVOP
diff --git a/embed.pl b/embed.pl
index 95dfed9eb0..f235ffb170 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1929,6 +1929,7 @@ s	|OP*	|too_few_arguments|OP *o|char* name
 s	|OP*	|too_many_arguments|OP *o|char* name
 s	|void	|op_clear	|OP* o
 s	|void	|null		|OP* o
+s	|PADOFFSET|pad_addlex	|SV* name
 s	|PADOFFSET|pad_findlex	|char* name|PADOFFSET newoff|U32 seq \
 				|CV* startcv|I32 cx_ix|I32 saweval|U32 flags
 s	|OP*	|newDEFSVOP
diff --git a/op.c b/op.c
index 386e9de0bf..961fe50abc 100644
--- a/op.c
+++ b/op.c
@@ -204,6 +204,31 @@ Perl_pad_allocmy(pTHX_ char *name)
     return off;
 }
 
+STATIC PADOFFSET
+S_pad_addlex(pTHX_ SV *proto_namesv)
+{
+    SV *namesv = NEWSV(1103,0);
+    PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
+    sv_upgrade(namesv, SVt_PVNV);
+    sv_setpv(namesv, SvPVX(proto_namesv));
+    av_store(PL_comppad_name, newoff, namesv);
+    SvNVX(namesv) = (NV)PL_curcop->cop_seq;
+    SvIVX(namesv) = PAD_MAX;			/* A ref, intro immediately */
+    SvFAKE_on(namesv);				/* A ref, not a real var */
+    if (SvFLAGS(proto_namesv) & SVpad_OUR) {	/* An "our" variable */
+	SvFLAGS(namesv) |= SVpad_OUR;
+	(void)SvUPGRADE(namesv, SVt_PVGV);
+	GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
+    }
+    if (SvOBJECT(proto_namesv)) {		/* A typed var */
+	SvOBJECT_on(namesv);
+	(void)SvUPGRADE(namesv, SVt_PVMG);
+	SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
+	PL_sv_objcount++;
+    }
+    return newoff;
+}
+
 #define FINDLEX_NOSEARCH	1		/* don't search outer contexts */
 
 STATIC PADOFFSET
@@ -246,28 +271,10 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
 		    }
 		    depth = 1;
 		}
-		oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
+		oldpad = (AV*)AvARRAY(curlist)[depth];
 		oldsv = *av_fetch(oldpad, off, TRUE);
 		if (!newoff) {		/* Not a mere clone operation. */
-		    SV *namesv = NEWSV(1103,0);
-		    newoff = pad_alloc(OP_PADSV, SVs_PADMY);
-		    sv_upgrade(namesv, SVt_PVNV);
-		    sv_setpv(namesv, name);
-		    av_store(PL_comppad_name, newoff, namesv);
-		    SvNVX(namesv) = (NV)PL_curcop->cop_seq;
-		    SvIVX(namesv) = PAD_MAX;	/* A ref, intro immediately */
-		    SvFAKE_on(namesv);		/* A ref, not a real var */
-		    if (SvFLAGS(sv) & SVpad_OUR) { /* An "our" variable */
-			SvFLAGS(namesv) |= SVpad_OUR;
-			(void)SvUPGRADE(namesv, SVt_PVGV);
-			GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(sv));
-		    }
-		    if (SvOBJECT(sv)) {		/* A typed var */
-			SvOBJECT_on(namesv);
-			(void)SvUPGRADE(namesv, SVt_PVMG);
-			SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(sv));
-			PL_sv_objcount++;
-		    }
+		    newoff = pad_addlex(sv);
 		    if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
 			/* "It's closures all the way down." */
 			CvCLONE_on(PL_compcv);
@@ -281,8 +288,23 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
 				 bcv && bcv != cv && !CvCLONE(bcv);
 				 bcv = CvOUTSIDE(bcv))
 			    {
-				if (CvANON(bcv))
+				if (CvANON(bcv)) {
+				    /* install the missing pad entry in intervening
+				     * nested subs and mark them cloneable.
+				     * XXX fix pad_foo() to not use globals */
+				    AV *ocomppad_name = PL_comppad_name;
+				    AV *ocomppad = PL_comppad;
+				    SV **ocurpad = PL_curpad;
+				    AV *padlist = CvPADLIST(bcv);
+				    PL_comppad_name = (AV*)AvARRAY(padlist)[0];
+				    PL_comppad = (AV*)AvARRAY(padlist)[1];
+				    PL_curpad = AvARRAY(PL_comppad);
+				    pad_addlex(sv);
+				    PL_comppad_name = ocomppad_name;
+				    PL_comppad = ocomppad;
+				    PL_curpad = ocurpad;
 				    CvCLONE_on(bcv);
+				}
 				else {
 				    if (ckWARN(WARN_CLOSURE)
 					&& !CvUNIQUE(bcv) && !CvUNIQUE(cv))
diff --git a/proto.h b/proto.h
index 76cb2f3e31..6f60109c45 100644
--- a/proto.h
+++ b/proto.h
@@ -865,6 +865,7 @@ STATIC OP*	S_too_few_arguments(pTHX_ OP *o, char* name);
 STATIC OP*	S_too_many_arguments(pTHX_ OP *o, char* name);
 STATIC void	S_op_clear(pTHX_ OP* o);
 STATIC void	S_null(pTHX_ OP* o);
+STATIC PADOFFSET	S_pad_addlex(pTHX_ SV* name);
 STATIC PADOFFSET	S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags);
 STATIC OP*	S_newDEFSVOP(pTHX);
 STATIC OP*	S_new_logop(pTHX_ I32 type, I32 flags, OP **firstp, OP **otherp);
diff --git a/t/op/closure.t b/t/op/closure.t
index 2284be6df1..52d2272b80 100755
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use Config;
 
-print "1..169\n";
+print "1..170\n";
 
 my $test = 1;
 sub test (&) {
@@ -157,6 +157,22 @@ test {
   &{$foo[4]}(4)
 };
 
+for my $n (0..4) {
+    $foo[$n] = sub {
+                     # no intervening reference to $n here
+                     sub { $n == $_[0] }
+		   };
+}
+
+test {
+  $foo[0]->()->(0) and
+  $foo[1]->()->(1) and
+  $foo[2]->()->(2) and
+  $foo[3]->()->(3) and
+  $foo[4]->()->(4)
+};
+
+
 # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
 
 {