From: Chip Salzenberg <chip@pobox.com>
Date: Sun, 30 Aug 2009 22:13:26 +0000 (-0700)
Subject: finish implementing -DB vs. -Dx
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f0e3f042f14b;p=p5sagit%2Fp5-mst-13.2.git

finish implementing -DB vs. -Dx
---

diff --git a/dump.c b/dump.c
index c891b2f..b5c5da7 100644
--- a/dump.c
+++ b/dump.c
@@ -92,16 +92,29 @@ Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args)
 void
 Perl_dump_all(pTHX)
 {
+    dump_all_perl(aTHX_ FALSE);
+}
+
+void
+Perl_dump_all_perl(pTHX_ bool justperl)
+{
+
     dVAR;
     PerlIO_setlinebuf(Perl_debug_log);
     if (PL_main_root)
 	op_dump(PL_main_root);
-    dump_packsubs(PL_defstash);
+    dump_packsubs_perl(PL_defstash, justperl);
 }
 
 void
 Perl_dump_packsubs(pTHX_ const HV *stash)
 {
+    dump_packsubs_perl(stash, FALSE);
+}
+
+void
+Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl)
+{
     dVAR;
     I32	i;
 
@@ -116,13 +129,13 @@ Perl_dump_packsubs(pTHX_ const HV *stash)
 	    if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
 		continue;
 	    if (GvCVu(gv))
-		dump_sub(gv);
+		dump_sub_perl(gv, justperl);
 	    if (GvFORM(gv))
 		dump_form(gv);
 	    if (HeKEY(entry)[HeKLEN(entry)-1] == ':') {
 		const HV * const hv = GvHV(gv);
 		if (hv && (hv != PL_defstash))
-		    dump_packsubs(hv);		/* nested package */
+		    dump_packsubs_perl(hv, justperl); /* nested package */
 	    }
 	}
     }
@@ -131,10 +144,20 @@ Perl_dump_packsubs(pTHX_ const HV *stash)
 void
 Perl_dump_sub(pTHX_ const GV *gv)
 {
-    SV * const sv = sv_newmortal();
+    dump_sub_perl(gv, FALSE);
+}
+
+void
+Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
+{
+    SV * sv;
 
     PERL_ARGS_ASSERT_DUMP_SUB;
 
+    if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+	return;
+
+    sv = sv_newmortal();
     gv_fullname3(sv, gv, NULL);
     Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv));
     if (CvISXSUB(GvCV(gv)))
@@ -2190,9 +2213,16 @@ Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *ar
 void
 Perl_xmldump_all(pTHX)
 {
+    xmldump_all_perl(FALSE);
+}
+
+void
+Perl_xmldump_all_perl(pTHX_ bool justperl)
+{
     PerlIO_setlinebuf(PL_xmlfp);
     if (PL_main_root)
 	op_xmldump(PL_main_root);
+    xmldump_packsubs_perl(PL_defstash, justperl)
     if (PL_xmlfp != (PerlIO*)PerlIO_stdout())
 	PerlIO_close(PL_xmlfp);
     PL_xmlfp = 0;
@@ -2228,10 +2258,20 @@ Perl_xmldump_packsubs(pTHX_ const HV *stash)
 void
 Perl_xmldump_sub(pTHX_ const GV *gv)
 {
-    SV * const sv = sv_newmortal();
+    xmldump_sub_perl(gv, FALSE);
+}
+
+void
+Perl_xmldump_sub_perl(pTHX_ const GV *gv, bool justperl)
+{
+    SV * sv;
 
     PERL_ARGS_ASSERT_XMLDUMP_SUB;
 
+    if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+	return;
+
+    sv = sv_newmortal();
     gv_fullname3(sv, gv, NULL);
     Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv));
     if (CvXSUB(GvCV(gv)))
diff --git a/embed.fnc b/embed.fnc
index 74cc604..9591a8c 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -304,6 +304,7 @@ p	|void	|do_vop		|I32 optype|NN SV* sv|NN SV* left|NN SV* right
 p	|OP*	|dofile		|NN OP* term|I32 force_builtin
 ApR	|I32	|dowantarray
 Ap	|void	|dump_all
+p	|void	|dump_all_perl	|bool justperl
 Ap	|void	|dump_eval
 #if defined(DUMP_FDS)
 Ap	|void	|dump_fds	|NN char* s
@@ -313,7 +314,9 @@ Ap	|void	|gv_dump	|NN GV* gv
 Ap	|void	|op_dump	|NN const OP *o
 Ap	|void	|pmop_dump	|NULLOK PMOP* pm
 Ap	|void	|dump_packsubs	|NN const HV* stash
