allow evals to see the full lexical scope

Message-ID: <20021124221906.A25386@fdgroup.com>

p4raw-id: //depot/perl@18220

21 files changed, 272 insertions, 149 deletions

diff --git a/cop.h b/cop.h
index fe0ca8a641..870225ca5d 100644
--- a/cop.h
+++ b/cop.h
@@ -5,6 +5,11 @@
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
+ * Control ops (cops) are one of the three ops OP_NEXTSTATE, OP_DBSTATE,
+ * and OP_SETSTATE that (loosely speaking) separate statements. They hold
+ * imformation important for lexical state and error reporting. At run
+ * time, PL_curcop is set to point to the most recently executed cop,
+ * and thus can be used to determine our current state.
  */
 
 struct cop {
diff --git a/cv.h b/cv.h
index cb47c0ff07..4611387d8c 100644
--- a/cv.h
+++ b/cv.h
@@ -30,6 +30,9 @@ struct xpvcv {
     PADLIST *	xcv_padlist;
     CV *	xcv_outside;
     cv_flags_t	xcv_flags;
+    U32		xcv_outside_seq; /* the COP sequence (at the point of our
+				  * compilation) in the lexically enclosing
+				  * sub */
 };
 
 /*
@@ -65,6 +68,7 @@ Returns the stash of the CV.
 #define CvPADLIST(sv)	((XPVCV*)SvANY(sv))->xcv_padlist
 #define CvOUTSIDE(sv)	((XPVCV*)SvANY(sv))->xcv_outside
 #define CvFLAGS(sv)	((XPVCV*)SvANY(sv))->xcv_flags
+#define CvOUTSIDE_SEQ(sv) ((XPVCV*)SvANY(sv))->xcv_outside_seq
 
 #define CVf_CLONE	0x0001	/* anon CV uses external lexicals */
 #define CVf_CLONED	0x0002	/* a clone of one of those */
diff --git a/dump.c b/dump.c
index 45d7494341..d874d32811 100644
--- a/dump.c
+++ b/dump.c
@@ -1287,6 +1287,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
 	Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
 	Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
+	Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
 	if (type == SVt_PVFM)
 	    Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
 	Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
diff --git a/embed.fnc b/embed.fnc
index c115249f9c..08a8f9d13a 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1070,7 +1070,7 @@ s	|I32	|dopoptoloop	|I32 startingblock
 s	|I32	|dopoptosub	|I32 startingblock
 s	|I32	|dopoptosub_at	|PERL_CONTEXT* cxstk|I32 startingblock
 s	|void	|save_lines	|AV *array|SV *sv
-s	|OP*	|doeval		|int gimme|OP** startop
+s	|OP*	|doeval		|int gimme|OP** startop|CV* outside|U32 seq
 s	|PerlIO *|doopen_pmc	|const char *name|const char *mode
 s	|bool	|path_is_absolute|char *name
 #endif
@@ -1329,7 +1329,7 @@ s	|void	|deb_stack_n	|SV** stack_base|I32 stack_min \
 #endif
 
 pd	|PADLIST*|pad_new	|padnew_flags flags
-pd	|void	|pad_undef	|CV* cv|CV* outercv
+pd	|void	|pad_undef	|CV* cv
 pd	|PADOFFSET|pad_add_name	|char *name\
 				|HV* typestash|HV* ourstash \
 				|bool clone
@@ -1347,13 +1347,13 @@ pd	|void	|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv
 pd	|void	|pad_push	|PADLIST *padlist|int depth|int has_args
 
 #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
-sd	|PADOFFSET|pad_findlex	|char* name|PADOFFSET newoff|U32 seq \
-				|CV* startcv|I32 cx_ix|I32 saweval|U32 flags
+sd	|PADOFFSET|pad_findlex	|char* name|PADOFFSET newoff|CV* innercv
 #  if defined(DEBUGGING)
 sd	|void	|cv_dump	|CV *cv|char *title
 #  endif
 s	|CV*	|cv_clone2	|CV *proto|CV *outside
 #endif
+pd 	|CV*	|find_runcv
 
 
 
diff --git a/embed.h b/embed.h
index 9dde007995..828746e33b 100644
--- a/embed.h
+++ b/embed.h
@@ -1211,6 +1211,7 @@
 #  endif
 #define cv_clone2		S_cv_clone2
 #endif
+#define find_runcv		Perl_find_runcv
 #define ck_anoncode		Perl_ck_anoncode
 #define ck_bitop		Perl_ck_bitop
 #define ck_concat		Perl_ck_concat
@@ -2513,7 +2514,7 @@
 #define dopoptosub(a)		S_dopoptosub(aTHX_ a)
 #define dopoptosub_at(a,b)	S_dopoptosub_at(aTHX_ a,b)
 #define save_lines(a,b)		S_save_lines(aTHX_ a,b)
-#define doeval(a,b)		S_doeval(aTHX_ a,b)
+#define doeval(a,b,c,d)		S_doeval(aTHX_ a,b,c,d)
 #define doopen_pmc(a,b)		S_doopen_pmc(aTHX_ a,b)
 #define path_is_absolute(a)	S_path_is_absolute(aTHX_ a)
 #endif
@@ -2740,7 +2741,7 @@
 #define deb_stack_n(a,b,c,d,e)	S_deb_stack_n(aTHX_ a,b,c,d,e)
 #endif
 #define pad_new(a)		Perl_pad_new(aTHX_ a)
-#define pad_undef(a,b)		Perl_pad_undef(aTHX_ a,b)
+#define pad_undef(a)		Perl_pad_undef(aTHX_ a)
 #define pad_add_name(a,b,c,d)	Perl_pad_add_name(aTHX_ a,b,c,d)
 #define pad_add_anon(a,b)	Perl_pad_add_anon(aTHX_ a,b)
 #define pad_check_dup(a,b,c)	Perl_pad_check_dup(aTHX_ a,b,c)
@@ -2753,12 +2754,13 @@
 #define pad_fixup_inner_anons(a,b,c)	Perl_pad_fixup_inner_anons(aTHX_ a,b,c)
 #define pad_push(a,b,c)		Perl_pad_push(aTHX_ a,b,c)
 #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
-#define pad_findlex(a,b,c,d,e,f,g)	S_pad_findlex(aTHX_ a,b,c,d,e,f,g)
+#define pad_findlex(a,b,c)	S_pad_findlex(aTHX_ a,b,c)
 #  if defined(DEBUGGING)
 #define cv_dump(a,b)		S_cv_dump(aTHX_ a,b)
 #  endif
 #define cv_clone2(a,b)		S_cv_clone2(aTHX_ a,b)
 #endif
+#define find_runcv()		Perl_find_runcv(aTHX)
 #define ck_anoncode(a)		Perl_ck_anoncode(aTHX_ a)
 #define ck_bitop(a)		Perl_ck_bitop(aTHX_ a)
 #define ck_concat(a)		Perl_ck_concat(aTHX_ a)
diff --git a/ext/B/B.pm b/ext/B/B.pm
index c1bd852d20..f75e54bae0 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -843,6 +843,8 @@ IoIFP($io) == PerlIO_stdin() ).
 
 =item OUTSIDE
 
