Debugging OPs

   Message-Id: <20020302054958.A5511@math.ohio-state.edu>
p4raw-link: @14577 on //depot/perl: 0ad5258ff3f3328f321188cbb4fcd6a74b365431

p4raw-id: //depot/perl@14956

7 files changed, 52 insertions, 10 deletions

diff --git a/deb.c b/deb.c
index fae944cf07..6a5a21c202 100644
--- a/deb.c
+++ b/deb.c
@@ -81,11 +81,14 @@ Perl_debstackptrs(pTHX)
 I32
 Perl_debstack(pTHX)
 {
-#ifdef DEBUGGING
+#ifndef SKIP_DEBUGGING
     I32 top = PL_stack_sp - PL_stack_base;
     register I32 i = top - 30;
     I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff;
 
+    if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+	return 0;
+
     if (i < 0)
 	i = 0;
     
@@ -118,6 +121,6 @@ Perl_debstack(pTHX)
     }
     while (1);
     PerlIO_printf(Perl_debug_log, "\n");
-#endif /* DEBUGGING */
+#endif /* SKIP_DEBUGGING */
     return 0;
 }
diff --git a/dump.c b/dump.c
index 0a360242de..9b2ff67307 100644
--- a/dump.c
+++ b/dump.c
@@ -1402,6 +1402,10 @@ Perl_debop(pTHX_ OP *o)
     CV *cv;
     SV *sv;
     STRLEN n_a;
+
+    if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+	return 0;
+
     Perl_deb(aTHX_ "%s", OP_NAME(o));
     switch (o->op_type) {
     case OP_CONST:
@@ -1435,7 +1439,7 @@ Perl_debop(pTHX_ OP *o)
            PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
         break;
     default:
-	break;
+	return 0;
     }
     PerlIO_printf(Perl_debug_log, "\n");
     return 0;
