From: Gurusamy Sarathy <gsar@cpan.org>
Date: Tue, 13 Oct 1998 02:06:09 +0000 (+0000)
Subject: ensure recursive attempts to findlex()icals know enough about where
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=155fc61f8f24f48a8180aab9a504f33842272586;p=p5sagit%2Fp5-mst-13.2.git

ensure recursive attempts to findlex()icals know enough about where
the last eval'' context was encountered

p4raw-id: //depot/perl@1943
---

diff --git a/op.c b/op.c
index cc79dfe..b2d6f77 100644
--- a/op.c
+++ b/op.c
@@ -48,7 +48,7 @@ static OP *too_few_arguments _((OP *o, char* name));
 static OP *too_many_arguments _((OP *o, char* name));
 static void null _((OP* o));
 static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
-	CV* startcv, I32 cx_ix));
+	CV* startcv, I32 cx_ix, I32 saweval));
 static OP *newDEFSVOP _((void));
 static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
 #endif
@@ -170,7 +170,7 @@ pad_allocmy(char *name)
 }
 
 STATIC PADOFFSET
-pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
+pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval)
 {
     dTHR;
     CV *cv;
@@ -178,7 +178,6 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
     SV *sv;
     register I32 i;
     register PERL_CONTEXT *cx;
-    int saweval;
 
     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
 	AV *curlist = CvPADLIST(cv);
@@ -261,14 +260,13 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
      * XXX This will also probably interact badly with eval tree caching.
      */
 
-    saweval = 0;
     for (i = cx_ix; i >= 0; i--) {
 	cx = &cxstack[i];
 	switch (cx->cx_type) {
 	default:
 	    if (i == 0 && saweval) {
 		seq = cxstack[saweval].blk_oldcop->cop_seq;
-		return pad_findlex(name, newoff, seq, PL_main_cv, 0);
+		return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval);
 	    }
 	    break;
 	case CXt_EVAL:
@@ -290,7 +288,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 		continue;
 	    }
 	    seq = cxstack[saweval].blk_oldcop->cop_seq;
-	    return pad_findlex(name, newoff, seq, cv, i-1);
+	    return pad_findlex(name, newoff, seq, cv, i-1, saweval);
 	}
     }
 
@@ -336,7 +334,7 @@ pad_findmy(char *name)
     }
 
     /* See if it's in a nested scope */
-    off = pad_findlex(name, 0, seq, CvOUTSIDE(PL_compcv), cxstack_ix);
+    off = pad_findlex(name, 0, seq, CvOUTSIDE(PL_compcv), cxstack_ix, 0);
     if (off) {
 	/* If there is a pending local definition, this new alias must die */
 	if (pendoff)
@@ -3588,7 +3586,7 @@ cv_clone2(CV *proto, CV *outside)
 	    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);
+				      CvOUTSIDE(cv), cxstack_ix, 0);
 		if (!off)
 		    PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
 		else if (off != ix)
diff --git a/t/op/eval.t b/t/op/eval.t
index 9368281..efa189e 100755
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -1,8 +1,6 @@
 #!./perl
 
-# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $
-
-print "1..23\n";
+print "1..27\n";
 
 eval 'print "ok 1\n";';
 
@@ -79,3 +77,26 @@ eval {
   };
   &$x();
 }
+
+my $b = 'wrong';
+my $X = sub {
+   my $b = "right";
+   print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n";
+};
+&$X();
+
+
+# check navigation of multiple eval boundaries to find lexicals
+
+my $x = 25;
+eval <<'EOT'; die if $@;
+  sub do_eval {
+     eval $_[0]; die if $@;
+  }
+EOT
+do_eval('print "ok $x\n"');
+$x++;
+do_eval('eval q[print "ok $x\n"]');
+$x++;
+do_eval('sub { eval q[print "ok $x\n"] }->()');
+$x++;