+=item OUTSIDE_SEQ
+
 =item XSUB
 
 =item XSUBANY
diff --git a/ext/B/B.xs b/ext/B/B.xs
index f24d0705c2..9001031bc1 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -1412,6 +1412,10 @@ B::CV
 CvOUTSIDE(cv)
 	B::CV	cv
 
+U32
+CvOUTSIDE_SEQ(cv)
+	B::CV	cv
+
 void
 CvXSUB(cv)
 	B::CV	cv
diff --git a/ext/B/B/Bytecode.pm b/ext/B/B/Bytecode.pm
index dd49c029ea..d1125bdc44 100644
--- a/ext/B/B/Bytecode.pm
+++ b/ext/B/B/Bytecode.pm
@@ -652,7 +652,8 @@ sub B::CV::bytecode {
     for ($i = 0; $i < @ixes; $i++) {
 	asmf "xcv_%s %d\n", lc($subfield_names[$i]), $ixes[$i];
     }
-    asmf "xcv_depth %d\nxcv_flags 0x%x\n", $cv->DEPTH, $cv->CvFLAGS;
+    asmf "xcv_depth %d\nxcv_flags 0x%x\nxcv_outside_seq 0x%x",
+	$cv->DEPTH, $cv->CvFLAGS, $cv->OUTSIDE_SEQ;
     asmf "xcv_file %d\n", $fileix;
     # Now save all the subfields (except for CvROOT which was handled
     # above) and CvSTART (now the initial element of @subfields).
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 77582d25e0..9ae2359801 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -1012,10 +1012,11 @@ sub B::CV::save {
 		     $cvstashname, $cvname); # debug
     }              
     $pv = '' unless defined $pv; # Avoid use of undef warnings
-    $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x",
+    $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x",
 			  $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
 			  $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
