Change 19870 by [EMAIL PROTECTED] on 2003/06/28 15:39:57
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"
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Fri, 27 Jun 2003 22:26:24 +0100
Message-ID: <[EMAIL PROTECTED]>
Subject: [PATCH] make -Dl show more scope info
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Fri, 27 Jun 2003 23:00:36 +0100
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/cop.h#77 edit
... //depot/perl/embed.fnc#91 edit
... //depot/perl/embed.h#407 edit
... //depot/perl/mg.c#267 edit
... //depot/perl/perl.c#494 edit
... //depot/perl/perl.h#517 edit
... //depot/perl/pod/perlvar.pod#121 edit
... //depot/perl/proto.h#448 edit
... //depot/perl/scope.h#59 edit
Differences ...
==== //depot/perl/cop.h#77 (text) ====
Index: perl/cop.h
--- perl/cop.h#76~19242~ Wed Apr 16 13:14:01 2003
+++ perl/cop.h Sat Jun 28 08:39:57 2003
@@ -334,6 +334,7 @@
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 @@
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 {
==== //depot/perl/embed.fnc#91 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#90~19863~ Fri Jun 27 01:15:11 2003
+++ perl/embed.fnc Sat Jun 28 08:39:57 2003
@@ -1386,6 +1386,9 @@
#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
==== //depot/perl/embed.h#407 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#406~19862~ Fri Jun 27 00:39:58 2003
+++ perl/embed.h Sat Jun 28 08:39:57 2003
@@ -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
@@ -4617,6 +4622,11 @@
#endif
#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)
==== //depot/perl/mg.c#267 (text) ====
Index: perl/mg.c
--- perl/mg.c#266~19769~ Fri Jun 13 12:17:50 2003
+++ perl/mg.c Sat Jun 28 08:39:57 2003
@@ -1975,8 +1975,13 @@
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') {
==== //depot/perl/perl.c#494 (text) ====
Index: perl/perl.c
--- perl/perl.c#493~19865~ Fri Jun 27 01:40:45 2003
+++ perl/perl.c Sat Jun 28 08:39:57 2003
@@ -2196,6 +2196,40 @@
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 @@
{
#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),
==== //depot/perl/perl.h#517 (text) ====
Index: perl/perl.h
--- perl/perl.h#516~19864~ Fri Jun 27 01:18:47 2003
+++ perl/perl.h Sat Jun 28 08:39:57 2003
@@ -2628,6 +2628,13 @@
#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
==== //depot/perl/pod/perlvar.pod#121 (text) ====
Index: perl/pod/perlvar.pod
--- perl/pod/perlvar.pod#120~19769~ Fri Jun 13 12:17:50 2003
+++ perl/pod/perlvar.pod Sat Jun 28 08:39:57 2003
@@ -902,7 +902,8 @@
=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
==== //depot/perl/proto.h#448 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#447~19863~ Fri Jun 27 01:15:11 2003
+++ perl/proto.h Sat Jun 28 08:39:57 2003
@@ -1326,6 +1326,9 @@
#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
==== //depot/perl/scope.h#59 (text) ====
Index: perl/scope.h
--- perl/scope.h#58~19431~ Mon May 5 13:07:33 2003
+++ perl/scope.h Sat Jun 28 08:39:57 2003
@@ -96,13 +96,11 @@
#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
End of Patch.