+p	|void	|dump_packsubs_perl	|NN const HV* stash|bool justperl
 Ap	|void	|dump_sub	|NN const GV* gv
+p	|void	|dump_sub_perl	|NN const GV* gv|bool justperl
 Apd	|void	|fbm_compile	|NN SV* sv|U32 flags
 ApdR	|char*	|fbm_instr	|NN unsigned char* big|NN unsigned char* bigend \
 				|NN SV* littlestr|U32 flags
@@ -2133,8 +2136,11 @@ Mfp	|void	|xmldump_indent	|I32 level|NN PerlIO *file|NN const char* pat \
 Mp	|void	|xmldump_vindent|I32 level|NN PerlIO *file|NN const char* pat \
 				|NULLOK va_list *args
 Mp	|void	|xmldump_all
+p	|void	|xmldump_all_perl	|bool justperl
 Mp	|void	|xmldump_packsubs	|NN const HV* stash
+p	|void	|xmldump_packsubs_perl	|NN const HV* stash|bool justperl
 Mp	|void	|xmldump_sub	|NN const GV* gv
+M	|void	|xmldump_sub_perl	|NN const GV* gv|bool justperl
 Mp	|void	|xmldump_form	|NN const GV* gv
 Mp	|void	|xmldump_eval
 Mp	|char*	|sv_catxmlsv	|NN SV *dsv|NN SV *ssv
diff --git a/embed.h b/embed.h
index fa2561f..817c291 100644
--- a/embed.h
+++ b/embed.h
@@ -232,6 +232,9 @@
 #endif
 #define dowantarray		Perl_dowantarray
 #define dump_all		Perl_dump_all
+#ifdef PERL_CORE
+#define dump_all_perl		Perl_dump_all_perl
+#endif
 #define dump_eval		Perl_dump_eval
 #if defined(DUMP_FDS)
 #define dump_fds		Perl_dump_fds
@@ -241,7 +244,13 @@
 #define op_dump			Perl_op_dump
 #define pmop_dump		Perl_pmop_dump
 #define dump_packsubs		Perl_dump_packsubs
+#ifdef PERL_CORE
+#define dump_packsubs_perl	Perl_dump_packsubs_perl
+#endif
 #define dump_sub		Perl_dump_sub
+#ifdef PERL_CORE
+#define dump_sub_perl		Perl_dump_sub_perl
+#endif
 #define fbm_compile		Perl_fbm_compile
 #define fbm_instr		Perl_fbm_instr
 #ifdef PERL_CORE
@@ -1907,8 +1916,12 @@
 #define xmldump_indent		Perl_xmldump_indent
 #define xmldump_vindent		Perl_xmldump_vindent
 #define xmldump_all		Perl_xmldump_all
+#define xmldump_all_perl	Perl_xmldump_all_perl
 #define xmldump_packsubs	Perl_xmldump_packsubs
+#define xmldump_packsubs_perl	Perl_xmldump_packsubs_perl
 #define xmldump_sub		Perl_xmldump_sub
+#endif
+#ifdef PERL_CORE
 #define xmldump_form		Perl_xmldump_form
 #define xmldump_eval		Perl_xmldump_eval
 #define sv_catxmlsv		Perl_sv_catxmlsv
@@ -2560,6 +2573,9 @@
 #endif
 #define dowantarray()		Perl_dowantarray(aTHX)
 #define dump_all()		Perl_dump_all(aTHX)
+#ifdef PERL_CORE
+#define dump_all_perl(a)	Perl_dump_all_perl(aTHX_ a)
+#endif
 #define dump_eval()		Perl_dump_eval(aTHX)
 #if defined(DUMP_FDS)
 #define dump_fds(a)		Perl_dump_fds(aTHX_ a)
@@ -2569,7 +2585,13 @@
 #define op_dump(a)		Perl_op_dump(aTHX_ a)
 #define pmop_dump(a)		Perl_pmop_dump(aTHX_ a)
 #define dump_packsubs(a)	Perl_dump_packsubs(aTHX_ a)
+#ifdef PERL_CORE
+#define dump_packsubs_perl(a,b)	Perl_dump_packsubs_perl(aTHX_ a,b)
+#endif
 #define dump_sub(a)		Perl_dump_sub(aTHX_ a)
+#ifdef PERL_CORE
+#define dump_sub_perl(a,b)	Perl_dump_sub_perl(aTHX_ a,b)
+#endif
 #define fbm_compile(a,b)	Perl_fbm_compile(aTHX_ a,b)
 #define fbm_instr(a,b,c,d)	Perl_fbm_instr(aTHX_ a,b,c,d)
 #ifdef PERL_CORE
