Two debugging patches.

The first allows to hold symbolic switches in $^D
and more generally fixes assignment to $^D. The
second one improves the information given by -Dl.

Subject: [PATCH] allow $^D = "flags"
Date: Fri, 27 Jun 2003 22:26:24 +0100
Message-ID: <20030627212624.GB12887@fdgroup.com>

Subject: [PATCH] make -Dl show more scope info
From: Dave Mitchell <davem@fdgroup.com>
Date: Fri, 27 Jun 2003 23:00:36 +0100
Message-ID: <20030627220036.GC12887@fdgroup.com>

p4raw-id: //depot/perl@19870

diff --git a/cop.h b/cop.h
index 44305da..04eb7c0 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -334,6 +334,7 @@ struct block {
        PL_retstack_ix   = cx->blk_oldretsp,                            \
        pm               = cx->blk_oldpm,                               \
        gimme            = cx->blk_gimme;                               \
+       DEBUG_SCOPE("POPBLOCK");                                        \
        DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",          \
                    (long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
 
@@ -343,7 +344,8 @@ struct block {
        PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp,            \
        PL_scopestack_ix = cx->blk_oldscopesp,                          \
        PL_retstack_ix   = cx->blk_oldretsp,                            \
-       PL_curpm         = cx->blk_oldpm
+       PL_curpm         = cx->blk_oldpm;                               \
+       DEBUG_SCOPE("TOPBLOCK");
 
 /* substitution context */
 struct subst {

diff --git a/embed.fnc b/embed.fnc
index 15647d0..2aa04ac 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1386,6 +1386,9 @@ sd        |void   |cv_dump        |CV *cv|char *title
 #endif
 pd     |CV*    |find_runcv     |U32 *db_seqp
 p      |void   |free_tied_hv_pool
+#if defined(DEBUGGING)
+p      |int    |get_debug_opts |char **s
+#endif
 
 
 

diff --git a/embed.h b/embed.h
index b89d173..c7dd564 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -2141,6 +2141,11 @@
 #ifdef PERL_CORE
 #define free_tied_hv_pool      Perl_free_tied_hv_pool
 #endif
+#if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define get_debug_opts         Perl_get_debug_opts
+#endif
+#endif
 #define ck_anoncode            Perl_ck_anoncode
 #define ck_bitop               Perl_ck_bitop
 #define ck_concat              Perl_ck_concat
@@ -4618,6 +4623,11 @@
 #ifdef PERL_CORE
 #define free_tied_hv_pool()    Perl_free_tied_hv_pool(aTHX)
 #endif
+#if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define get_debug_opts(a)      Perl_get_debug_opts(aTHX_ a)
+#endif
+#endif
 #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/mg.c b/mg.c
index ba576c3..98ccb34 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1975,8 +1975,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        break;
 
     case '\004':       /* ^D */
-       PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#ifdef DEBUGGING
+       s = SvPV_nolen(sv);
+       PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
        DEBUG_x(dump_all());
+#else
+       PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#endif
        break;
     case '\005':  /* ^E */
        if (*(mg->mg_ptr+1) == '\0') {

diff --git a/perl.c b/perl.c
index d0bf931..bb45684 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2196,6 +2196,40 @@ NULL
        PerlIO_printf(PerlIO_stdout(), "\n  %s", *p++);
 }
 
+/* convert a string of -D options (or digits) into an int.
+ * sets *s to point to the char after the options */
+
+#ifdef DEBUGGING
+int
+Perl_get_debug_opts(pTHX_ char **s)
+{
+    int i = 0;
+    if (isALPHA(**s)) {
+       /* if adding extra options, remember to update DEBUG_MASK */
+       static char debopts[] = "psltocPmfrxu HXDSTRJvC";
+
+       for (; isALNUM(**s); (*s)++) {
+           char *d = strchr(debopts,**s);
+           if (d)
+               i |= 1 << (d - debopts);
+           else if (ckWARN_d(WARN_DEBUGGING))
+               Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+                   "invalid option -D%c\n", **s);
+       }
+    }
+    else {
+       i = atoi(*s);
+       for (; isALNUM(**s); (*s)++) ;
+    }
+#  ifdef EBCDIC
+    if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
+       Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+               "-Dp not implemented on this platform\n");
+#  endif
+    return i;
+}
+#endif
+
 /* This routine handles any switches that can be given during run */
 
 char *
@@ -2295,24 +2329,8 @@ Perl_moreswitches(pTHX_ char *s)
     {  
 #ifdef DEBUGGING
        forbid_setid("-D");
-       if (isALPHA(s[1])) {
-           /* if adding extra options, remember to update DEBUG_MASK */
-           static char debopts[] = "psltocPmfrxu HXDSTRJvC";
-           char *d;
-
-           for (s++; *s && (d = strchr(debopts,*s)); s++)
-               PL_debug |= 1 << (d - debopts);
-       }
-       else {
-           PL_debug = atoi(s+1);
-           for (s++; isDIGIT(*s); s++) ;
-       }
-#ifdef EBCDIC
-       if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
-           Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
-                   "-Dp not implemented on this platform\n");
-#endif
-       PL_debug |= DEBUG_TOP_FLAG;
+       s++;
+       PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
 #else /* !DEBUGGING */
        if (ckWARN_d(WARN_DEBUGGING))
            Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),