-                        $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
+                        $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS,
+			$cv->OUTSIDE_SEQ));
 
     if (${$cv->OUTSIDE} == ${main_cv()}){
 	$init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
@@ -1436,6 +1437,9 @@ typedef struct {
     AV *	xcv_padlist;
     CV *	xcv_outside;
     cv_flags_t	xcv_flags;
+    U32		xcv_outside_seq; /* the COP sequence (at the point of our
+				  * compilation) in the lexically enclosing
+				  * sub */
 } XPVCV_or_similar;
 #define ANYINIT(i) i
 #else
diff --git a/ext/B/B/Debug.pm b/ext/B/B/Debug.pm
index f9f8c092f7..da8b1474f4 100644
--- a/ext/B/B/Debug.pm
+++ b/ext/B/B/Debug.pm
@@ -198,7 +198,7 @@ sub B::CV::debug {
     my ($padlist) = $sv->PADLIST;
     my ($file) = $sv->FILE;
     my ($gv) = $sv->GV;
-    printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
+    printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
 	STASH		0x%x
 	START		0x%x
 	ROOT		0x%x
@@ -207,6 +207,7 @@ sub B::CV::debug {
 	DEPTH		%d
 	PADLIST		0x%x			       
 	OUTSIDE		0x%x
+	OUTSIDE_SEQ	%d
 EOT
     $start->debug if $start;
     $root->debug if $root;
diff --git a/ext/Devel/Peek/Peek.t b/ext/Devel/Peek/Peek.t
index 1230026c2e..529d3c9fa9 100644
--- a/ext/Devel/Peek/Peek.t
+++ b/ext/Devel/Peek/Peek.t
@@ -221,6 +221,7 @@ do_test(13,
 (?:    MUTEXP = $ADDR
     OWNER = $ADDR
 )?    FLAGS = 0x4
+    OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
     OUTSIDE = $ADDR \\(MAIN\\)');
@@ -247,6 +248,7 @@ do_test(14,
 (?:    MUTEXP = $ADDR
     OWNER = $ADDR
 )?    FLAGS = 0x0
+    OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
        \\d+\\. $ADDR<\\d+>      \\(\\d+,\\d+\\) "\\$pattern"
diff --git a/op.c b/op.c
index c3aee1e68b..c46bbfce0e 100644
--- a/op.c
+++ b/op.c
@@ -3756,7 +3756,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 void
 Perl_cv_undef(pTHX_ CV *cv)
 {
-    CV *outsidecv;
     CV *freecv = Nullcv;
 
 #ifdef USE_ITHREADS
@@ -3780,20 +3779,21 @@ Perl_cv_undef(pTHX_ CV *cv)
     }
     SvPOK_off((SV*)cv);		/* forget prototype */
     CvGV(cv) = Nullgv;
-    outsidecv = CvOUTSIDE(cv);
+
+    pad_undef(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))
-        freecv = outsidecv;
+        freecv = CvOUTSIDE(cv);
     CvOUTSIDE(cv) = Nullcv;
     if (CvCONST(cv)) {
 	SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
 	CvCONST_off(cv);
     }
-    pad_undef(cv, outsidecv);
     if (freecv)
 	SvREFCNT_dec(freecv);
     if (CvXSUB(cv)) {
@@ -4086,9 +4086,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    SAVEFREESV(PL_compcv);
 	    goto done;
 	}
+	/* transfer PL_compcv to cv */
 	cv_undef(cv);
 	CvFLAGS(cv) = CvFLAGS(PL_compcv);
 	CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
+	CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
 	CvOUTSIDE(PL_compcv) = 0;
 	CvPADLIST(cv) = CvPADLIST(PL_compcv);
 	CvPADLIST(PL_compcv) = 0;
diff --git a/pad.c b/pad.c
index 590aad8d15..0dfc989b2e 100644
--- a/pad.c
+++ b/pad.c
@@ -194,13 +194,13 @@ Free the padlist associated with a CV.
 If parts of it happen to be current, we null the relevant
 PL_*pad* global vars so that we don't have any dangling references left.
 We also repoint the CvOUTSIDE of any about-to-be-orphaned
-inner subs to outercv.
+inner subs to the outer of this cv.
 
 =cut
 */
 
 void
-Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
+Perl_pad_undef(pTHX_ CV* cv)
 {
     I32 ix;
     PADLIST *padlist = CvPADLIST(cv);
@@ -218,10 +218,12 @@ Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
     if ((CvEVAL(cv) && !CvGV(cv) /* is this eval"" ? */
 	    && !PL_dirty) || CvSPECIAL(cv))
     {
+	CV *outercv = CvOUTSIDE(cv);
+	U32 seq     = CvOUTSIDE_SEQ(cv);
 	/* XXX DAPM the following code is very similar to
 	 * pad_fixup_inner_anons(). Merge??? */
 
-	/* inner references to eval's cv must be fixed up */
+	/* inner references to eval's/BEGIN's/etc cv must be fixed up */
 	AV *comppad_name = (AV*)AvARRAY(padlist)[0];
 	SV **namepad = AvARRAY(comppad_name);
 	AV *comppad = (AV*)AvARRAY(padlist)[1];
@@ -237,6 +239,8 @@ Perl_pad_undef(pTHX_ CV* cv, CV* outercv)
 		    && CvOUTSIDE(innercv) == cv)
 		{
 		    CvOUTSIDE(innercv) = outercv;
+		    CvOUTSIDE_SEQ(innercv) = seq;
+		    /* anon prototypes aren't refcounted */
 		    if (!CvANON(innercv) || CvCLONED(innercv)) {
 			(void)SvREFCNT_inc(outercv);
 			if (SvREFCNT(cv))
@@ -529,8 +533,6 @@ Perl_pad_findmy(pTHX_ char *name)
     SV *sv;
     SV **svp = AvARRAY(PL_comppad_name);
     U32 seq = PL_cop_seqmax;
-    PERL_CONTEXT *cx;
-    CV *outside;
 
     ASSERT_CURPAD_ACTIVE("pad_findmy");
     DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad findmy:  \"%s\"\n", name));
@@ -550,20 +552,8 @@ Perl_pad_findmy(pTHX_ char *name)
 	}
     }
 
-    outside = CvOUTSIDE(PL_compcv);
-
-    /* Check if if we're compiling an eval'', and adjust seq to be the
-     * eval's seq number.  This depends on eval'' having a non-null
-     * CvOUTSIDE() while it is being compiled.  The eval'' itself is
-     * identified by CvEVAL being true and CvGV being null. */
-    if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
-	cx = &cxstack[cxstack_ix];
-	if (CxREALEVAL(cx))
-	    seq = cx->blk_oldcop->cop_seq;
-    }
-
     /* See if it's in a nested scope */
-    off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
+    off = pad_findlex(name, 0, PL_compcv);
     if (!off)			/* pad_findlex returns 0 for failure...*/
 	return NOT_IN_PAD;	/* ...but we return NOT_IN_PAD for failure */
 
@@ -579,41 +569,40 @@ Perl_pad_findmy(pTHX_ char *name)
 =for apidoc pad_findlex
 
 Find a named lexical anywhere in a chain of nested pads. Add fake entries
-in the inner pads if its found in an outer one.
-
-If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
+in the inner pads if it's found in an outer one. innercv is the CV *inside*
+the chain of outer CVs to be searched. If newoff is non-null, this is a
+run-time cloning: don't add fake entries, just find the lexical and add a
+ref to it at newoff in the current pad.
 
 =cut
 */
 
-#define FINDLEX_NOSEARCH	1	/* don't search outer contexts */
-
 STATIC PADOFFSET
-S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
-	    I32 cx_ix, I32 saweval, U32 flags)
+S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, CV* innercv)
 {
     CV *cv;
     I32 off;
     SV *sv;
-    register I32 i;
-    register PERL_CONTEXT *cx;
+    CV* startcv;
+    U32 seq;
 
     ASSERT_CURPAD_ACTIVE("pad_findlex");
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-	"Pad findlex: \"%s\" off=%ld seq=%lu cv=0x%"UVxf
-	    " ix=%ld saweval=%d flags=%lu\n",
-	    name, (long)newoff, (unsigned long)seq, PTR2UV(startcv),
-	    (long)cx_ix, (int)saweval, (unsigned long)flags
-	)
+	"Pad findlex: \"%s\" off=%ld startcv=0x%"UVxf"\n",
+	    name, (long)newoff, PTR2UV(innercv))
     );
 
