From: Richard Foley Date: Wed, 3 Mar 2004 16:10:25 +0000 (+0100) Subject: debugger (5.8.x and 5.9.x) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e219e2fb468c95e644354a070b0529da6fc4a353;p=p5sagit%2Fp5-mst-13.2.git debugger (5.8.x and 5.9.x) Message-Id: <200403031610.25080.richard.foley@rfi.net> p4raw-id: //depot/perl@22426 --- diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 15701b5..99986b8 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 +# + 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 - send current history to a file + +Takes the complete history, (not the shrunken version you see with C), +and saves it to the given filename, so it can be replayed using C. + +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 - 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 I Evals expression in list context, prints methods callable on the first element of the result. B I Prints methods callable via the given class. B Show versions of loaded modules. +B I Prints nested parents of given class. B [I [I]] List lexical variables I levels up from current sub B<<> ? List Perl commands to run before each prompt. @@ -2825,6 +2877,7 @@ B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::O B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " See 'B I' too. B I Execute I containing debugger commands (may nest). +B I Save current debugger session (actual history) to I. B I<-number> Display last number commands (default all). B

I Same as \"I\" in current package. B<|>I Run debugger command, piping DB::OUT to current pager. @@ -2907,7 +2960,7 @@ I B Execute perl code, also see: B,B,B B

I Print expression (uses script's current package). B [[B]I] List subroutine names [not] matching pattern B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. - B [I] Same as \"B I [I]\". + B [I] Same as \"B I [I]\". B I inheritance tree. B [I [I]] List lexicals in higher scope . Vars same as B. For more help, type B I, 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;