diff --git a/perl.h b/perl.h
index ea55630..4a8387b 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2628,6 +2628,13 @@ Gid_t getegid (void);
 #endif /* DEBUGGING */
 
 
+#define DEBUG_SCOPE(where) \
+    DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \
+                   where, PL_scopestack_ix, __FILE__, __LINE__)));
+
+
+
+
 /* These constants should be used in preference to raw characters
  * when using magic. Note that some perl guts still assume
  * certain character properties of these constants, namely that

diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 6e2a853..ad791dd 100644 (file)
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -902,7 +902,8 @@ C<$^C = 1> is similar to calling C<B::minus_c>.
 =item $^D
 
 The current value of the debugging flags.  (Mnemonic: value of B<-D>
-switch.)
+switch.) May be read or set. Like its command-line equivalent, you can use
+numeric or symbolic values, eg C<$^D = 10> or C<$^D = "st">.
 
 =item $SYSTEM_FD_MAX
 

diff --git a/proto.h b/proto.h
index 96e32cb..54882c1 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1326,6 +1326,9 @@ STATIC void       S_cv_dump(pTHX_ CV *cv, char *title);
 #endif
 PERL_CALLCONV CV*      Perl_find_runcv(pTHX_ U32 *db_seqp);
 PERL_CALLCONV void     Perl_free_tied_hv_pool(pTHX);
+#if defined(DEBUGGING)
+PERL_CALLCONV int      Perl_get_debug_opts(pTHX_ char **s);
+#endif
 
 
 

diff --git a/scope.h b/scope.h
index e2150e8..25c7bc5 100644 (file)
--- a/scope.h
+++ b/scope.h
@@ -96,13 +96,11 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 #define ENTER                                                  \
     STMT_START {                                               \
        push_scope();                                           \
-       DEBUG_l(WITH_THR(Perl_deb(aTHX_ "ENTER scope %ld at %s:%d\n",   \
-                   PL_scopestack_ix, __FILE__, __LINE__)));    \
+       DEBUG_SCOPE("ENTER")                                    \
     } STMT_END
 #define LEAVE                                                  \
     STMT_START {                                               \
-       DEBUG_l(WITH_THR(Perl_deb(aTHX_ "LEAVE scope %ld at %s:%d\n",   \
-                   PL_scopestack_ix, __FILE__, __LINE__)));    \
+       DEBUG_SCOPE("LEAVE")                                    \
        pop_scope();                                            \
     } STMT_END
 #else