-    for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
+    seq = CvOUTSIDE_SEQ(innercv);
+    startcv = CvOUTSIDE(innercv);
+
+    for (cv = startcv; cv; seq = CvOUTSIDE_SEQ(cv), cv = CvOUTSIDE(cv)) {
 	AV *curlist = CvPADLIST(cv);
 	SV **svp = av_fetch(curlist, 0, FALSE);
 	AV *curname;
 
 	DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-	    "             searching: cv=0x%"UVxf"\n", PTR2UV(cv))
+	    "             searching: cv=0x%"UVxf" seq=%d\n",
+	    PTR2UV(cv), (int) seq )
 	);
 
 	if (!svp || *svp == &PL_sv_undef)
@@ -735,59 +724,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
 	    return newoff;
 	}
     }
-
-    if (flags & FINDLEX_NOSEARCH)
-	return 0;
-
-    /* Nothing in current lexical context--try eval's context, if any.
-     * This is necessary to let the perldb get at lexically scoped variables.
-     * XXX This will also probably interact badly with eval tree caching.
-     */
-
-    for (i = cx_ix; i >= 0; i--) {
-	cx = &cxstack[i];
-	switch (CxTYPE(cx)) {
-	default:
-	    if (i == 0 && saweval) {
-		return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
-	    }
-	    break;
-	case CXt_EVAL:
-	    switch (cx->blk_eval.old_op_type) {
-	    case OP_ENTEREVAL:
-		if (CxREALEVAL(cx)) {
-		    PADOFFSET off;
-		    saweval = i;
-		    seq = cxstack[i].blk_oldcop->cop_seq;
-		    startcv = cxstack[i].blk_eval.cv;
-		    if (startcv && CvOUTSIDE(startcv)) {
-			off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
-					  i - 1, saweval, 0);
-			if (off)	/* continue looking if not found here */
-			    return off;
-		    }
-		}
-		break;
-	    case OP_DOFILE:
-	    case OP_REQUIRE:
-		/* require/do must have their own scope */
-		return 0;
-	    }
-	    break;
-	case CXt_FORMAT:
-	case CXt_SUB:
-	    if (!saweval)
-		return 0;
-	    cv = cx->blk_sub.cv;
-	    if (PL_debstash && CvSTASH(cv) == PL_debstash) {	/* ignore DB'* scope */
-		saweval = i;	/* so we know where we were called from */
-		seq = cxstack[i].blk_oldcop->cop_seq;
-		continue;
-	    }
-	    return pad_findlex(name, newoff, seq, cv, i - 1, saweval, FINDLEX_NOSEARCH);
-	}
-    }
-
     return 0;
 }
 
