# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 0.97;
+$VERSION = 0.98;
$header = "perl5db.pl patch level $VERSION";
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# Changes: 0.97: NonStop will not stop in at_exit().
# Option AutoTrace implemented.
# Trace printed differently if frames are printed too.
+# new `inhibitExit' option.
+# printing of a very long statement interruptible.
+# Changes: 0.98: New command `m' for printing possible methods
+# 'l -' is a synonim for `-'.
+# Cosmetic bugs in printing stack trace.
+# `frame' & 8 to print "expanded args" in stack trace.
+# Can list/break in imported subs.
+# new `maxTraceLen' option.
+# frame & 4 and frame & 8 granted.
+# new command `m'
+# nonstoppable lines do not have `:' near the line number.
+# `b compile subname' implemented.
+# Will not use $` any more.
+# `-' behaves sane now.
####################################################################
@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
compactDump veryCompact quote HighBit undefPrint
globPrint PrintRet UsageOnly frame AutoTrace
- TTY noTTY ReadLine NonStop LineInfo
+ TTY noTTY ReadLine NonStop LineInfo maxTraceLen
recallCommand ShellBang pager tkRunning
signalLevel warnLevel dieLevel inhibit_exit);
frame => \$frame,
AutoTrace => \$trace,
inhibit_exit => \$inhibit_exit,
+ maxTraceLen => \$maxtrace,
);
%optionAction = (
&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager;
&recallCommand("!") unless defined $prc;
&shellBang("!") unless defined $psh;
+$maxtrace = 400 unless defined $maxtrace;
if (-e "/dev/tty") {
$rcfile=".perldb";
print $OUT $#stack . " levels deep in subroutine calls!\n"
if $single & 4;
$start = $line;
+ $incr = -1; # for backward motion.
@typeahead = @$pretype, @typeahead;
CMD:
while (($term || &setterm),
select ($savout);
next CMD; };
$cmd =~ s/^x\b/ / && do { # So that will be evaled
- $onetimeDump = 1; };
+ $onetimeDump = 'dump'; };
+ $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
+ methods($1); next CMD};
+ $cmd =~ s/^m\b/ / && do { # So this will be evaled
+ $onetimeDump = 'methods'; };
$cmd =~ /^f\b\s*(.*)/ && do {
$file = $1;
if (!$file) {
$start = 1;
$cmd = "l";
} };
+ $cmd =~ s/^l\s+-\s*$/-/;
$cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
$subname = $1;
$subname =~ s/\'/::/;
$subname = "main::".$subname unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
- @pieces = split(/:/,$sub{$subname});
+ @pieces = split(/:/,find_sub($subname));
$subrange = pop @pieces;
$file = join(':', @pieces);
if ($file ne $filename) {
next CMD;
} };
$cmd =~ /^\.$/ && do {
+ $incr = -1; # for backward motion.
$start = $line;
$filename = $filename_ini;
*dbline = "::_<$filename";
#print $OUT 'l ' . $start . '-' . ($start + $incr);
$cmd = 'l ' . $start . '-' . ($start + $incr); };
$cmd =~ /^-$/ && do {
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
$incr = $window - 1;
- $cmd = 'l ' . ($start-$window*2) . '+'; };
+ $cmd = 'l ' . ($start) . '+'; };
$cmd =~ /^l$/ && do {
$incr = $window - 1;
$cmd = 'l ' . $start . '-' . ($start + $incr); };
$i = $2;
$i = $line if $i eq '.';
$i = 1 if $i < 1;
+ $incr = $end - $i;
if ($emacs) {
print $OUT "\032\032$filename:$i:0\n";
$i = $end;
$had_breakpoints{$file} = 1;
print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
next CMD; };
- $cmd =~ /^b\b\s*postpone\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
- my $cond = $2 || '1';
- my $subname = $1;
+ $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
+ my $cond = $3 || '1';
+ my ($subname, $break) = ($2, $1 eq 'postpone');
$subname =~ s/\'/::/;
$subname = "${'package'}::" . $subname
unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
- $postponed{$subname} = "break +0 if $cond";
+ $postponed{$subname} = $break
+ ? "break +0 if $cond" : "compile";
next CMD; };
$cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
$subname = $1;
unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
# Filename below can contain ':'
- ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
+ ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
$i += 0;
if ($i) {
$filename = $file;
end_report(), next CMD if $finished and $level <= 1;
$i = $1;
if ($i =~ /\D/) { # subroutine name
- ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
+ ($file,$i) = (find_sub($i) =~ /^(.*):(.*)$/);
$i += 0;
if ($i) {
$filename = $file;
$pat = $inpat;
}
$end = $start;
+ $incr = -1;
eval '
for (;;) {
++$start;
$pat = $inpat;
}
$end = $start;
+ $incr = -1;
eval '
for (;;) {
--$start;
sub sub {
my ($al, $ret, @ret) = "";
- if ($sub =~ /::AUTOLOAD$/) {
- $al = " for $ {$` . '::AUTOLOAD'}";
+ if ($sub =~ /(.*)::AUTOLOAD$/) {
+ $al = " for $ {$1 . '::AUTOLOAD'}";
}
push(@stack, $single);
$single &= 1;
eval "&DB::save";
if ($at) {
print $OUT $at;
- } elsif ($onetimeDump) {
+ } elsif ($onetimeDump eq 'dump') {
dumpit(\@res);
+ } elsif ($onetimeDump eq 'methods') {
+ methods($res[0]);
}
}
sub postponed_sub {
my $subname = shift;
- if ($postponed{$subname} =~ s/break\s([+-]?\d+)\s+if\s//) {
+ if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
my $offset = $1 || 0;
# Filename below can contain ':'
- my ($file,$i) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/);
+ my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
$i += $offset;
if ($i) {
local *dbline = "::_<$file";
}
return;
}
+ elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
#print $OUT "In postponed_sub for `$subname'.\n";
}
my $fh = shift;
my @sub = dump_trace($_[0] + 1, $_[1]);
my $short = $_[2]; # Print short report, next one for sub name
+ my $s;
for ($i=0; $i <= $#sub; $i++) {
last if $signal;
local $" = ', ';
my $args = defined $sub[$i]{args}
? "(@{ $sub[$i]{args} })"
: '' ;
+ $args = (substr $args, 0, $maxtrace - 3) . '...'
+ if length $args > $maxtrace;
my $file = $sub[$i]{file};
$file = $file eq '-e' ? $file : "file `$file'" unless $short;
+ $s = $sub[$i]{sub};
+ $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
if ($short) {
- my $sub = @_ >= 4 ? $_[3] : $sub[$i]{sub};
+ my $sub = @_ >= 4 ? $_[3] : $s;
print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
} else {
- print $fh "$sub[$i]{context} = $sub[$i]{sub}$args" .
+ print $fh "$sub[$i]{context} = $s$args" .
" called from $file" .
" line $sub[$i]{line}\n";
}
$context = $context ? '@' : "\$";
$args = $h ? [@a] : undef;
$e =~ s/\n\s*\;\s*\Z// if $e;
- $e =~ s/[\\\']/\\$1/g if $e;
+ $e =~ s/([\\\'])/\\$1/g if $e;
if ($r) {
$sub = "require '$e'";
} elsif (defined $r) {
b postpone subname [condition]
Set breakpoint at first line of subroutine after
it is compiled.
+b compile subname
+ Stop after the subroutine is compiled.
d [line] Delete the breakpoint for line.
D Delete all breakpoints.
a [line] command
Use ~pattern and !pattern for positive and negative regexps.
X [vars] Same as \"V currentpackage [vars]\".
x expr Evals expression in array context, dumps the result.
+m expr Evals expression in array context, prints methods callable
+ on the first element of the result.
+m class Prints methods callable via the given class.
O [opt[=val]] [opt\"val\"] [opt?]...
Set or query values of options. val defaults to 1. opt can
be abbreviated. Several options can be listed.
Option PrintRet affects printing of return value after r command,
frame affects printing messages on entry and exit from subroutines.
AutoTrace affects printing messages on every possible breaking point.
+ maxTraceLen gives maximal length of evals/args listed in stack trace.
During startup options are initialized from \$ENV{PERLDB_OPTS}.
You can put additional initialization options TTY, noTTY,
ReadLine, and NonStop there.
|[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
q or ^D Quit R Attempt a restart
Data Examination: expr Execute perl code, also see: s,n,t expr
- x expr Evals expression in array context, dumps the result.
+ x|m expr Evals expr in array context, dumps the result or lists methods.
p expr Print expression (uses script's current package).
S [[!]pat] List subroutine names [not] matching pattern
V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
$signalLevel;
}
+sub find_sub {
+ my $subr = shift;
+ return unless defined &$subr;
+ $sub{$subr} or do {
+ $subr = \&$subr; # Hard reference
+ my $s;
+ for (keys %sub) {
+ $s = $_, last if $subr eq \&$_;
+ }
+ $sub{$s} if $s;
+ }
+}
+
+sub methods {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ local %seen;
+ local %packs;
+ methods_via($class, '', 1);
+ methods_via('UNIVERSAL', 'UNIVERSAL', 0);
+}
+
+sub methods_via {
+ my $class = shift;
+ return if $packs{$class}++;
+ my $prefix = shift;
+ my $prepend = $prefix ? "via $prefix: " : '';
+ my $name;
+ for $name (grep {defined &{$ {"$ {class}::"}{$_}}}
+ sort keys %{"$ {class}::"}) {
+ next if $seen{ \&{$ {"$ {class}::"}{$name}} }++;
+ print $DB::OUT "$prepend$name\n";
+ }
+ return unless shift; # Recurse?
+ for $name (@{"$ {class}::ISA"}) {
+ $prepend = $prefix ? $prefix . " -> $name" : $name;
+ methods_via($name, $prepend, 1);
+ }
+}
+
# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
BEGIN { # This does not compile, alas.
}
return @out;
}
- return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines
- if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/;
+ return grep /^\Q$text/, (keys %sub), qw(postpone load compile) # subroutines
+ if (substr $line, 0, $start) =~ /^[bl]\s+((postpone|compile)\s+)?$/;
return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
if (substr $line, 0, $start) =~ /^V\s+$/;
if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space
projects / p5sagit/p5-mst-13.2.git / commitdiff