Re: [perl #19017] lexical "my" variables not visible in debugger "x" command

Date: Thu, 12 Dec 2002 23:42:35 +0000
Message-ID: <20021212234235.A29245@fdgroup.com>
and
Date: Sat, 14 Dec 2002 19:16:38 +0000
Message-ID: <20021214191638.A3992@fdgroup.com>

p4raw-id: //depot/perl@18307

7 files changed, 65 insertions, 11 deletions

diff --git a/embed.fnc b/embed.fnc
index 5c56027e13..ace2ade0c9 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1353,7 +1353,7 @@ sd	|void	|cv_dump	|CV *cv|char *title
 #  endif
 s	|CV*	|cv_clone2	|CV *proto|CV *outside
 #endif
-pd 	|CV*	|find_runcv
+pd 	|CV*	|find_runcv	|U32 *db_seqp
 
 
 
diff --git a/embed.h b/embed.h
index 828746e33b..636dca9181 100644
--- a/embed.h
+++ b/embed.h
@@ -2760,7 +2760,7 @@
 #  endif
 #define cv_clone2(a,b)		S_cv_clone2(aTHX_ a,b)
 #endif
-#define find_runcv()		Perl_find_runcv(aTHX)
+#define find_runcv(a)		Perl_find_runcv(aTHX_ a)
 #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/pod/perlfunc.pod b/pod/perlfunc.pod
index 8a745efdce..2496f83ae2 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -1449,6 +1449,11 @@ in case 6.
 C<eval BLOCK> does I<not> count as a loop, so the loop control statements
 C<next>, C<last>, or C<redo> cannot be used to leave or restart the block.
 
+Note that as a very special case, an C<eval ''> executed within the C<DB>
+package doesn't see the usual surrounding lexical scope, but rather the
+scope of the first non-DB piece of code that called it. You don't normally
+need to worry about this unless you are writing a Perl debugger.
+
 =item exec LIST
 
 =item exec PROGRAM LIST
diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index c2e246a8d9..0d0b19d1b0 100644
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -285,8 +285,12 @@ Found in file pad.h
 =item find_runcv
 
 Locate the CV corresponding to the currently executing sub or eval.
+If db_seqp is non_null, skip CVs that are in the DB package and populate
+*db_seqp with the cop sequence number at the point that the DB:: code was
+entered. (allows debuggers to eval in the scope of the breakpoint rather
+than in in the scope of the debuger itself).
 
-	CV*	find_runcv()
+	CV*	find_runcv(U32 *db_seqp)
 
 =for hackers
 Found in file pp_ctl.c
diff --git a/pp_ctl.c b/pp_ctl.c
index 143888d99a..623b1ce78e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2615,7 +2615,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
     /* 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();
+	runcv = find_runcv(NULL);
 
     PL_op = &dummy;
     PL_op->op_type = OP_ENTEREVAL;
@@ -2649,22 +2649,35 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
 =for apidoc find_runcv
 
 Locate the CV corresponding to the currently executing sub or eval.
+If db_seqp is non_null, skip CVs that are in the DB package and populate
+*db_seqp with the cop sequence number at the point that the DB:: code was
+entered. (allows debuggers to eval in the scope of the breakpoint rather
+than in in the scope of the debuger itself).
 
 =cut
 */
 
 CV*
-Perl_find_runcv(pTHX)
+Perl_find_runcv(pTHX_ U32 *db_seqp)
 {
     I32		 ix;
     PERL_SI	 *si;
     PERL_CONTEXT *cx;
 
+    if (db_seqp)
+	*db_seqp = PL_curcop->cop_seq;
     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;
+	    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+		CV *cv = cx->blk_sub.cv;
+		/* skip DB:: code */
+		if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
+		    *db_seqp = cx->blk_oldcop->cop_seq;
+		    continue;
+		}
+		return cv;
+	    }
 	    else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
 		return PL_compcv;
 	}
@@ -3222,6 +3235,7 @@ PP(pp_entereval)
     STRLEN len;
     OP *ret;
     CV* runcv;
+    U32 seq;
 
     if (!SvPV(sv,len))
 	RETPUSHUNDEF;
@@ -3269,7 +3283,12 @@ PP(pp_entereval)
         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
         SAVEFREESV(PL_compiling.cop_io);
     }
-    runcv = find_runcv();
+    /* special case: an eval '' executed within the DB package gets lexically
+     * placed in the first non-DB CV rather than the current CV - this
+     * allows the debugger to execute code, find lexicals etc, in the
+     * scope of the code being debugged. Passing &seq gets find_runcv
+     * to do the dirty work for us */
+    runcv = find_runcv(&seq);
 
     push_return(PL_op->op_next);
     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
@@ -3280,7 +3299,7 @@ PP(pp_entereval)
     if (PERLDB_LINE && PL_curstash != PL_debstash)
 	save_lines(CopFILEAV(&PL_compiling), PL_linestr);
     PUTBACK;
-    ret = doeval(gimme, NULL, runcv, PL_curcop->cop_seq);
+    ret = doeval(gimme, NULL, runcv, 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/proto.h b/proto.h
index b5ade0278b..fca42edacb 100644
--- a/proto.h
+++ b/proto.h
@@ -1381,7 +1381,7 @@ 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);
+PERL_CALLCONV CV*	Perl_find_runcv(pTHX_ U32 *db_seqp);
 
 
 
diff --git a/t/op/eval.t b/t/op/eval.t
index 41c5ef3c48..e81b9f76a5 100755
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..78\n";
+print "1..84\n";
 
 eval 'print "ok 1\n";';
 
@@ -349,3 +349,29 @@ eval q{ my $yyy = 888; my $zzz = 999; fred5(); };
    print "ok 78\n";
 }
 
+# evals that appear in the DB package should see the lexical scope of the
+# thing outside DB that called them (usually the debugged code), rather
+# than the usual surrounding scope
+
+$test=79;
+our $x = 1;
+{
+    my $x=2;
+    sub db1	{ $x; eval '$x' }
+    sub DB::db2	{ $x; eval '$x' }
+    package DB;
+    sub db3	{ eval '$x' }
+    sub DB::db4	{ eval '$x' }
+    sub db5	{ my $x=4; eval '$x' }
+    package main;
+    sub db6	{ my $x=4; eval '$x' }
+}
+{
+    my $x = 3;
+    print db1()     == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
+    print DB::db2() == 2 ? 'ok' : 'not ok', " $test\n"; $test++;
+    print DB::db3() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
+    print DB::db4() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
+    print DB::db5() == 3 ? 'ok' : 'not ok', " $test\n"; $test++;
+    print db6()     == 4 ? 'ok' : 'not ok', " $test\n"; $test++;
+}