@@ -1315,8 +1251,10 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
     CvSTASH(cv)		= CvSTASH(proto);
     CvROOT(cv)		= OpREFCNT_inc(CvROOT(proto));
     CvSTART(cv)		= CvSTART(proto);
-    if (outside)
+    if (outside) {
 	CvOUTSIDE(cv)	= (CV*)SvREFCNT_inc(outside);
+	CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto);
+    }
 
     if (SvPOK(proto))
 	sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
@@ -1334,8 +1272,7 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 	if (namesv && namesv != &PL_sv_undef) {
 	    char *name = SvPVX(namesv);    /* XXX */
 	    if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
-		I32 off = pad_findlex(name, ix, SvIVX(namesv),
-				      CvOUTSIDE(cv), cxstack_ix, 0, 0);
+		I32 off = pad_findlex(name, ix, cv);
 		if (!off)
 		    PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
 		else if (off != ix)
@@ -1432,6 +1369,7 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv)
 	    CV *innercv = (CV*)curpad[ix];
 	    if (CvOUTSIDE(innercv) == old_cv) {
 		CvOUTSIDE(innercv) = new_cv;
+		/* anon prototypes aren't refcounted */
 		if (!CvANON(innercv) || CvCLONED(innercv)) {
 		    (void)SvREFCNT_inc(new_cv);
 		    SvREFCNT_dec(old_cv);
diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index de1f4b21e5..0ec74e0816 100644
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -216,6 +216,23 @@ Found in file pad.h
 
 =back
 
+=head1 Functions in file pp_ctl.c
+
+
+=over 8
+
+=item find_runcv
+
+Locate the CV corresponding to the currently executing sub or eval.
+
+	CV*	find_runcv()
+
+=for hackers
+Found in file pp_ctl.c
+
+
+=back
+
 =head1 Global Variables
 
 =over 8
@@ -505,11 +522,12 @@ Found in file pad.c
 =item pad_findlex
 
 Find a named lexical anywhere in a chain of nested pads. Add fake entries
-in the inner pads if its found in an outer one.
-
-If flags == FINDLEX_NOSEARCH we don't bother searching outer contexts.
+in the inner pads if it's found in an outer one. innercv is the CV *inside*
+the chain of outer CVs to be searched. If newoff is non-null, this is a
+run-time cloning: don't add fake entries, just find the lexical and add a
+ref to it at newoff in the current pad.
 
-	PADOFFSET	pad_findlex(char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags)
+	PADOFFSET	pad_findlex(char* name, PADOFFSET newoff, CV* innercv)
 
 =for hackers
 Found in file pad.c
@@ -629,9 +647,9 @@ Free the padlist associated with a CV.
 If parts of it happen to be current, we null the relevant
 PL_*pad* global vars so that we don't have any dangling references left.
 We also repoint the CvOUTSIDE of any about-to-be-orphaned
-inner subs to outercv.
+inner subs to the outer of this cv.
 
-	void	pad_undef(CV* cv, CV* outercv)
+	void	pad_undef(CV* cv)
 
 =for hackers
 Found in file pad.c
diff --git a/pp_ctl.c b/pp_ctl.c
index a43e629e2d..76a2466ca5 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2572,6 +2572,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
     char tbuf[TYPE_DIGITS(long) + 12 + 10];
     char *tmpbuf = tbuf;
     char *safestr;
+    int runtime;
+    CV* runcv;
 
     ENTER;
     lex_start(sv);
@@ -2610,12 +2612,21 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
 #endif
     PL_hints &= HINT_UTF8;
 
+    /* we get here either during compilation, or via pp_regcomp at runtime */
+    runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
+    if (runtime)
+	runcv = find_runcv();
+
     PL_op = &dummy;
     PL_op->op_type = OP_ENTEREVAL;
     PL_op->op_flags = 0;			/* Avoid uninit warning. */
     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
     PUSHEVAL(cx, 0, Nullgv);
-    rop = doeval(G_SCALAR, startop);
+
+    if (runtime)
+	rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
+    else
+	rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
     POPBLOCK(cx,PL_curpm);
     POPEVAL(cx);
 
@@ -2633,14 +2644,47 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
     return rop;
 }
 
+
+/*
+=for apidoc find_runcv
+
+Locate the CV corresponding to the currently executing sub or eval.
+
+=cut
+*/
+
+CV*
+Perl_find_runcv(pTHX)
+{
+    I32		 ix;
+    PERL_SI	 *si;
+    PERL_CONTEXT *cx;
+
+    for (si = PL_curstackinfo; si; si = si->si_prev) {
+	for (ix = si->si_cxix; ix >= 0; ix--) {
+	    cx = &(si->si_cxstack[ix]);
+	    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+		return cx->blk_sub.cv;
+	    else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
+		return PL_compcv;
+	}
+    }
+    return PL_main_cv;
+}
+
+
+/* Compile a require/do, an eval '', or a /(?{...})/.
+ * In the last case, startop is non-null, and contains the address of
+ * a pointer that should be set to the just-compiled code.
+ * outside is the lexically enclosing CV (if any) that invoked us.
+ */
+
 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
 STATIC OP *
-S_doeval(pTHX_ int gimme, OP** startop)
+S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 {
     dSP;
     OP *saveop = PL_op;
-    CV *caller;
-    I32 i;
 
     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
 		  ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
@@ -2648,17 +2692,6 @@ S_doeval(pTHX_ int gimme, OP** startop)
 
     PUSHMARK(SP);
 
-    caller = PL_compcv;
-    for (i = cxstack_ix - 1; i >= 0; i--) {
-	PERL_CONTEXT *cx = &cxstack[i];
-	if (CxTYPE(cx) == CXt_EVAL)
-	    break;
-	else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
-	    caller = cx->blk_sub.cv;
-	    break;
-	}
-    }
-
     SAVESPTR(PL_compcv);
     PL_compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
@@ -2666,15 +2699,13 @@ S_doeval(pTHX_ int gimme, OP** startop)
     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
 
+    CvOUTSIDE_SEQ(PL_compcv) = seq;
+    CvOUTSIDE(PL_compcv) = outside ? (CV*)SvREFCNT_inc(outside) : outside;
+
     /* set up a scratch pad */
 
     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
 
-    if (!saveop ||
-	(saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
-    {
-	CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
-    }
 
     SAVEMORTALIZESV(PL_compcv);	/* must remain until end of current statement */
 
@@ -2743,8 +2774,6 @@ S_doeval(pTHX_ int gimme, OP** startop)
     CopLINE_set(&PL_compiling, 0);
     if (startop) {
 	*startop = PL_eval_root;
-	SvREFCNT_dec(CvOUTSIDE(PL_compcv));
-	CvOUTSIDE(PL_compcv) = Nullcv;
     } else
 	SAVEFREEOP(PL_eval_root);
     if (gimme & G_VOID)
@@ -3168,7 +3197,7 @@ PP(pp_require)
     encoding = PL_encoding;
     PL_encoding = Nullsv;
 
-    op = DOCATCH(doeval(gimme, NULL));
+    op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
     
     /* Restore encoding. */
     PL_encoding = encoding;
@@ -3192,6 +3221,7 @@ PP(pp_entereval)
     char *safestr;
     STRLEN len;
     OP *ret;
+    CV* runcv;
 
     if (!SvPV(sv,len))
 	RETPUSHUNDEF;
@@ -3239,6 +3269,7 @@ PP(pp_entereval)
         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
         SAVEFREESV(PL_compiling.cop_io);
     }
+    runcv = find_runcv();
 
     push_return(PL_op->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
@@ -3249,7 +3280,7 @@ PP(pp_entereval)
     if (PERLDB_LINE && PL_curstash != PL_debstash)
 	save_lines(CopFILEAV(&PL_compiling), PL_linestr);
     PUTBACK;
-    ret = doeval(gimme, NULL);
+    ret = doeval(gimme, NULL, runcv, PL_curcop->cop_seq);
     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
 	&& ret != PL_op->op_next) {	/* Successive compilation. */
 	strcpy(safestr, "_<(eval )");	/* Anything fake and short. */
diff --git a/pp_hot.c b/pp_hot.c
index 0b3d6228c3..03855f3671 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2624,8 +2624,8 @@ try_autoload:
 	CvDEPTH(cv)++;
 	/* XXX This would be a natural place to set C<PL_compcv = cv> so
 	 * that eval'' ops within this sub know the correct lexical space.
-	 * Owing the speed considerations, we choose to search for the cv
-	 * in doeval() instead.
+	 * Owing the speed considerations, we choose instead to search for
+	 * the cv using find_runcv() when calling doeval().
 	 */
 	if (CvDEPTH(cv) < 2)
 	    (void)SvREFCNT_inc(cv);
diff --git a/proto.h b/proto.h
index 5a48fd376b..b5ade0278b 100644
--- a/proto.h
+++ b/proto.h
@@ -1112,7 +1112,7 @@ 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_save_lines(pTHX_ AV *array, SV *sv);
-STATIC OP*	S_doeval(pTHX_ int gimme, OP** startop);
+STATIC OP*	S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq);
 STATIC PerlIO *	S_doopen_pmc(pTHX_ const char *name, const char *mode);
 STATIC bool	S_path_is_absolute(pTHX_ char *name);
 #endif
@@ -1360,7 +1360,7 @@ STATIC void	S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I
 #endif
 
 PERL_CALLCONV PADLIST*	Perl_pad_new(pTHX_ padnew_flags flags);
-PERL_CALLCONV void	Perl_pad_undef(pTHX_ CV* cv, CV* outercv);
+PERL_CALLCONV void	Perl_pad_undef(pTHX_ CV* cv);
 PERL_CALLCONV PADOFFSET	Perl_pad_add_name(pTHX_ char *name, HV* typestash, HV* ourstash, bool clone);
 PERL_CALLCONV PADOFFSET	Perl_pad_add_anon(pTHX_ SV* sv, OPCODE op_type);
 PERL_CALLCONV void	Perl_pad_check_dup(pTHX_ char* name, bool is_our, HV* ourstash);
@@ -1375,12 +1375,13 @@ PERL_CALLCONV void	Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv
 PERL_CALLCONV void	Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args);
 
 #if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
-STATIC PADOFFSET	S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval, U32 flags);
+STATIC PADOFFSET	S_pad_findlex(pTHX_ char* name, PADOFFSET newoff, CV* innercv);
 #  if defined(DEBUGGING)
 STATIC void	S_cv_dump(pTHX_ CV *cv, char *title);
 #  endif
 STATIC CV*	S_cv_clone2(pTHX_ CV *proto, CV *outside);
 #endif
