From: Gurusamy Sarathy <gsar@cpan.org>
Date: Tue, 13 Oct 1998 03:15:50 +0000 (+0000)
Subject: change#1614 merely disabled earlier fix (doh!); undo it and properly
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6b35e00972a13cc3d5e641e82fd498a9d9f6a324;p=p5sagit%2Fp5-mst-13.2.git

change#1614 merely disabled earlier fix (doh!); undo it and properly
fixup the cop_seq value that must be seen by lexical lookups that
emanate within eval''

p4raw-link: @1614 on //depot/perl: bd28dd3ca083953e5682058b02b9529902e14ca9

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

diff --git a/cop.h b/cop.h
index f15b1e1..98ae91f 100644
--- a/cop.h
+++ b/cop.h
@@ -199,7 +199,7 @@ struct block {
 	pm		 = cx->blk_oldpm,				\
 	gimme		 = cx->blk_gimme;				\
 	DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Leaving block %ld, type %s\n",		\
-		    (long)cxstack_ix+1,block_type[cx->cx_type]); )
+		    (long)cxstack_ix+1,block_type[CxTYPE(cx)]); )
 
 /* Continue a block elsewhere (NEXT and REDO). */
 #define TOPBLOCK(cx) cx  = &cxstack[cxstack_ix],			\
@@ -262,12 +262,14 @@ struct subst {
 	rxres_free(&cx->sb_rxres)
 
 struct context {
-    I32		cx_type;	/* what kind of context this is */
+    U32		cx_type;	/* what kind of context this is */
     union {
 	struct block	cx_blk;
 	struct subst	cx_subst;
     } cx_u;
 };
+
+#define CXTYPEMASK	0xff
 #define CXt_NULL	0
 #define CXt_SUB		1
 #define CXt_EVAL	2
@@ -275,6 +277,12 @@ struct context {
 #define CXt_SUBST	4
 #define CXt_BLOCK	5
 
+/* private flags for CXt_EVAL */
+#define CXp_REAL	0x00000100	/* truly eval'', not a lookalike */
+
+#define CxTYPE(c)	((c)->cx_type & CXTYPEMASK)
+#define CxREALEVAL(c)	(((c)->cx_type & (CXt_EVAL|CXp_REAL)) == (CXt_EVAL|CXp_REAL))
+
 #define CXINC (cxstack_ix < cxstack_max ? ++cxstack_ix : (cxstack_ix = cxinc()))
 
 /* "gimme" values */
diff --git a/op.c b/op.c
index b2d6f77..d673fad 100644
--- a/op.c
+++ b/op.c
@@ -230,14 +230,18 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
 			    CV *bcv;
 			    for (bcv = startcv;
 				 bcv && bcv != cv && !CvCLONE(bcv);
-				 bcv = CvOUTSIDE(bcv)) {
+				 bcv = CvOUTSIDE(bcv))
+			    {
 				if (CvANON(bcv))
 				    CvCLONE_on(bcv);
 				else {
-				    if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv))
+				    if (ckWARN(WARN_CLOSURE)
+					&& !CvUNIQUE(bcv) && !CvUNIQUE(cv))
+				    {
 					warner(WARN_CLOSURE,
 					  "Variable \"%s\" may be unavailable",
 					     name);
+				    }
 				    break;
 				}
 			    }
