fix longstanding bug: searches for lexicals originating within eval''

       weren't stopping at the subroutine boundary correctly
(back-formation from change 3037)

p4raw-id: //depot/maint-5.004/perl@3228

2 files changed, 62 insertions, 12 deletions

diff --git a/op.c b/op.c
index 969f244cd8..215b12c3ab 100644
--- a/op.c
+++ b/op.c
@@ -35,6 +35,8 @@
 #define CHECKOP(type,o) (*check[type])(o)
 #endif /* USE_OP_MASK */
 
+#define FINDLEX_NOSEARCH	1	/* don't search outer contexts */
+
 static I32 list_assignment _((OP *o));
 static void bad_type _((I32 n, char *t, char *name, OP *kid));
 static OP *modkids _((OP *o, I32 type));
@@ -45,7 +47,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, I32 saweval));
+	CV* startcv, I32 cx_ix, I32 saweval, I32 flags));
 static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
 
 static char*
@@ -169,15 +171,17 @@ char *name;
 
 static PADOFFSET
 #ifndef CAN_PROTOTYPE
-pad_findlex(name, newoff, seq, startcv, cx_ix, saweval)
+pad_findlex(name, newoff, seq, startcv, cx_ix, saweval, flags)
 char *name;
 PADOFFSET newoff;
 U32 seq;
 CV* startcv;
 I32 cx_ix;
 I32 saweval;
+I32 flags;
 #else
-pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval)
+pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix,
+	    I32 saweval, I32 flags)
 #endif
 {
     dTHR;
@@ -266,6 +270,9 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
 	}
     }
 
+    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.
@@ -277,7 +284,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
 	default:
 	    if (i == 0 && saweval) {
 		seq = cxstack[saweval].blk_oldcop->cop_seq;
-		return pad_findlex(name, newoff, seq, main_cv, -1, saweval);
+		return pad_findlex(name, newoff, seq, main_cv, -1, saweval, 0);
 	    }
 	    break;
 	case CXt_EVAL:
@@ -300,7 +307,8 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
 		continue;
 	    }
 	    seq = cxstack[saweval].blk_oldcop->cop_seq;
-	    return pad_findlex(name, newoff, seq, cv, i-1, saweval);
+	    return pad_findlex(name, newoff, seq, cv, i-1, saweval,
+			       FINDLEX_NOSEARCH);
 	}
     }
 
@@ -348,7 +356,7 @@ char *name;
     }
 
     /* See if it's in a nested scope */
-    off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0);
+    off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
     if (off) {
 	/* If there is a pending local definition, this new alias must die */
 	if (pendoff)
@@ -3256,7 +3264,7 @@ 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, 0);
+				      CvOUTSIDE(cv), cxstack_ix, 0, 0);
 		if (!off)
 		    curpad[ix] = SvREFCNT_inc(ppad[ix]);
 		else if (off != ix)
diff --git a/t/op/eval.t b/t/op/eval.t
index 498c63aaf3..dc163e9e8f 100755
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..29\n";
+print "1..36\n";
 
 eval 'print "ok 1\n";';
 
@@ -90,15 +90,46 @@ my $X = sub {
 
 my $x = 25;
 eval <<'EOT'; die if $@;
-  sub do_eval {
+  print "# $x\n";	# clone into eval's pad
+  sub do_eval1 {
      eval $_[0]; die if $@;
   }
 EOT
-do_eval('print "ok $x\n"');
+do_eval1('print "ok $x\n"');
 $x++;
-do_eval('eval q[print "ok $x\n"]');
+do_eval1('eval q[print "ok $x\n"]');
 $x++;
-do_eval('sub { eval q[print "ok $x\n"] }->()');
+do_eval1('sub { eval q[print "ok $x\n"] }->()');
+$x++;
+
+# calls from within eval'' should clone outer lexicals
+
+eval <<'EOT'; die if $@;
+  sub do_eval2 {
+     eval $_[0]; die if $@;
+  }
+do_eval2('print "ok $x\n"');
+$x++;
+do_eval2('eval q[print "ok $x\n"]');
+$x++;
+do_eval2('sub { eval q[print "ok $x\n"] }->()');
+$x++;
+EOT
+
+# calls outside eval'' should NOT clone lexicals from called context
+
+$main::x = '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++;
 
 # can recursive subroutine-call inside eval'' see its own lexicals?
@@ -129,3 +160,14 @@ eval <<'EOT';
   }
 EOT
 create_closure("ok $x\n")->();
+$x++;
+
+# does lexical search terminate correctly at subroutine boundary?
+$main::r = "ok $x\n";
+sub terminal { eval 'print $r' }
+{
+   my $r = "not ok $x\n";
+   eval 'terminal($r)';
+}
+$x++;
+