+PERL_CALLCONV CV*	Perl_find_runcv(pTHX);
 
 
 
diff --git a/sv.c b/sv.c
index 4d48bc7960..9597a8ac36 100644
--- a/sv.c
+++ b/sv.c
@@ -9602,10 +9602,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
 	  CvDEPTH(dstr) = 0;
 	}
 	PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
+	/* anon prototypes aren't refcounted */
 	if (!CvANON(sstr) || CvCLONED(sstr))
 	    CvOUTSIDE(dstr)	= cv_dup_inc(CvOUTSIDE(sstr), param);
 	else
 	    CvOUTSIDE(dstr)	= cv_dup(CvOUTSIDE(sstr), param);
+	CvOUTSIDE_SEQ(dstr)	= CvOUTSIDE_SEQ(sstr);
 	CvFLAGS(dstr)	= CvFLAGS(sstr);
 	CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
 	break;
diff --git a/sv.h b/sv.h
index a77a193585..393f88f30e 100644
--- a/sv.h
+++ b/sv.h
@@ -318,7 +318,9 @@ struct xpvfm {
     AV *	xcv_padlist;
     CV *	xcv_outside;
     cv_flags_t	xcv_flags;
-
+    U32		xcv_outside_seq; /* the COP sequence (at the point of our
+				  * compilation) in the lexically enclosing
+				  * sub */
     IV		xfm_lines;
 };
 