@@ -262,7 +266,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
 
     for (i = cx_ix; i >= 0; i--) {
 	cx = &cxstack[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	default:
 	    if (i == 0 && saweval) {
 		seq = cxstack[saweval].blk_oldcop->cop_seq;
@@ -272,7 +276,8 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
 	case CXt_EVAL:
 	    switch (cx->blk_eval.old_op_type) {
 	    case OP_ENTEREVAL:
-		saweval = i;
+		if (CxREALEVAL(cx))
+		    saweval = i;
 		break;
 	    case OP_REQUIRE:
 		/* require must have its own scope */
@@ -304,6 +309,7 @@ pad_findmy(char *name)
     SV *sv;
     SV **svp = AvARRAY(PL_comppad_name);
     U32 seq = PL_cop_seqmax;
+    PERL_CONTEXT *cx;
 
 #ifdef USE_THREADS
     /*
@@ -333,6 +339,14 @@ pad_findmy(char *name)
 	}
     }
 
+    /* Check if if we're in an eval'', and adjust seq to be the eval's
+     * seq number */
+    if (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, CvOUTSIDE(PL_compcv), cxstack_ix, 0);
     if (off) {
diff --git a/pp_ctl.c b/pp_ctl.c
index b566738..332b24c 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -977,7 +977,7 @@ dopoptolabel(char *label)
 
     for (i = cxstack_ix; i >= 0; i--) {
 	cx = &cxstack[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting substitution via %s", 
@@ -1058,7 +1058,7 @@ dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
 	cx = &cxstk[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	default:
 	    continue;
 	case CXt_EVAL:
@@ -1078,7 +1078,7 @@ dopoptoeval(I32 startingblock)
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
 	cx = &cxstack[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	default:
 	    continue;
 	case CXt_EVAL:
@@ -1097,7 +1097,7 @@ dopoptoloop(I32 startingblock)
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
 	cx = &cxstack[i];
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	    if (ckWARN(WARN_UNSAFE))
 		warner(WARN_UNSAFE, "Exiting substitution via %s", 
@@ -1137,9 +1137,9 @@ dounwind(I32 cxix)
     while (cxstack_ix > cxix) {
 	cx = &cxstack[cxstack_ix];
 	DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
-			      (long) cxstack_ix, block_type[cx->cx_type]));
+			      (long) cxstack_ix, block_type[CxTYPE(cx)]));
 	/* Note: we don't need to restore the base context info till the end. */
-	switch (cx->cx_type) {
+	switch (CxTYPE(cx)) {
 	case CXt_SUBST:
 	    POPSUBST(cx);
 	    continue;  /* not break */
@@ -1208,7 +1208,7 @@ die_where(char *message)
 		dounwind(cxix);
 
 	    POPBLOCK(cx,PL_curpm);
-	    if (cx->cx_type != CXt_EVAL) {
+	    if (CxTYPE(cx) != CXt_EVAL) {
 		PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
 		my_exit(1);
 	    }
@@ -1298,7 +1298,7 @@ PP(pp_caller)
     }
 
     cx = &ccstack[cxix];
-    if (ccstack[cxix].cx_type == CXt_SUB) {
+    if (CxTYPE(cx) == CXt_SUB) {
         dbcxix = dopoptosub_at(ccstack, cxix - 1);
 	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
 	   field below is defined for any cx. */
@@ -1327,7 +1327,7 @@ PP(pp_caller)
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
     if (!MAXARG)
 	RETURN;
-    if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
+    if (CxTYPE(cx) == CXt_SUB) { /* So is ccstack[dbcxix]. */
 	sv = NEWSV(49, 0);
 	gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
 	PUSHs(sv_2mortal(sv));
@@ -1342,7 +1342,7 @@ PP(pp_caller)
 	PUSHs(&PL_sv_undef);
     else
 	PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
-    if (cx->cx_type == CXt_EVAL) {
+    if (CxTYPE(cx) == CXt_EVAL) {
 	if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
 	    PUSHs(cx->blk_eval.cur_text);
 	    PUSHs(&PL_sv_no);
@@ -1353,7 +1353,7 @@ PP(pp_caller)
 	    PUSHs(&PL_sv_yes);
 	}
     }
-    else if (cx->cx_type == CXt_SUB &&
+    else if (CxTYPE(cx) == CXt_SUB &&
 	    cx->blk_sub.hasargs &&
 	    PL_curcop->cop_stash == PL_debstash)
     {
@@ -1610,7 +1610,7 @@ PP(pp_return)
 	dounwind(cxix);
 
     POPBLOCK(cx,newpm);
-    switch (cx->cx_type) {
+    switch (CxTYPE(cx)) {
     case CXt_SUB:
 	POPSUB1(cx);	/* Delay POPSUB2 until stack values are safe */
 	popsub2 = TRUE;
@@ -1698,7 +1698,7 @@ PP(pp_last)
 	dounwind(cxix);
 
     POPBLOCK(cx,newpm);
-    switch (cx->cx_type) {
+    switch (CxTYPE(cx)) {
     case CXt_LOOP:
 	POPLOOP1(cx);	/* Delay POPLOOP2 until stack values are safe */
 	pop2 = CXt_LOOP;
@@ -1901,10 +1901,10 @@ PP(pp_goto)
 	    if (cxix < cxstack_ix)
 		dounwind(cxix);
 	    TOPBLOCK(cx);
-	    if (cx->cx_type == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
+	    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL) 
 		DIE("Can't goto subroutine from an eval-string");
 	    mark = PL_stack_sp;
-	    if (cx->cx_type == CXt_SUB &&
+	    if (CxTYPE(cx) == CXt_SUB &&
 		cx->blk_sub.hasargs) {   /* put @_ back onto stack */
 		AV* av = cx->blk_sub.argarray;
 		
@@ -1934,7 +1934,7 @@ PP(pp_goto)
 		Copy(AvARRAY(av), PL_stack_sp, items, SV*);
 		PL_stack_sp += items;
 	    }
-	    if (cx->cx_type == CXt_SUB &&
+	    if (CxTYPE(cx) == CXt_SUB &&
 		!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
 		SvREFCNT_dec(cx->blk_sub.cv);
 	    oldsave = PL_scopestack[PL_scopestack_ix - 1];
@@ -1973,7 +1973,7 @@ PP(pp_goto)
 	    else {
 		AV* padlist = CvPADLIST(cv);
 		SV** svp = AvARRAY(padlist);
-		if (cx->cx_type == CXt_EVAL) {
+		if (CxTYPE(cx) == CXt_EVAL) {
 		    PL_in_eval = cx->blk_eval.old_in_eval;
 		    PL_eval_root = cx->blk_eval.old_eval_root;
 		    cx->cx_type = CXt_SUB;
@@ -2123,7 +2123,7 @@ PP(pp_goto)
 	*enterops = 0;
 	for (ix = cxstack_ix; ix >= 0; ix--) {
 	    cx = &cxstack[ix];
-	    switch (cx->cx_type) {
+	    switch (CxTYPE(cx)) {
 	    case CXt_EVAL:
 		gotoprobe = PL_eval_root; /* XXX not good for nested eval */
 		break;
@@ -2422,11 +2422,11 @@ doeval(int gimme, OP** startop)
     SAVEI32(PL_max_intro_pending);
 
     caller = PL_compcv;
-    for (i = cxstack_ix; i >= 0; i--) {
+    for (i = cxstack_ix - 1; i >= 0; i--) {
 	PERL_CONTEXT *cx = &cxstack[i];
-	if (cx->cx_type == CXt_EVAL)
+	if (CxTYPE(cx) == CXt_EVAL)
 	    break;
-	else if (cx->cx_type == CXt_SUB) {
+	else if (CxTYPE(cx) == CXt_SUB) {
 	    caller = cx->blk_sub.cv;
 	    break;
 	}
@@ -2772,7 +2772,7 @@ PP(pp_entereval)
     }
 
     push_return(PL_op->op_next);
-    PUSHBLOCK(cx, CXt_EVAL, SP);
+    PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
     PUSHEVAL(cx, 0, PL_compiling.cop_filegv);
 
     /* prepare to compile string */
diff --git a/pp_hot.c b/pp_hot.c
index 701f462..f513c12 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1465,7 +1465,7 @@ PP(pp_iter)
 
     EXTEND(SP, 1);
     cx = &cxstack[cxstack_ix];
-    if (cx->cx_type != CXt_LOOP)
+    if (CxTYPE(cx) != CXt_LOOP)
 	DIE("panic: pp_iter");
 
     av = cx->blk_loop.iterary;
@@ -2273,6 +2273,11 @@ PP(pp_entersub)
 	PUSHBLOCK(cx, CXt_SUB, MARK);
 	PUSHSUB(cx);
 	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.
+	 */
 	if (CvDEPTH(cv) < 2)
 	    (void)SvREFCNT_inc(cv);
 	else {	/* save temporaries on recursion? */
diff --git a/scope.c b/scope.c
index b603641..eb43648 100644
--- a/scope.c
+++ b/scope.c
@@ -841,8 +841,8 @@ cx_dump(PERL_CONTEXT *cx)
 {
 #ifdef DEBUGGING
     dTHR;
-    PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]);
-    if (cx->cx_type != CXt_SUBST) {
+    PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[CxTYPE(cx)]);
+    if (CxTYPE(cx) != CXt_SUBST) {
 	PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
 	PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
 	PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
@@ -851,7 +851,7 @@ cx_dump(PERL_CONTEXT *cx)
 	PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
 	PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
     }
-    switch (cx->cx_type) {
+    switch (CxTYPE(cx)) {
     case CXt_NULL:
     case CXt_BLOCK:
 	break;
diff --git a/t/op/eval.t b/t/op/eval.t
index efa189e..5a9c198 100755
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -100,3 +100,20 @@ do_eval('eval q[print "ok $x\n"]');
 $x++;
 do_eval('sub { eval q[print "ok $x\n"] }->()');
 $x++;
+
+# can recursive subroutine-call inside eval'' see its own lexicals?
+sub recurse {
+  my $l = shift;
+  if ($l < $x) {
+     ++$l;
+     eval 'print "# level $l\n"; recurse($l);';
+     die if $@;
+  }
+  else {
+    print "ok $l\n";
+  }
+}
+{
+  local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ };
+  recurse($x-5);
+}