debugger (5.8.x and 5.9.x)

Message-Id: <200403031610.25080.richard.foley@rfi.net>

p4raw-id: //depot/perl@22426

1 files changed, 61 insertions, 7 deletions

diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 15701b5a4b..99986b8d8d 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -3,7 +3,7 @@ package DB;
 use IO::Handle;
 
 # Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.21_01;
+$VERSION = 1.21_02;
 $header  = "perl5db.pl version $VERSION";
 
 # It is crucial that there is no lexicals in scope of `eval ""' down below
@@ -326,7 +326,10 @@ sub eval {
 #   + watch val joined out of eval()
 # Changes: 1.21: Dec 21, 2003 Dominique Quatravaux
 #   + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug")
-# 
+# Changes: 1.24: Mar 03, 2004 Richard Foley <richard.foley@rfi.net>
+#   + Added command to save all debugger commands for sourcing later.
+#   + Added command to display parent inheritence tree of given class.
+#   + Fixed minor newline in history bug.
 ####################################################################
 
 # Needed for the statement after exec():
@@ -718,7 +721,7 @@ sub DB {
       for (my $n = 0; $n <= $#to_watch; $n++) {
 		$evalarg = $to_watch[$n];
 		local $onetimeDump;	# Do not output results
-		my ($val) = join("', '", &eval);	# Fix context (&eval is doing array)? - rjsf
+		my ($val) = join("', '", &eval);	# Fix context (&eval is doing array)
 		$val = ( (defined $val) ? "'$val'" : 'undef' );
 		if ($val ne $old_watch[$n]) {
 		  $signal = 1;
@@ -807,7 +810,9 @@ EOP
 		    redo CMD;
 		};
 		$cmd =~ /^$/ && ($cmd = $laststep);
+		chomp($cmd); # get rid of the annoying extra newline
 		push(@hist,$cmd) if length($cmd) > 1;
+        push (@truehist, $cmd);
 	      PIPE: {
 		    $cmd =~ s/^\s+//s;   # trim annoying leading whitespace
 		    $cmd =~ s/\s+$//s;   # trim annoying trailing whitespace
@@ -921,12 +926,10 @@ EOP
 			$start = 1 if $start <= 0;
 			$incr = $window - 1;
 			$cmd = 'l ' . ($start) . '+'; };
-			# rjsf     ->
-		  $cmd =~ /^([aAbBhlLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do { 
+		  $cmd =~ /^([aAbBhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do { 
 				&cmd_wrapper($1, $2, $line); 
 				next CMD; 
 			};
-			# rjsf <- pre|post commands stripped out
                    $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
                        eval { require PadWalker; PadWalker->VERSION(0.08) }
                          or &warn($@ =~ /locate/
@@ -1236,6 +1239,30 @@ EOP
 			&warn("Can't execute `$1': $!\n");
 		      }
 		      next CMD; };
+
+=head4 C<save> - send current history to a file
+
+Takes the complete history, (not the shrunken version you see with C<H>),
+and saves it to the given filename, so it can be replayed using C<source>.
+
+Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
+
+=cut
+
+				# save source - write commands to a file for later use
+                $cmd =~ /^save\s*(.*)$/ && do {
+					my $file = $1 || '.perl5dbrc'; # default?
+                    if (open my $fh, "> $file") {
+						# chomp to remove extraneous newlines from source'd files 
+						chomp(my @truelist = map { m/^\s*(save|source)/ ? "#$_": $_ } @truehist);
+						print $fh join("\n", @truelist); 
+						print "commands saved in $file\n";
+                    } else {
+                        &warn("Can't save debugger commands in '$1': $!\n");
+                    }
+                    next CMD;
+                };
+
 		    $cmd =~ /^\|\|?\s*[^|]/ && do {
 			if ($pager =~ /^\|/) {
 			    open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
@@ -1733,6 +1760,30 @@ sub cmd_h {
 	}
 }
 
+=head3 C<cmd_i> - inheritance display
+
+Display the (nested) parentage of the module or object given.
+
+=cut
+
+sub cmd_i {
+    my $cmd  = shift;
+    my $line = shift;
+	eval { require Class::ISA };
+	if ($@) { 
+		&warn($@ =~ /locate/ ? "Class::ISA module not found - please install\n" : $@);
+	} else {
+		ISA:
+		foreach my $isa (split(/\s+/, $line)) {
+		  no strict 'refs'; 
+		  print join(', ', map { # snaffled unceremoniously from Class::ISA
+				"$_".(defined(${"$_\::VERSION"}) ? ' '.${"$_\::VERSION"} : undef)
+			  } Class::ISA::self_and_super_path($isa));
+		  print "\n";
+		}
+	}
+} ## end sub cmd_i
+
 sub cmd_l {
 	my $current_line = $line;
 	my $cmd    = shift; # l
@@ -2802,6 +2853,7 @@ B<m> I<expr>		Evals expression in list context, prints methods callable
 		on the first element of the result.
 B<m> I<class>		Prints methods callable via the given class.
 B<M>		Show versions of loaded modules.
+B<i> I<class>       Prints nested parents of given class.
 B<y> [I<n> [I<vars>]]	List lexical variables I<n> levels up from current sub
 
 B<<> ?			List Perl commands to run before each prompt.
@@ -2825,6 +2877,7 @@ B<$psh$psh> I<cmd>  	Run cmd in a subprocess (reads from DB::IN, writes to DB::O
 B<$psh> [I<cmd>] 	Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
 		See 'B<O> I<shellBang>' too.
 B<source> I<file>		Execute I<file> containing debugger commands (may nest).
+B<save> I<file>       Save current debugger session (actual history) to I<file>.
 B<H> I<-number>	Display last number commands (default all).
 B<p> I<expr>		Same as \"I<print {DB::OUT} expr>\" in current package.
 B<|>I<dbcmd>		Run debugger command, piping DB::OUT to current pager.
@@ -2907,7 +2960,7 @@ I<Data Examination:>     B<expr>     Execute perl code, also see: B<s>,B<n>,B<t>
   B<p> I<expr>         Print expression (uses script's current package).
   B<S> [[B<!>]I<pat>]     List subroutine names [not] matching pattern
   B<V> [I<Pk> [I<Vars>]]  List Variables in Package.  Vars can be ~pattern or !pattern.
-  B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".
+  B<X> [I<Vars>]       Same as \"B<V> I<current_package> [I<Vars>]\".  B<i> I<class> inheritance tree.
   B<y> [I<n> [I<Vars>]]   List lexicals in higher scope <n>.  Vars same as B<V>.
 For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
 END_SUM
@@ -3399,6 +3452,7 @@ BEGIN {			# This does not compile, alas.
   $sh = '!';
   $rc = ',';
   @hist = ('?');
+  @truehist=();           # Can be saved for replay (per session)
   $deep = 100;			# warning if stack gets this deep
   $window = 10;
   $preview = 3;