From: Dave Mitchell Date: Fri, 27 Jun 2003 22:26:24 +0000 (+0100) Subject: Two debugging patches. X-Git-Tag: perl-5.9.0~1113 X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/b4ab917c3d812d8e61d365bfa48d9bf7675bc113?ds=sidebyside 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 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -902,7 +902,8 @@ C<$^C = 1> is similar to calling 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 --- 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 --- a/scope.h +++ b/scope.h @@ -96,13 +96,11 @@ Closing bracket on a callback. See C and L. #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