diff --git a/t/op/eval.t b/t/op/eval.t
index 5897b2bac4..6487b9e8e4 100755
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..46\n";
+print "1..77\n";
 
 eval 'print "ok 1\n";';
 
@@ -118,19 +118,20 @@ EOT
 
 # calls outside eval'' should NOT clone lexicals from called context
 
-$main::x = 'ok';
+$main::ok = 'not ok';
+my $ok = 'ok';
 eval <<'EOT'; die if $@;
   # $x unbound here
   sub do_eval3 {
      eval $_[0]; die if $@;
   }
 EOT
-do_eval3('print "$x ' . $x . '\n"');
-$x++;
-do_eval3('eval q[print "$x ' . $x . '\n"]');
-$x++;
-do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()');
-$x++;
+{
+    my $ok = 'not ok';
+    do_eval3('print "$ok ' . $x++ . '\n"');
+    do_eval3('eval q[print "$ok ' . $x++ . '\n"]');
+    do_eval3('sub { eval q[print "$ok ' . $x++ . '\n"] }->()');
+}
 
 # can recursive subroutine-call inside eval'' see its own lexicals?
 sub recurse {
@@ -241,3 +242,104 @@ print $@;
     eval q{};
     print length($@) ? "not ok 46\t# \$\@ = '$@'\n" : "ok 46\n";
 }
