Help -Dt show correct pad variables

Message-ID: <Pine.LNX.4.21.0105061142040.12858-100000@localhost.localdomain>

p4raw-id: //depot/perl@10015

diff --git a/embed.h b/embed.h
index dd5d658..ff6ffee 100644 (file)
--- 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 (executable)
--- 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 (file)
--- 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 (file)
--- 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)
 {