From 53a2efa2dc68a3abcc2483f05bd06213caea8bbd Mon Sep 17 00:00:00 2001
From: Benjamin Sugars <bsugars@canoe.ca>
Date: Sun, 6 May 2001 08:54:13 -0400
Subject: [PATCH] Help -Dt show correct pad variables Message-ID:
 <Pine.LNX.4.21.0105061142040.12858-100000@localhost.localdomain>

p4raw-id: //depot/perl@10015
---
 embed.h  |  4 ++++
 embed.pl |  1 +
 proto.h  |  1 +
 run.c    | 40 ++++++++++++++++++++++++++++++++++------
 4 files changed, 40 insertions(+), 6 deletions(-)

diff --git a/embed.h b/embed.h
index dd5d658..ff6ffee 100644
--- a/embed.h
+++ b/embed.h
@@ -1053,6 +1053,7 @@
 #define find_byclass		S_find_byclass
 #endif
 #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+#define deb_curcv		S_deb_curcv
 #define debprof			S_debprof
 #endif
 #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
@@ -2539,6 +2540,7 @@
 #define find_byclass(a,b,c,d,e,f)	S_find_byclass(aTHX_ a,b,c,d,e,f)
 #endif
 #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+#define deb_curcv(a)		S_deb_curcv(aTHX_ a)
 #define debprof(a)		S_debprof(aTHX_ a)
 #endif
 #if defined(PERL_IN_SCOPE_C) || defined(PERL_DECL_PROT)
@@ -4945,6 +4947,8 @@
 #define find_byclass		S_find_byclass
 #endif
 #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+#define S_deb_curcv		CPerlObj::S_deb_curcv
+#define deb_curcv		S_deb_curcv
 #define S_debprof		CPerlObj::S_debprof
 #define debprof			S_debprof
 #endif
diff --git a/embed.pl b/embed.pl
index fcaaaed..5d3254d 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2451,6 +2451,7 @@ s	|char*	|find_byclass	|regexp * prog|regnode *c|char *s|char *strend|char *star
 #endif
 
 #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+s	|CV*	|deb_curcv	|I32 ix
 s	|void	|debprof	|OP *o
 #endif
 
diff --git a/proto.h b/proto.h
index cc4050d..c8b5aa6 100644
--- a/proto.h
+++ b/proto.h
@@ -1175,6 +1175,7 @@ STATIC char*	S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, char *stre
 #endif
 
 #if defined(PERL_IN_RUN_C) || defined(PERL_DECL_PROT)
+STATIC CV*	S_deb_curcv(pTHX_ I32 ix);
 STATIC void	S_debprof(pTHX_ OP *o);
 #endif
 
diff --git a/run.c b/run.c
index 1b1e72b..054abfe 100644
--- a/run.c
+++ b/run.c
@@ -63,8 +63,9 @@ I32
 Perl_debop(pTHX_ OP *o)
 {
 #ifdef DEBUGGING
+    AV *padlist, *comppad;
+    CV *cv;
     SV *sv;
-    SV **svp;
     STRLEN n_a;
     Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]);
     switch (o->op_type) {
@@ -86,12 +87,18 @@ Perl_debop(pTHX_ OP *o)
     case OP_PADAV:
     case OP_PADHV:
 	/* print the lexical's name */
-	svp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
-	if (svp)
-	    PerlIO_printf(Perl_debug_log, "(%s)", SvPV(*svp,n_a));
-	else
+        cv = deb_curcv(cxstack_ix);
+        if (cv) {
+            padlist = CvPADLIST(cv);
+            comppad = (AV*)(*av_fetch(padlist, 0, FALSE));
+            sv = *av_fetch(comppad, o->op_targ, FALSE);
+        } else
+            sv = Nullsv;
+        if (sv)
+           PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv));
+        else
            PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
-	break;
+        break;
     default:
 	break;
     }
@@ -100,6 +107,27 @@ Perl_debop(pTHX_ OP *o)
     return 0;
 }
 
+STATIC CV*
+S_deb_curcv(I32 ix)
+{
+#ifdef DEBUGGING
+    PERL_CONTEXT *cx = &cxstack[ix];
+    if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
+        return cx->blk_sub.cv;
+    else if (CxTYPE(cx) == CXt_EVAL && PL_compcv)
+        /* XXX Should be PL_compcv? */
+        return Nullcv;
+    else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN)
+        return PL_main_cv;
+    else if (ix <= 0)
+        return Nullcv;
+    else
+        return deb_curcv(ix - 1);
+#else
+    return Nullcv;
+#endif  /* DEBUGGING */
+}
+
 void
 Perl_watch(pTHX_ char **addr)
 {
-- 
1.8.3.1