+
+# DAPM Nov-2002. Perl should now capture the full lexical context during
+# evals.
+
+$::zzz = $::zzz = 0;
+my $zzz = 1;
+
+eval q{
+    sub fred1 {
+	eval q{ print eval '$zzz' == 1 ? 'ok' : 'not ok', " $_[0]\n"}
+    }
+    fred1(47);
+    { my $zzz = 2; fred1(48) }
+};
+
+eval q{
+    sub fred2 {
+	print eval('$zzz') == 1 ? 'ok' : 'not ok', " $_[0]\n";
+    }
+};
+fred2(49);
+{ my $zzz = 2; fred2(50) }
+
+# sort() starts a new context stack. Make sure we can still find
+# the lexically enclosing sub
+
+sub do_sort {
+    my $zzz = 2;
+    my @a = sort
+	    { print eval('$zzz') == 2 ? 'ok' : 'not ok', " 51\n"; $a <=> $b }
+	    2, 1;
+}
+do_sort();
+
+# more recursion and lexical scope leak tests
+
+eval q{
+    my $r = -1;
+    my $yyy = 9;
+    sub fred3 {
+	my $l = shift;
+	my $r = -2;
+	return 1 if $l < 1;
+	return 0 if eval '$zzz' != 1;
+	return 0 if       $yyy  != 9;
+	return 0 if eval '$yyy' != 9;
+	return 0 if eval '$l' != $l;
+	return $l * fred3($l-1);
+    }
+    my $r = fred3(5);
+    print $r == 120 ? 'ok' : 'not ok', " 52\n";
+    $r = eval'fred3(5)';
+    print $r == 120 ? 'ok' : 'not ok', " 53\n";
+    $r = 0;
+    eval '$r = fred3(5)';
+    print $r == 120 ? 'ok' : 'not ok', " 54\n";
+    $r = 0;
+    { my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
+    print $r == 120 ? 'ok' : 'not ok', " 55\n";
+};
+my $r = fred3(5);
+print $r == 120 ? 'ok' : 'not ok', " 56\n";
+$r = eval'fred3(5)';
+print $r == 120 ? 'ok' : 'not ok', " 57\n";
+$r = 0;
+eval'$r = fred3(5)';
+print $r == 120 ? 'ok' : 'not ok', " 58\n";
+$r = 0;
+{ my $yyy = 4; my $zzz = 5; my $l = 6; $r = eval 'fred3(5)' };
+print $r == 120 ? 'ok' : 'not ok', " 59\n";
+
+# check that goto &sub within evals doesn't leak lexical scope
+
+my $yyy = 2;
+
+my $test = 60;
+sub fred4 { 
+    my $zzz = 3;
+    print +($zzz == 3  && eval '$zzz' == 3) ? 'ok' : 'not ok', " $test\n";
+    $test++;
+    print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
+    $test++;
+}
+
+eval q{
+    fred4();
+    sub fred5 {
+	my $zzz = 4;
+	print +($zzz == 4  && eval '$zzz' == 4) ? 'ok' : 'not ok', " $test\n";
+	$test++;
+	print eval '$yyy' == 2 ? 'ok' : 'not ok', " $test\n";
+	$test++;
+	goto &fred4;
+    }
+    fred5();
+};
+fred5();
+{ my $yyy = 88; my $zzz = 99; fred5(); }
+eval q{ my $yyy = 888; my $zzz = 999; fred5(); }
+
+
diff --git a/toke.c b/toke.c
index aff4549138..7d73497e79 100644
--- a/toke.c
+++ b/toke.c
@@ -7568,6 +7568,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
     PL_subline = CopLINE(PL_curcop);
     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
+    CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
 
     return oldsavestack_ix;
 }