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

9 files changed, 72 insertions, 25 deletions

diff --git a/cop.h b/cop.h
index 44305da95a..04eb7c0c97 100644
--- 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 15647d0278..2aa04acf12 100644
--- 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 b89d17359a..c7dd564177 100644
--- 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 ba576c3707..98ccb34e3d 100644
--- 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 d0bf93130d..bb45684638 100644
--- 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 ea55630132..4a8387b390 100644
--- 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 6e2a853007..ad791dd71b 100644
--- 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 96e32cbc45..54882c1ebb 100644
--- 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 e2150e87c0..25c7bc5f49 100644
--- 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