@@ -1469,6 +1473,8 @@ Perl_watch(pTHX_ char **addr)
 STATIC void
 S_debprof(pTHX_ OP *o)
 {
+    if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
+	return;
     if (!PL_profiledata)
 	Newz(000, PL_profiledata, MAXO, U32);
     ++PL_profiledata[o->op_type];
diff --git a/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm
index ecc44b7ca0..3b4b845be5 100644
--- a/ext/Devel/Peek/Peek.pm
+++ b/ext/Devel/Peek/Peek.pm
@@ -17,6 +17,26 @@ use XSLoader ();
 
 XSLoader::load 'Devel::Peek';
 
+sub import {
+  my $c = shift;
+  my $ops_rx = qr/^:opd(=[stP]*)?\b/;
+  my @db = grep m/$ops_rx/, @_;
+  @_ = grep !m/$ops_rx/, @_;
+  if (@db) {
+    die "Too many :opd options" if @db > 1;
+    runops_debug(1);
+    my $flags = ($db[0] =~ m/$ops_rx/ and $1);
+    $flags = 'st' unless defined $flags;
+    my $f = 0;
+    $f |= 2  if $flags =~ /s/;
+    $f |= 8  if $flags =~ /t/;
+    $f |= 64 if $flags =~ /P/;
+    $^D |= $f if $f;
+  }
+  unshift @_, $c;
+  goto &Exporter::import;
+}
+
 sub DumpWithOP ($;$) {
    local($Devel::Peek::dump_ops)=1;
    my $depth = @_ > 1 ? $_[1] : 4 ;
@@ -58,6 +78,8 @@ Devel::Peek - A data debugging tool for the XS programmer
         DumpArray( 5, $a, $b, ... );
 	mstat "Point 5";
 
+        use Devel::Peek ':opd=st';
+
 =head1 DESCRIPTION
 
 Devel::Peek contains functions which allows raw Perl datatypes to be
@@ -88,6 +110,11 @@ The global variable $Devel::Peek::pv_limit can be set to limit the
 number of character printed in various string values.  Setting it to 0
 means no limit.
 
+If C<use Devel::Peek> directive has a C<:opd=FLAGS> argument,
+this switches on debugging of opcode dispatch.  C<FLAGS> should be a
+combination of C<s>, C<t>, and C<P> (see B<-D> flags in L<perlrun>).
+C<:opd> is a shortcut for C<:opd=st>.
+
 =head2 Runtime debugging
 
 C<CvGV($cv)> return one of the globs associated to a subroutine reference $cv.
diff --git a/perl.c b/perl.c
index 91a3ddaf68..a2921fb1e4 100644
--- a/perl.c
+++ b/perl.c
@@ -2257,7 +2257,7 @@ Perl_moreswitches(pTHX_ char *s)
 	forbid_setid("-D");
 	if (isALPHA(s[1])) {
 	    /* if adding extra options, remember to update DEBUG_MASK */
-	    static char debopts[] = "psltocPmfrxuLHXDSTR";
+	    static char debopts[] = "psltocPmfrxuLHXDSTRJ";
 	    char *d;
 
 	    for (s++; *s && (d = strchr(debopts,*s)); s++)
diff --git a/perl.h b/perl.h
index 2fffc93b5b..61d17fde63 100644
--- a/perl.h
+++ b/perl.h
@@ -2358,11 +2358,12 @@ Gid_t getegid (void);
 #define DEBUG_S_FLAG		0x00010000 /*  65536 */
 #define DEBUG_T_FLAG		0x00020000 /* 131072 */
 #define DEBUG_R_FLAG		0x00040000 /* 262144 */
-#define DEBUG_MASK		0x0007FFFF /* mask of all the standard flags */
+#define DEBUG_J_FLAG		0x00080000 /* 524288 */
+#define DEBUG_MASK		0x000FFFFF /* mask of all the standard flags */
 
 #define DEBUG_DB_RECURSE_FLAG	0x40000000
-#define DEBUG_TOP_FLAG		0x80000000 /* XXX what's this for ??? */
-
+#define DEBUG_TOP_FLAG		0x80000000 /* XXX what's this for ??? Signal
+					      that something was done? */
 
 #  define DEBUG_p_TEST_ (PL_debug & DEBUG_p_FLAG)
 #  define DEBUG_s_TEST_ (PL_debug & DEBUG_s_FLAG)
@@ -2383,6 +2384,7 @@ Gid_t getegid (void);
 #  define DEBUG_S_TEST_ (PL_debug & DEBUG_S_FLAG)
 #  define DEBUG_T_TEST_ (PL_debug & DEBUG_T_FLAG)
 #  define DEBUG_R_TEST_ (PL_debug & DEBUG_R_FLAG)
+#  define DEBUG_J_TEST_ (PL_debug & DEBUG_J_FLAG)
 
 #ifdef DEBUGGING
 
@@ -2408,6 +2410,7 @@ Gid_t getegid (void);
 #  define DEBUG_S_TEST DEBUG_S_TEST_
 #  define DEBUG_T_TEST DEBUG_T_TEST_
 #  define DEBUG_R_TEST DEBUG_R_TEST_
+#  define DEBUG_J_TEST DEBUG_J_TEST_
 
 #  define DEB(a)     a
 #  define DEBUG(a)   if (PL_debug)   a
@@ -2470,6 +2473,7 @@ Gid_t getegid (void);
 #  define DEBUG_S_TEST (0)
 #  define DEBUG_T_TEST (0)
 #  define DEBUG_R_TEST (0)
+#  define DEBUG_J_TEST (0)
 
 #  define DEB(a)
 #  define DEBUG(a)
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 0a709bdcee..9bbb8d9386 100644
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -313,7 +313,7 @@ B<-D14> is equivalent to B<-Dtls>):
         8  t  Trace execution
        16  o  Method and overloading resolution
        32  c  String/numeric conversions
-       64  P  Print preprocessor command for -P, source file input state
+       64  P  Print profiling info, preprocessor command for -P, source file input state
       128  m  Memory allocation
       256  f  Format processing
       512  r  Regular expression parsing and execution
@@ -326,9 +326,11 @@ B<-D14> is equivalent to B<-Dtls>):
     65536  S  Thread synchronization
    131072  T  Tokenising
    262144  R  Include reference counts of dumped variables (eg when using -Ds)
+   524288  J  Do not s,t,P-debug (Jump over) opcodes within package DB
 
 All these flags require B<-DDEBUGGING> when you compile the Perl
-executable.  See the F<INSTALL> file in the Perl source distribution 
+executable (but see L<Devel::Peek>, L<re> which may change this).
+See the F<INSTALL> file in the Perl source distribution 
 for how to do this.  This flag is automatically set if you include B<-g>
 option when C<Configure> asks you about optimizer/debugger flags.
 
diff --git a/sv.h b/sv.h
index d925421b20..8fd4ae7b69 100644
--- a/sv.h
+++ b/sv.h
@@ -1229,7 +1229,7 @@ Returns a pointer to the character buffer.
 #define SvSetMagicSV_nosteal(dst,src) \
 		SvSetSV_nosteal_and(dst,src,SvSETMAGIC(dst))
 
-#ifdef DEBUGGING
+#if !defined(SKIP_DEBUGGING)
 #define SvPEEK(sv) sv_peek(sv)
 #else
 #define SvPEEK(sv) ""