@@ -4256,8 +4278,11 @@
 #ifdef PERL_CORE
 #define xmldump_vindent(a,b,c,d)	Perl_xmldump_vindent(aTHX_ a,b,c,d)
 #define xmldump_all()		Perl_xmldump_all(aTHX)
+#define xmldump_all_perl(a)	Perl_xmldump_all_perl(aTHX_ a)
 #define xmldump_packsubs(a)	Perl_xmldump_packsubs(aTHX_ a)
+#define xmldump_packsubs_perl(a,b)	Perl_xmldump_packsubs_perl(aTHX_ a,b)
 #define xmldump_sub(a)		Perl_xmldump_sub(aTHX_ a)
+#define xmldump_sub_perl(a,b)	_ a,b)
 #define xmldump_form(a)		Perl_xmldump_form(aTHX_ a)
 #define xmldump_eval()		Perl_xmldump_eval(aTHX)
 #define sv_catxmlsv(a,b)	Perl_sv_catxmlsv(aTHX_ a,b)
diff --git a/mg.c b/mg.c
index c15119f..15ae6ce 100644
--- a/mg.c
+++ b/mg.c
@@ -2334,7 +2334,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 #ifdef DEBUGGING
 	s = SvPV_nolen_const(sv);
 	PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
-	DEBUG_x(dump_all());
+	DEBUG_B(dump_all());
 #else
 	PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
 #endif
diff --git a/perl.c b/perl.c
index 7cb8530..126de99 100644
--- a/perl.c
+++ b/perl.c
@@ -2253,8 +2253,9 @@ S_run_body(pTHX_ I32 oldscope)
 	    exit(0);	/* less likely to core dump than my_exit(0) */
 	}
 #endif
-	DEBUG_x(dump_all());
 #ifdef DEBUGGING
+	if (DEBUG_x_TEST || DEBUG_B_TEST)
+	    dump_all_perl(!DEBUG_B_TEST);
 	if (!DEBUG_q_TEST)
 	  PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
 #endif
diff --git a/proto.h b/proto.h
index 9734b14..724a347 100644
--- a/proto.h
+++ b/proto.h
@@ -739,6 +739,7 @@ PERL_CALLCONV I32	Perl_dowantarray(pTHX)
 			__attribute__warn_unused_result__;
 
 PERL_CALLCONV void	Perl_dump_all(pTHX);
+PERL_CALLCONV void	Perl_dump_all_perl(pTHX_ bool justperl);
 PERL_CALLCONV void	Perl_dump_eval(pTHX);
 #if defined(DUMP_FDS)
 PERL_CALLCONV void	Perl_dump_fds(pTHX_ char* s)
@@ -768,11 +769,21 @@ PERL_CALLCONV void	Perl_dump_packsubs(pTHX_ const HV* stash)
 #define PERL_ARGS_ASSERT_DUMP_PACKSUBS	\
 	assert(stash)
 
+PERL_CALLCONV void	Perl_dump_packsubs_perl(pTHX_ const HV* stash, bool justperl)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL	\
+	assert(stash)
+
 PERL_CALLCONV void	Perl_dump_sub(pTHX_ const GV* gv)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_DUMP_SUB	\
 	assert(gv)
 
+PERL_CALLCONV void	Perl_dump_sub_perl(pTHX_ const GV* gv, bool justperl)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_DUMP_SUB_PERL	\
+	assert(gv)
+
 PERL_CALLCONV void	Perl_fbm_compile(pTHX_ SV* sv, U32 flags)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_FBM_COMPILE	\
@@ -6444,16 +6455,27 @@ PERL_CALLCONV void	Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const cha
 	assert(file); assert(pat)
 
 PERL_CALLCONV void	Perl_xmldump_all(pTHX);
+PERL_CALLCONV void	Perl_xmldump_all_perl(pTHX_ bool justperl);
 PERL_CALLCONV void	Perl_xmldump_packsubs(pTHX_ const HV* stash)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS	\
 	assert(stash)
 
+PERL_CALLCONV void	Perl_xmldump_packsubs_perl(pTHX_ const HV* stash, bool justperl)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS_PERL	\
+	assert(stash)
+
 PERL_CALLCONV void	Perl_xmldump_sub(pTHX_ const GV* gv)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_XMLDUMP_SUB	\
 	assert(gv)
 
+PERL_CALLCONV void	xmldump_sub_perl(pTHX_ const GV* gv, bool justperl)
+			__attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_XMLDUMP_SUB_PERL	\
+	assert(gv)
+
 PERL_CALLCONV void	Perl_xmldump_form(pTHX_ const GV* gv)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_XMLDUMP_FORM	\