From: Chip Salzenberg <chip@pobox.com>
Date: Wed, 26 Aug 2009 20:25:52 +0000 (-0700)
Subject: New debugging flag -DB now dumps subroutine definitions,
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cc8773c013ccdaec9cb8d2c57d85a70c368e102f;p=p5sagit%2Fp5-mst-13.2.git

New debugging flag -DB now dumps subroutine definitions,
 leaving -Dx for its original purpose of dumping syntax trees.
---

diff --git a/op.c b/op.c
index e03997a..1bd3498 100644
--- a/op.c
+++ b/op.c
@@ -5896,7 +5896,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
 	    SAVECOPFILE(&PL_compiling);
 	    SAVECOPLINE(&PL_compiling);
 
-	    DEBUG_x( dump_sub(gv) );
+	    DEBUG_B( dump_sub(gv) );
 	    Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
 	    GvCV(gv) = 0;		/* cv has been hijacked */
 	    call_list(oldscope, PL_beginav);
@@ -5910,7 +5910,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
     } else {
 	if (*name == 'E') {
 	    if strEQ(name, "END") {
-		DEBUG_x( dump_sub(gv) );
+		DEBUG_B( dump_sub(gv) );
 		Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
 	    } else
 		return;
@@ -5941,7 +5941,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
 		return;
 	} else
 	    return;
-	DEBUG_x( dump_sub(gv) );
+	DEBUG_B( dump_sub(gv) );
 	GvCV(gv) = 0;		/* cv has been hijacked */
     }
 }
diff --git a/perl.c b/perl.c
index 6c1b543..7cb8530 100644
--- a/perl.c
+++ b/perl.c
@@ -2864,6 +2864,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  A  Consistency checks on internal structures",
       "  q  quiet - currently only suppresses the 'EXECUTING' message",
       "  M  trace smart match resolution",
+      "  B  dump suBroutine definitions, including special Blocks like BEGIN",
       NULL
     };
     int i = 0;
@@ -2872,7 +2873,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
 
     if (isALPHA(**s)) {
 	/* if adding extra options, remember to update DEBUG_MASK */
-	static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqM";
+	static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
 
 	for (; isALNUM(**s); (*s)++) {
 	    const char * const d = strchr(debopts,**s);
diff --git a/perl.h b/perl.h
index 41f4ab1..5e6f0a8 100644
--- a/perl.h
+++ b/perl.h
@@ -3618,8 +3618,9 @@ Gid_t getegid (void);
 #define DEBUG_C_FLAG		0x00200000 /*2097152 */
 #define DEBUG_A_FLAG		0x00400000 /*4194304 */
 #define DEBUG_q_FLAG		0x00800000 /*8388608 */
-#define DEBUG_M_FLAG		0x01000000 /*8388608 */
-#define DEBUG_MASK		0x01FEEFFF /* mask of all the standard flags */
+#define DEBUG_M_FLAG		0x01000000 /*16777216*/
+#define DEBUG_B_FLAG		0x02000000 /*33554432*/
+#define DEBUG_MASK		0x03FEEFFF /* mask of all the standard flags */
 
 #define DEBUG_DB_RECURSE_FLAG	0x40000000
 #define DEBUG_TOP_FLAG		0x80000000 /* XXX what's this for ??? Signal
@@ -3649,6 +3650,7 @@ Gid_t getegid (void);
 #  define DEBUG_A_TEST_ (PL_debug & DEBUG_A_FLAG)
 #  define DEBUG_q_TEST_ (PL_debug & DEBUG_q_FLAG)
 #  define DEBUG_M_TEST_ (PL_debug & DEBUG_M_FLAG)
+#  define DEBUG_B_TEST_ (PL_debug & DEBUG_B_FLAG)
 #  define DEBUG_Xv_TEST_ (DEBUG_X_TEST_ && DEBUG_v_TEST_)
 #  define DEBUG_Uv_TEST_ (DEBUG_U_TEST_ && DEBUG_v_TEST_)
 
@@ -3678,6 +3680,7 @@ Gid_t getegid (void);
 #  define DEBUG_A_TEST DEBUG_A_TEST_
 #  define DEBUG_q_TEST DEBUG_q_TEST_
 #  define DEBUG_M_TEST DEBUG_M_TEST_
+#  define DEBUG_B_TEST DEBUG_B_TEST_
 #  define DEBUG_Xv_TEST DEBUG_Xv_TEST_
 #  define DEBUG_Uv_TEST DEBUG_Uv_TEST_
 
@@ -3725,6 +3728,7 @@ Gid_t getegid (void);
 #  define DEBUG_A(a) DEBUG__(DEBUG_A_TEST, a)
 #  define DEBUG_q(a) DEBUG__(DEBUG_q_TEST, a)
 #  define DEBUG_M(a) DEBUG__(DEBUG_M_TEST, a)
+#  define DEBUG_B(a) DEBUG__(DEBUG_B_TEST, a)
 
 #else /* DEBUGGING */
 
@@ -3752,6 +3756,7 @@ Gid_t getegid (void);
 #  define DEBUG_A_TEST (0)
 #  define DEBUG_q_TEST (0)
 #  define DEBUG_M_TEST (0)
+#  define DEBUG_B_TEST (0)
 #  define DEBUG_Xv_TEST (0)
 #  define DEBUG_Uv_TEST (0)
 
@@ -3780,6 +3785,7 @@ Gid_t getegid (void);
 #  define DEBUG_A(a)
 #  define DEBUG_q(a)
 #  define DEBUG_M(a)
+#  define DEBUG_B(a)
 #  define DEBUG_Xv(a)
 #  define DEBUG_Uv(a)
 #endif /* DEBUGGING */
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 3d177eb..f18a40a 100644
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -418,6 +418,7 @@ B<-D14> is equivalent to B<-Dtls>):
   4194304  A  Consistency checks on internal structures
   8388608  q  quiet - currently only suppresses the "EXECUTING" message
  16777216  M  trace smart match resolution
+ 33554432  B  dump suBroutine definitions, including special Blocks like BEGIN
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
 executable (but see L<Devel::Peek>, L<re> which may change this).