# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 0.96;
-$header = "perl5db.pl patch level $VERSION";
+$VERSION = 1.02;
+$header = "perl5db.pl version $VERSION";
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
#
-# Perl supplies the values for @line and %sub. It effectively inserts
-# a &DB'DB(<linenum>); in front of every place that can have a
+# Perl supplies the values for %sub. It effectively inserts
+# a &DB'DB(); in front of every place that can have a
# breakpoint. Instead of a subroutine call it calls &DB::sub with
# $DB::sub being the called subroutine. It also inserts a BEGIN
# {require 'perl5db.pl'} before the first line.
#
# After each `require'd file is compiled, but before it is executed, a
-# call to DB::postponed(*{"_<$filename"}) is emulated. Here the
+# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
# $filename is the expanded name of the `require'd file (as found as
# value of %INC).
#
# if caller() is called from the package DB, it provides some
# additional data.
#
-# The array @{"_<$filename"} is the line-by-line contents of
+# The array @{$main::{'_<'.$filename} is the line-by-line contents of
# $filename.
#
-# The hash %{"_<$filename"} contains breakpoints and action (it is
+# The hash %{'_<'.$filename} contains breakpoints and action (it is
# keyed by line number), and individual entries are settable (as
# opposed to the whole hash). Only true/false is important to the
# interpreter, though the values used by perl5db.pl have the form
# "$break_condition\0$action". Values are magical in numeric context.
#
-# The scalar ${"_<$filename"} contains "_<$filename".
+# The scalar ${'_<'.$filename} contains "_<$filename".
#
# Note that no subroutine call is possible until &DB::sub is defined
-# (for subroutines defined outside this file). In fact the same is
+# (for subroutines defined outside of the package DB). In fact the same is
# true if $deep is not defined.
#
# $Log: perldb.pl,v $
# When restarting debugger breakpoints/actions persist.
# Buglet: When restarting debugger only one breakpoint/action per
# autoloaded function persists.
+# 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.
+# Changes: 0.99: Completion for `f', `m'.
+# `m' will remove duplicate names instead of duplicate functions.
+# `b load' strips trailing whitespace.
+# completion ignores leading `|'; takes into account current package
+# when completing a subroutine name (same for `l').
####################################################################
$dumpvar::quoteHighBit,
$dumpvar::printUndef,
$dumpvar::globPrint,
- $readline::Tk_toloop,
$dumpvar::usageOnly,
@ARGS,
$Carp::CarpLevel,
$panic,
- $first_time,
+ $second_time,
) if 0;
# Command-line + PERLLIB:
# (local $^W cannot help - other packages!).
$inhibit_exit = $option{PrintRet} = 1;
-@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
+@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages DumpReused
compactDump veryCompact quote HighBit undefPrint
- globPrint PrintRet UsageOnly frame
- TTY noTTY ReadLine NonStop LineInfo
- recallCommand ShellBang pager tkRunning
- signalLevel warnLevel dieLevel);
+ globPrint PrintRet UsageOnly frame AutoTrace
+ TTY noTTY ReadLine NonStop LineInfo maxTraceLen
+ recallCommand ShellBang pager tkRunning ornaments
+ signalLevel warnLevel dieLevel inhibit_exit
+ ImmediateStop);
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
arrayDepth => \$dumpvar::arrayDepth,
DumpDBFiles => \$dumpvar::dumpDBFiles,
DumpPackages => \$dumpvar::dumpPackages,
+ DumpReused => \$dumpvar::dumpReused,
HighBit => \$dumpvar::quoteHighBit,
undefPrint => \$dumpvar::printUndef,
globPrint => \$dumpvar::globPrint,
- tkRunning => \$readline::Tk_toloop,
UsageOnly => \$dumpvar::usageOnly,
- frame => \$frame,
+ frame => \$frame,
+ AutoTrace => \$trace,
+ inhibit_exit => \$inhibit_exit,
+ maxTraceLen => \$maxtrace,
+ ImmediateStop => \$ImmediateStop,
);
%optionAction = (
signalLevel => \&signalLevel,
warnLevel => \&warnLevel,
dieLevel => \&dieLevel,
+ tkRunning => \&tkRunning,
+ ornaments => \&ornaments,
);
%optionRequire = (
&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";
%postponed = get_list("PERLDB_POSTPONE");
my @had_breakpoints= get_list("PERLDB_VISITED");
for (0 .. $#had_breakpoints) {
- %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
+ my %pf = get_list("PERLDB_FILE_$_");
+ $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
}
my %opt = get_list("PERLDB_OPT");
my ($opt,$val);
}
@INC = get_list("PERLDB_INC");
@ini_INC = @INC;
+ $pretype = [get_list("PERLDB_PRETYPE")];
+ $pre = [get_list("PERLDB_PRE")];
+ $post = [get_list("PERLDB_POST")];
+ @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
}
if ($notty) {
if (-e "/dev/tty") {
$console = "/dev/tty";
- } elsif (-e "con") {
+ } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
$console = "con";
} else {
$console = "sys\$command";
}
+ if (($^O eq 'MSWin32') and ($emacs or defined $ENV{EMACS})) {
+ $console = undef;
+ }
+
# Around a bug:
if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
$console = undef;
&afterinit();
}
+$I_m_init = 1;
+
############################################################ Subroutines
sub DB {
- unless ($first_time++) { # Do when-running init
- if ($runnonstop) { # Disable until signal
+ # _After_ the perl program is compiled, $single is set to 1:
+ if ($single and not $second_time++) {
+ if ($runnonstop) { # Disable until signal
for ($i=0; $i <= $#stack; ) {
$stack[$i++] &= ~1;
}
$single = 0;
- return;
+ # return; # Would not print trace!
+ } elsif ($ImmediateStop) {
+ $ImmediateStop = 0;
+ $signal = 1;
}
}
+ $runnonstop = 0 if $single or $signal; # Disable it if interactive.
&save;
($package, $filename, $line) = caller;
$filename_ini = $filename;
- $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
+ $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
"package $package;"; # this won't let them modify, alas
- local(*dbline) = "::_<$filename";
+ local(*dbline) = $main::{'_<' . $filename};
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
if ($stop eq '1') {
$dbline{$line} =~ s/;9($|\0)/$1/;
}
}
- if ($single || $trace || $signal) {
+ my $was_signal = $signal;
+ if ($trace & 2) {
+ for (my $n = 0; $n <= $#to_watch; $n++) {
+ $evalarg = $to_watch[$n];
+ my ($val) = &eval; # Fix context (&eval is doing array)?
+ $val = ( (defined $val) ? "'$val'" : 'undef' );
+ if ($val ne $old_watch[$n]) {
+ $signal = 1;
+ print $OUT <<EOP;
+Watchpoint $n:\t$to_watch[$n] changed:
+ old value:\t$old_watch[$n]
+ new value:\t$val
+EOP
+ $old_watch[$n] = $val;
+ }
+ }
+ }
+ if ($trace & 4) { # User-installed watch
+ return if watchfunction($package, $filename, $line)
+ and not $single and not $was_signal and not ($trace & ~4);
+ }
+ $was_signal = $signal;
+ $signal = 0;
+ if ($single || ($trace & 1) || $was_signal) {
$term || &setterm;
if ($emacs) {
$position = "\032\032$filename:$line:0\n";
print $LINEINFO $position;
+ } elsif ($package eq 'DB::fake') {
+ print_help(<<EOP);
+Debugged program terminated. Use B<q> to quit or B<R> to restart,
+ use B<O> I<inhibit_exit> to avoid stopping after program termination,
+ B<h q>, B<h R> or B<h O> to get additional info.
+EOP
+ $package = 'main';
+ $usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
} else {
$sub =~ s/\'/::/;
$prefix = $sub =~ /::/ ? "" : "${'package'}::";
$after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
if (length($prefix) > 30) {
$position = "$prefix$line):\n$line:\t$dbline[$line]$after";
- print $LINEINFO $position;
$prefix = "";
$infix = ":\t";
} else {
$infix = "):\t";
$position = "$prefix$line$infix$dbline[$line]$after";
+ }
+ if ($frame) {
+ print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after";
+ } else {
print $LINEINFO $position;
}
for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
+ last if $signal;
$after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
$incr_pos = "$prefix$i$infix$dbline[$i]$after";
- print $LINEINFO $incr_pos;
$position .= $incr_pos;
+ if ($frame) {
+ print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after";
+ } else {
+ print $LINEINFO $incr_pos;
+ }
}
}
}
$evalarg = $action, &eval if $action;
- if ($single || $signal) {
+ if ($single || $was_signal) {
local $level = $level + 1;
- map {$evalarg = $_, &eval} @$pre;
+ foreach $evalarg (@$pre) {
+ &eval;
+ }
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),
+ ($term_pid == $$ or &resetterm),
defined ($cmd=&readline(" DB" . ('<' x $level) .
($#hist+1) . ('>' x $level) .
" "))) {
$cmd .= &readline(" cont: ");
redo CMD;
};
- $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
$cmd =~ /^$/ && ($cmd = $laststep);
push(@hist,$cmd) if length($cmd) > 1;
PIPE: {
($i) = split(/\s+/,$cmd);
eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i};
+ $cmd =~ /^q$/ && ($exiting = 1) && exit 0;
$cmd =~ /^h$/ && do {
- print $OUT $help;
+ print_help($help);
next CMD; };
$cmd =~ /^h\s+h$/ && do {
- print $OUT $summary;
+ print_help($summary);
next CMD; };
$cmd =~ /^h\s+(\S)$/ && do {
my $asked = "\Q$1";
- if ($help =~ /^$asked/m) {
- while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
- print $OUT $1;
+ if ($help =~ /^(?:[IB]<)$asked/m) {
+ while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) {
+ print_help($1);
}
} else {
- print $OUT "`$asked' is not a debugger command.\n";
+ print_help("B<$asked> is not a debugger command.\n");
}
next CMD; };
$cmd =~ /^t$/ && do {
- $trace = !$trace;
- print $OUT "Trace = ".($trace?"on":"off")."\n";
+ ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
+ print $OUT "Trace = " .
+ (($trace & 1) ? "on" : "off" ) . "\n";
next CMD; };
$cmd =~ /^S(\s+(!)?(.+))?$/ && do {
$Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
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;
+ $file =~ s/\s+$//;
if (!$file) {
print $OUT "The old f command is now the r command.\n";
print $OUT "The new f command switches filenames.\n";
}
if (!defined $main::{'_<' . $file}) {
if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
- $file = substr($try,2);
- print "\n$file:\n";
+ $try = substr($try,2);
+ print $OUT "Choosing $try matching `$file':\n";
+ $file = $try;
}}
}
if (!defined $main::{'_<' . $file}) {
- print $OUT "There's no code here matching $file.\n";
+ print $OUT "No file matching `$file' is loaded.\n";
next CMD;
} elsif ($file ne $filename) {
- *dbline = "::_<$file";
+ *dbline = $main::{'_<' . $file};
$max = $#dbline;
$filename = $file;
$start = 1;
$cmd = "l";
- } };
+ } else {
+ print $OUT "Already in $file.\n";
+ next CMD;
+ }
+ };
+ $cmd =~ s/^l\s+-\s*$/-/;
$cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do {
$subname = $1;
$subname =~ s/\'/::/;
- $subname = "main::".$subname unless $subname =~ /::/;
+ $subname = $package."::".$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) {
- *dbline = "::_<$file";
+ *dbline = $main::{'_<' . $file};
$max = $#dbline;
$filename = $file;
}
next CMD;
} };
$cmd =~ /^\.$/ && do {
+ $incr = -1; # for backward motion.
$start = $line;
$filename = $filename_ini;
- *dbline = "::_<$filename";
+ *dbline = $main::{'_<' . $filename};
$max = $#dbline;
print $LINEINFO $position;
next CMD };
#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;
$arrow = ($i==$line
and $filename eq $filename_ini)
? '==>'
- : ':' ;
+ : ($dbline[$i]+0 ? ':' : ' ') ;
$arrow .= 'b' if $stop;
$arrow .= 'a' if $action;
print $OUT "$i$arrow\t", $dbline[$i];
print $OUT "Deleting all breakpoints...\n";
my $file;
for $file (keys %had_breakpoints) {
- local *dbline = "::_<$file";
+ local *dbline = $main::{'_<' . $file};
my $max = $#dbline;
my $was;
$cmd =~ /^L$/ && do {
my $file;
for $file (keys %had_breakpoints) {
- local *dbline = "::_<$file";
+ local *dbline = $main::{'_<' . $file};
my $max = $#dbline;
my $was;
print $OUT "Postponed breakpoints in files:\n";
my ($file, $line);
for $file (keys %postponed_file) {
- my %db = %{$postponed_file{$file}};
- next unless keys %db;
+ my $db = $postponed_file{$file};
print $OUT " $file:\n";
- for $line (sort {$a <=> $b} keys %db) {
- print $OUT " $i:\n";
- my ($stop,$action) = split(/\0/, $db{$line});
+ for $line (sort {$a <=> $b} keys %$db) {
+ print $OUT " $line:\n";
+ my ($stop,$action) = split(/\0/, $$db{$line});
print $OUT " break if (", $stop, ")\n"
if $stop;
print $OUT " action: ", $action, "\n"
last if $signal;
}
}
+ if ($trace & 2) {
+ print $OUT "Watch-expressions:\n";
+ my $expr;
+ for $expr (@to_watch) {
+ print $OUT " $expr\n";
+ last if $signal;
+ }
+ }
next CMD; };
$cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
- my $file = $1;
+ my $file = $1; $file =~ s/\s+$//;
{
$break_on_load{$file} = 1;
$break_on_load{$::INC{$file}} = 1 if $::INC{$file};
$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;
- *dbline = "::_<$filename";
+ *dbline = $main::{'_<' . $filename};
$had_breakpoints{$filename} = 1;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
$cmd =~ /^A$/ && do {
my $file;
for $file (keys %had_breakpoints) {
- local *dbline = "::_<$file";
+ local *dbline = $main::{'_<' . $file};
my $max = $#dbline;
my $was;
}
next CMD; };
$cmd =~ /^n$/ && do {
- next CMD if $finished and $level <= 1;
+ end_report(), next CMD if $finished and $level <= 1;
$single = 2;
$laststep = $cmd;
last CMD; };
$cmd =~ /^s$/ && do {
- next CMD if $finished and $level <= 1;
+ end_report(), next CMD if $finished and $level <= 1;
$single = 1;
$laststep = $cmd;
last CMD; };
$cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
- next CMD if $finished and $level <= 1;
- $i = $1;
+ end_report(), next CMD if $finished and $level <= 1;
+ $subname = $i = $1;
if ($i =~ /\D/) { # subroutine name
- ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
+ ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
$i += 0;
if ($i) {
$filename = $file;
- *dbline = "::_<$filename";
+ *dbline = $main::{'_<' . $filename};
$had_breakpoints{$filename}++;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
}
last CMD; };
$cmd =~ /^r$/ && do {
- next CMD if $finished and $level <= 1;
+ end_report(), next CMD if $finished and $level <= 1;
$stack[$#stack] |= 1;
$doret = $option{PrintRet} ? $#stack - 1 : -2;
last CMD; };
my @hard;
for (0 .. $#had_breakpoints) {
my $file = $had_breakpoints[$_];
- *dbline = "::_<$file";
- next unless %dbline or %{$postponed_file{$file}};
+ *dbline = $main::{'_<' . $file};
+ next unless %dbline or $postponed_file{$file};
(push @hard, $file), next
if $file =~ /^\(eval \d+\)$/;
my @add;
@add = %{$postponed_file{$file}}
- if %{$postponed_file{$file}};
+ if $postponed_file{$file};
set_list("PERLDB_FILE_$_", %dbline, @add);
}
for (@hard) { # Yes, really-really...
# Find the subroutines in this eval
- *dbline = "::_<$_";
+ *dbline = $main::{'_<' . $_};
my ($quoted, $sub, %subs, $line) = quotemeta $_;
for $sub (keys %sub) {
next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
}
}
set_list("PERLDB_POSTPONE", %postponed);
+ set_list("PERLDB_PRETYPE", @$pretype);
+ set_list("PERLDB_PRE", @$pre);
+ set_list("PERLDB_POST", @$post);
+ set_list("PERLDB_TYPEAHEAD", @typeahead);
$ENV{PERLDB_RESTART} = 1;
#print "$^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS";
exec $^X, '-d', @flags, @script, ($emacs ? '-emacs' : ()), @ARGS;
print $OUT "exec failed: $!\n";
last CMD; };
$cmd =~ /^T$/ && do {
- print_trace($OUT, 3); # skip DB print_trace dump_trace
+ print_trace($OUT, 1); # skip DB
+ next CMD; };
+ $cmd =~ /^W\s*$/ && do {
+ $trace &= ~2;
+ @to_watch = @old_watch = ();
+ next CMD; };
+ $cmd =~ /^W\b\s*(.*)/s && do {
+ push @to_watch, $1;
+ $evalarg = $1;
+ my ($val) = &eval;
+ $val = (defined $val) ? "'$val'" : 'undef' ;
+ push @old_watch, $val;
+ $trace |= 2;
next CMD; };
$cmd =~ /^\/(.*)$/ && do {
$inpat = $1;
$pat = $inpat;
}
$end = $start;
+ $incr = -1;
eval '
for (;;) {
++$start;
$pat = $inpat;
}
$end = $start;
+ $incr = -1;
eval '
for (;;) {
--$start;
$cmd =~ s/^\|+\s*//;
redo PIPE; };
# XXX Local variants do not work!
- $cmd =~ s/^t\s/\$DB::trace = 1;\n/;
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
$cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
$cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
} # PIPE:
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
if ($onetimeDump) {
$onetimeDump = undef;
- } else {
+ } elsif ($term_pid == $$) {
print $OUT "\n";
}
} continue { # CMD:
$piped= "";
}
} # CMD:
- map {$evalarg = $_; &eval} @$post;
+ $exiting = 1 unless defined $cmd;
+ foreach $evalarg (@$post) {
+ &eval;
+ }
} # if ($single || $signal)
- ($@, $!, $,, $/, $\, $^W) = @saved;
+ ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
();
}
sub sub {
my ($al, $ret, @ret) = "";
- if ($sub =~ /::AUTOLOAD$/) {
- $al = " for $ {$` . '::AUTOLOAD'}";
+ if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
+ $al = " for $$sub";
}
- print $LINEINFO ' ' x $#stack, "entering $sub$al\n" if $frame;
push(@stack, $single);
$single &= 1;
$single |= 4 if $#stack == $deep;
+ ($frame & 4
+ ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "),
+ # Why -1? But it works! :-(
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
+ : print $LINEINFO ' ' x ($#stack - 1), "entering $sub$al\n") if $frame;
if (wantarray) {
@ret = &$sub;
$single |= pop(@stack);
- print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
- $doret = -2 if $doret eq $#stack;
- print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1;
+ ($frame & 4
+ ? ( (print $LINEINFO ' ' x $#stack, "out "),
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
+ : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
+ print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
+ "list context return from $sub:\n"), dumpit( \@ret ),
+ $doret = -2 if $doret eq $#stack or $frame & 16;
@ret;
} else {
- $ret = &$sub;
+ if (defined wantarray) {
+ $ret = &$sub;
+ } else {
+ &$sub; undef $ret;
+ };
$single |= pop(@stack);
- print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
- $doret = -2 if $doret eq $#stack;
- print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1;
+ ($frame & 4
+ ? ( (print $LINEINFO ' ' x $#stack, "out "),
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
+ : print $LINEINFO ' ' x $#stack, "exited $sub$al\n") if $frame & 2;
+ print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
+ "scalar context return from $sub: "), dumpit( $ret ),
+ $doret = -2 if $doret eq $#stack or $frame & 16;
$ret;
}
}
sub save {
- @saved = ($@, $!, $,, $/, $\, $^W);
+ @saved = ($@, $!, $^E, $,, $/, $\, $^W);
$, = ""; $/ = "\n"; $\ = ""; $^W = 0;
}
$^D = $od;
}
my $at = $@;
- eval "&DB::save";
+ local $saved[0]; # Preserve the old value of $@
+ eval { &DB::save };
if ($at) {
print $OUT $at;
- } elsif ($onetimeDump) {
+ } elsif ($onetimeDump eq 'dump') {
dumpit(\@res);
+ } elsif ($onetimeDump eq 'methods') {
+ methods($res[0]);
}
+ @res;
}
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+)-.*$/);
- $i += $offset;
+ my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
if ($i) {
- local *dbline = "::_<$file";
+ $i += $offset;
+ local *dbline = $main::{'_<' . $file};
local $^W = 0; # != 0 is magical below
$had_breakpoints{$file}++;
my $max = $#dbline;
}
return;
}
- print $OUT "In postponed_sub for `$subname'.\n";
+ elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
+ #print $OUT "In postponed_sub for `$subname'.\n";
}
sub postponed {
+ if ($ImmediateStop) {
+ $ImmediateStop = 0;
+ $signal = 1;
+ }
return &postponed_sub
unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
# Cannot be done before the file is compiled
local *dbline = shift;
my $filename = $dbline;
$filename =~ s/^_<//;
- $signal = 1, print $OUT "'$filename' loaded...\n" if $break_on_load{$filename};
- return unless %{$postponed_file{$filename}};
+ $signal = 1, print $OUT "'$filename' loaded...\n"
+ if $break_on_load{$filename};
+ print $LINEINFO ' ' x $#stack, "Package $filename.\n" if $frame;
+ return unless $postponed_file{$filename};
$had_breakpoints{$filename}++;
#%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
my $key;
for $key (keys %{$postponed_file{$filename}}) {
$dbline{$key} = $ {$postponed_file{$filename}}{$key};
}
- undef %{$postponed_file{$filename}};
+ delete $postponed_file{$filename};
}
sub dumpit {
select ($savout);
}
+# Tied method do not create a context, so may get wrong message:
+
sub print_trace {
my $fh = shift;
- my @sub = dump_trace(@_);
+ 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} })"
: '' ;
- $file = $sub[$i]{file} eq '-e' ? $sub[$i]{file} :
- "file `$sub[$i]{file}'";
- print $fh "$sub[$i]{context}$sub[$i]{sub}$args" .
- " called from $file" .
- " line $sub[$i]{line}\n";
+ $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] : $s;
+ print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
+ } else {
+ print $fh "$sub[$i]{context} = $s$args" .
+ " called from $file" .
+ " line $sub[$i]{line}\n";
+ }
}
}
sub dump_trace {
my $skip = shift;
+ my $count = shift || 1e9;
+ $skip++;
+ $count += $skip;
my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
+ my $nothard = not $frame & 8;
+ local $frame = 0; # Do not want to trace this.
+ my $otrace = $trace;
+ $trace = 0;
for ($i = $skip;
- ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
+ $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
$i++) {
@a = ();
for $arg (@args) {
- $_ = "$arg";
- s/([\'\\])/\\$1/g;
- s/([^\0]*)/'$1'/
- unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
- s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
- s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
- push(@a, $_);
+ my $type;
+ if (not defined $arg) {
+ push @a, "undef";
+ } elsif ($nothard and tied $arg) {
+ push @a, "tied";
+ } elsif ($nothard and $type = ref $arg) {
+ push @a, "ref($type)";
+ } else {
+ local $_ = "$arg"; # Safe to stringify now - should not call f().
+ s/([\'\\])/\\$1/g;
+ s/(.*)/'$1'/s
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ push(@a, $_);
+ }
}
- $context = $context ? '@ = ' : '$ = ';
+ $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) {
file => $file, line => $line});
last if $signal;
}
+ $trace = $otrace;
@sub;
}
# We save, change, then restore STDIN and STDOUT to avoid fork() since
# many non-Unix systems can do system() but have problems with fork().
open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
- open(SAVEOUT,">&OUT") || &warn("Can't save STDOUT");
+ open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
system(@_);
} else {
$term = new Term::ReadLine 'perldb', $IN, $OUT;
- $readline::rl_basic_word_break_characters .= "[:"
- if defined $readline::rl_basic_word_break_characters
- and index($readline::rl_basic_word_break_characters, ":") == -1;
- $readline::rl_special_prefixes =
- $readline::rl_special_prefixes = '$@&%';
- $readline::rl_completer_word_break_characters =
- $readline::rl_completer_word_break_characters . '$@&%';
- $readline::rl_completion_function =
- $readline::rl_completion_function = \&db_complete;
+ $rl_attribs = $term->Attribs;
+ $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
+ if defined $rl_attribs->{basic_word_break_characters}
+ and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
+ $rl_attribs->{special_prefixes} = '$@&%';
+ $rl_attribs->{completer_word_break_characters} .= '$@&%';
+ $rl_attribs->{completion_function} = \&db_complete;
}
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
if ($term->Features->{setHistory} and "@hist" ne "?") {
$term->SetHistory(@hist);
}
+ ornaments($ornaments) if defined $ornaments;
+ $term_pid = $$;
+}
+
+sub resetterm { # We forked, so we need a different TTY
+ $term_pid = $$;
+ if (defined &get_fork_TTY) {
+ &get_fork_TTY;
+ } elsif (not defined $fork_TTY
+ and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
+ and defined $ENV{WINDOWID} and defined $ENV{DISPLAY}) {
+ # Possibly _inside_ XTERM
+ open XT, q[3>&1 xterm -title 'Forked Perl debugger' -e sh -c 'tty 1>&3;\
+ sleep 10000000' |];
+ $fork_TTY = <XT>;
+ chomp $fork_TTY;
+ }
+ if (defined $fork_TTY) {
+ TTY($fork_TTY);
+ undef $fork_TTY;
+ } else {
+ print_help(<<EOP);
+I<#########> Forked, but do not know how to change a B<TTY>. I<#########>
+ Define B<\$DB::fork_TTY>
+ - or a function B<DB::get_fork_TTY()> which will set B<\$DB::fork_TTY>.
+ The value of B<\$DB::fork_TTY> should be the name of I<TTY> to use.
+ On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
+ by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
+EOP
+ }
}
sub readline {
sub catch {
$signal = 1;
+ return; # Put nothing on the stack - malloc/free land!
}
sub warn {
}
sub TTY {
- if ($term) {
- &warn("Too late to set TTY!\n") if @_;
- } else {
- $tty = shift if @_;
- }
+ if (@_ and $term and $term->Features->{newTTY}) {
+ my ($in, $out) = shift;
+ if ($in =~ /,/) {
+ ($in, $out) = split /,/, $in, 2;
+ } else {
+ $out = $in;
+ }
+ open IN, $in or die "cannot open `$in' for read: $!";
+ open OUT, ">$out" or die "cannot open `$out' for write: $!";
+ $term->newTTY(\*IN, \*OUT);
+ $IN = \*IN;
+ $OUT = \*OUT;
+ return $tty = $in;
+ } elsif ($term and @_) {
+ &warn("Too late to set TTY, enabled on next `R'!\n");
+ }
+ $tty = shift if @_;
$tty or $console;
}
sub noTTY {
if ($term) {
- &warn("Too late to set noTTY!\n") if @_;
- } else {
- $notty = shift if @_;
+ &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
}
+ $notty = shift if @_;
$notty;
}
sub ReadLine {
if ($term) {
- &warn("Too late to set ReadLine!\n") if @_;
- } else {
- $rl = shift if @_;
+ &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
}
+ $rl = shift if @_;
$rl;
}
+sub tkRunning {
+ if ($ {$term->Features}{tkRunning}) {
+ return $term->tkRunning(@_);
+ } else {
+ print $OUT "tkRunning not supported by current ReadLine package.\n";
+ 0;
+ }
+}
+
sub NonStop {
if ($term) {
- &warn("Too late to set up NonStop mode!\n") if @_;
- } else {
- $runnonstop = shift if @_;
+ &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
}
+ $runnonstop = shift if @_;
$runnonstop;
}
$psh;
}
+sub ornaments {
+ if (defined $term) {
+ local ($warnLevel,$dieLevel) = (0, 1);
+ return '' unless $term->Features->{ornaments};
+ eval { $term->ornaments(@_) } || '';
+ } else {
+ $ornaments = shift;
+ }
+}
+
sub recallCommand {
if (@_) {
$rc = quotemeta shift;
sub sethelp {
$help = "
-T Stack trace.
-s [expr] Single step [in expr].
-n [expr] Next, steps over subroutine calls [in expr].
-<CR> Repeat last n or s command.
-r Return from current subroutine.
-c [line|sub] Continue; optionally inserts a one-time-only breakpoint
+B<T> Stack trace.
+B<s> [I<expr>] Single step [in I<expr>].
+B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
+<B<CR>> Repeat last B<n> or B<s> command.
+B<r> Return from current subroutine.
+B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
at the specified position.
-l min+incr List incr+1 lines starting at min.
-l min-max List lines min through max.
-l line List single line.
-l subname List first window of lines from subroutine.
-l List next window of lines.
-- List previous window of lines.
-w [line] List window around line.
-. Return to the executed line.
-f filename Switch to viewing filename.
-/pattern/ Search forwards for pattern; final / is optional.
-?pattern? Search backwards for pattern; final ? is optional.
-L List all breakpoints and actions for the current file.
-S [[!]pattern] List subroutine names [not] matching pattern.
-t Toggle trace mode.
-t expr Trace through execution of expr.
-b [line] [condition]
- Set breakpoint; line defaults to the current execution line;
- condition breaks if it evaluates to true, defaults to '1'.
-b subname [condition]
+B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
+B<l> I<min>B<->I<max> List lines I<min> through I<max>.
+B<l> I<line> List single I<line>.
+B<l> I<subname> List first window of lines from subroutine.
+B<l> List next window of lines.
+B<-> List previous window of lines.
+B<w> [I<line>] List window around I<line>.
+B<.> Return to the executed line.
+B<f> I<filename> Switch to viewing I<filename>. Must be loaded.
+B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
+B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
+B<L> List all breakpoints and actions.
+B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
+B<t> Toggle trace mode.
+B<t> I<expr> Trace through execution of I<expr>.
+B<b> [I<line>] [I<condition>]
+ Set breakpoint; I<line> defaults to the current execution line;
+ I<condition> breaks if it evaluates to true, defaults to '1'.
+B<b> I<subname> [I<condition>]
Set breakpoint at first line of subroutine.
-b load filename Set breakpoint on `require'ing the given file.
-b postpone subname [condition]
+B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
+B<b> B<postpone> I<subname> [I<condition>]
Set breakpoint at first line of subroutine after
it is compiled.
-d [line] Delete the breakpoint for line.
-D Delete all breakpoints.
-a [line] command
- Set an action to be done before the line is executed.
- Sequence is: check for breakpoint, print line if necessary,
- do action, prompt user if breakpoint or step, evaluate line.
-A Delete all actions.
-V [pkg [vars]] List some (default all) variables in package (default current).
- 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.
-O [opt[=val]] [opt\"val\"] [opt?]...
- Set or query values of options. val defaults to 1. opt can
+B<b> B<compile> I<subname>
+ Stop after the subroutine is compiled.
+B<d> [I<line>] Delete the breakpoint for I<line>.
+B<D> Delete all breakpoints.
+B<a> [I<line>] I<command>
+ Set an action to be done before the I<line> is executed.
+ Sequence is: check for breakpoint/watchpoint, print line
+ if necessary, do action, prompt user if necessary,
+ execute expression.
+B<A> Delete all actions.
+B<W> I<expr> Add a global watch-expression.
+B<W> Delete all watch-expressions.
+B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
+ Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
+B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
+B<x> I<expr> Evals expression in array context, dumps the result.
+B<m> I<expr> Evals expression in array context, prints methods callable
+ on the first element of the result.
+B<m> I<class> Prints methods callable via the given class.
+B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
+ Set or query values of options. I<val> defaults to 1. I<opt> can
be abbreviated. Several options can be listed.
- recallCommand, ShellBang: chars used to recall command or spawn shell;
- pager: program for output of \"|cmd\";
- The following options affect what happens with V, X, and x commands:
- arrayDepth, hashDepth: print only first N elements ('' for all);
- compactDump, veryCompact: change style of array and hash dump;
- globPrint: whether to print contents of globs;
- DumpDBFiles: dump arrays holding debugged files;
- DumpPackages: dump symbol tables of packages;
- quote, HighBit, undefPrint: change style of string dump;
- tkRunning: run Tk while prompting (with ReadLine);
- signalLevel warnLevel dieLevel: level of verbosity;
- Option PrintRet affects printing of return value after r command,
- frame affects printing messages on entry and exit from subroutines.
+ I<recallCommand>, I<ShellBang>: chars used to recall command or spawn shell;
+ I<pager>: program for output of \"|cmd\";
+ I<tkRunning>: run Tk while prompting (with ReadLine);
+ I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
+ I<inhibit_exit> Allows stepping off the end of the script.
+ I<ImmediateStop> Debugger should stop as early as possible.
+ The following options affect what happens with B<V>, B<X>, and B<x> commands:
+ I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
+ I<compactDump>, I<veryCompact>: change style of array and hash dump;
+ I<globPrint>: whether to print contents of globs;
+ I<DumpDBFiles>: dump arrays holding debugged files;
+ I<DumpPackages>: dump symbol tables of packages;
+ I<DumpReused>: dump contents of \"reused\" addresses;
+ I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
+ Option I<PrintRet> affects printing of return value after B<r> command,
+ I<frame> affects printing messages on entry and exit from subroutines.
+ I<AutoTrace> affects printing messages on every possible breaking point.
+ I<maxTraceLen> gives maximal length of evals/args listed in stack trace.
+ I<ornaments> affects screen appearance of the command line.
During startup options are initialized from \$ENV{PERLDB_OPTS}.
- You can put additional initialization options TTY, noTTY,
- ReadLine, and NonStop there.
-< command Define Perl command to run before each prompt.
-<< command Add to the list of Perl commands to run before each prompt.
-> command Define Perl command to run after each prompt.
->> command Add to the list of Perl commands to run after each prompt.
-\{ commandline Define debugger command to run before each prompt.
-\{{ commandline Add to the list of debugger commands to run before each prompt.
-$prc number Redo a previous command (default previous command).
-$prc -number Redo number'th-to-last command.
-$prc pattern Redo last command that started with pattern.
- See 'O recallCommand' too.
-$psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
+ You can put additional initialization options I<TTY>, I<noTTY>,
+ I<ReadLine>, and I<NonStop> there (or use `B<R>' after you set them).
+B<<> I<expr> Define Perl command to run before each prompt.
+B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
+B<>> I<expr> Define Perl command to run after each prompt.
+B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<{> I<db_command> Define debugger command to run before each prompt.
+B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
+B<$prc> I<number> Redo a previous command (default previous command).
+B<$prc> I<-number> Redo number'th-to-last command.
+B<$prc> I<pattern> Redo last command that started with I<pattern>.
+ See 'B<O> I<recallCommand>' too.
+B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
. ( $rc eq $sh ? "" : "
-$psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
- See 'O shellBang' too.
-H -number Display last number commands (default all).
-p expr Same as \"print {DB::OUT} expr\" in current package.
-|dbcmd Run debugger command, piping DB::OUT to current pager.
-||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
-\= [alias value] Define a command alias, or list current aliases.
-command Execute as a perl statement in current package.
-v Show versions of loaded modules.
-R Pure-man-restart of debugger, some of debugger state
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
+ See 'B<O> I<shellBang>' too.
+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.
+B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
+B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
+I<command> Execute as a perl statement in current package.
+B<v> Show versions of loaded modules.
+B<R> Pure-man-restart of debugger, some of debugger state
and command-line options may be lost.
-h [db_command] Get help [on a specific debugger command], enter |h to page.
-h h Summary of debugger commands.
-q or ^D Quit.
+ Currently the following setting are preserved:
+ history, breakpoints and actions, debugger B<O>ptions
+ and the following command-line options: I<-w>, I<-I>, I<-e>.
+B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
+B<h h> Summary of debugger commands.
+B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
";
$summary = <<"END_SUM";
-List/search source lines: Control script execution:
- l [ln|sub] List source code T Stack trace
- - or . List previous/current line s [expr] Single step [in expr]
- w [line] List around line n [expr] Next, steps over subs
- f filename View source in file <CR> Repeat last n or s
- /pattern/ ?patt? Search forw/backw r Return from subroutine
- v Show versions of modules c [ln|sub] Continue until position
-Debugger controls: L List break pts & actions
- O [...] Set debugger options t [expr] Toggle trace [trace expr]
- <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
- >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
- $prc [N|pat] Redo a previous command d [line] Delete a breakpoint
- H [-num] Display last num commands D Delete all breakpoints
- = [a val] Define/list an alias a [ln] cmd Do cmd before line
- h [db_cmd] Get help on command A Delete all actions
- |[|]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.
- 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.
- X [Vars] Same as \"V current_package [Vars]\".
+I<List/search source lines:> I<Control script execution:>
+ B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
+ B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
+ B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
+ B<f> I<filename> View source in file <B<CR>> Repeat last B<n> or B<s>
+ B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
+ B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
+I<Debugger controls:> B<L> List break/watch/actions
+ B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
+ B<<>[B<<>] or B<{>[B<{>] [I<cmd>] Do before prompt B<b> [I<ln>|I<event>] [I<cnd>] Set breakpoint
+ B<>>[B<>>] [I<cmd>] Do after prompt B<b> I<sub> [I<cnd>] Set breakpoint for sub
+ B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
+ B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
+ B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
+ B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
+ B<|>[B<|>]I<dbcmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
+ B<q> or B<^D> Quit B<R> Attempt a restart
+I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
+ B<x>|B<m> I<expr> Evals expr in array context, dumps the result or lists methods.
+ 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>]\".
END_SUM
# ')}}; # Fix balance of Emacs parsing
}
+sub print_help {
+ my $message = shift;
+ if (@Term::ReadLine::TermCap::rl_term_set) {
+ $message =~ s/B<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[2]$1$Term::ReadLine::TermCap::rl_term_set[3]/g;
+ $message =~ s/I<([^>]+|>)>/$Term::ReadLine::TermCap::rl_term_set[0]$1$Term::ReadLine::TermCap::rl_term_set[1]/g;
+ }
+ print $OUT $message;
+}
+
sub diesignal {
local $frame = 0;
local $doret = -2;
$SIG{'ABRT'} = 'DEFAULT';
kill 'ABRT', $$ if $panic++;
- print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
- local $SIG{__WARN__} = '';
- require Carp;
- local $Carp::CarpLevel = 2; # mydie + confess
- &warn(Carp::longmess("Signal @_"));
+ if (defined &Carp::longmess) {
+ local $SIG{__WARN__} = '';
+ local $Carp::CarpLevel = 2; # mydie + confess
+ &warn(Carp::longmess("Signal @_"));
+ }
+ else {
+ print $DB::OUT "Got signal @_\n";
+ }
kill 'ABRT', $$;
}
local $doret = -2;
local $SIG{__WARN__} = '';
local $SIG{__DIE__} = '';
- eval { require Carp }; # If error/warning during compilation,
- # require may be broken.
- warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
- unless defined &Carp::longmess;
- #&warn("Entering dbwarn\n");
+ eval { require Carp } if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+ warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
+ return unless defined &Carp::longmess;
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
my $mess = Carp::longmess(@_);
($single,$trace) = ($mysingle,$mytrace);
- #&warn("Warning in dbwarn\n");
&warn($mess);
- #&warn("Exiting dbwarn\n");
}
sub dbdie {
local $SIG{__DIE__} = '';
local $SIG{__WARN__} = '';
my $i = 0; my $ineval = 0; my $sub;
- #&warn("Entering dbdie\n");
- if ($dieLevel != 2) {
- while ((undef,undef,undef,$sub) = caller(++$i)) {
- $ineval = 1, last if $sub eq '(eval)';
- }
- {
+ if ($dieLevel > 2) {
local $SIG{__WARN__} = \&dbwarn;
- &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
- }
- #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
- die @_ if $ineval and $dieLevel < 2;
+ &warn(@_); # Yell no matter what
+ return;
}
- eval { require Carp }; # If error/warning during compilation,
- # require may be broken.
- die(@_, "\nUnrecoverable error") unless defined &Carp::longmess;
+ if ($dieLevel < 2) {
+ die @_ if $^S; # in eval propagate
+ }
+ eval { require Carp } if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+ die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
+ unless defined &Carp::longmess;
# We do not want to debug this chunk (automatic disabling works
# inside DB::DB, but not in Carp).
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
my $mess = Carp::longmess(@_);
($single,$trace) = ($mysingle,$mytrace);
- #&warn("dieing loudly in dbdie\n");
die $mess;
}
$SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
#$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
print $OUT "Stack dump during die enabled",
- ( $dieLevel == 1 ? " outside of evals" : ""), ".\n";
+ ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
+ if $I_m_init;
print $OUT "Dump printed too.\n" if $dieLevel > 2;
} else {
$SIG{__DIE__} = $prevdie;
$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{ $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.
#use Carp; # This did break, left for debuggin
sub db_complete {
+ # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
my($text, $line, $start) = @_;
- my ($itext, $prefix, $pack) = $text;
+ my ($itext, $search, $prefix, $pack) =
+ ($text, "^\Q$ {'package'}::\E([^:]+)\$");
+ return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
+ (map { /$search/ ? ($1) : () } keys %sub)
+ if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
+ return sort grep /^\Q$text/, values %INC # files
+ if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
+ return sort map {($_, db_complete($_ . "::", "V ", 2))}
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
+ if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
+ return sort map {($_, db_complete($_ . "::", "V ", 2))}
+ grep !/^main::/,
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
+ # packages
+ if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
+ and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
+ if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
+ # We may want to complete to (eval 9), so $text may be wrong
+ $prefix = length($1) - length($text);
+ $text = $1;
+ return sort
+ map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
+ }
if ((substr $text, 0, 1) eq '&') { # subroutines
$text = substr $text, 1;
$prefix = "&";
- return map "$prefix$_", grep /^\Q$text/, keys %sub;
+ return sort map "$prefix$_",
+ grep /^\Q$text/,
+ (keys %sub),
+ (map { /$search/ ? ($1) : () }
+ keys %sub);
}
if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
$pack = ($1 eq 'main' ? '' : $1) . '::';
if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
return db_complete($out[0], $line, $start);
}
- return @out;
+ return sort @out;
}
if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
$pack = ($package eq 'main' ? '' : $package) . '::';
if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
return db_complete($out[0], $line, $start);
}
- return @out;
+ return sort @out;
}
- return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines
- if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\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
+ if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
my @out = grep /^\Q$text/, @options;
my $val = option_val($out[0], undef);
my $out = '? ';
$out = "=$val ";
}
# Default to value if one completion, to question if many
- $readline::rl_completer_terminator_character
- = $readline::rl_completer_terminator_character
- = (@out == 1 ? $out : '? ');
- return @out;
+ $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
+ return sort @out;
}
- return &readline::rl_filename_list($text); # filenames
+ return $term->filename_list($text); # filenames
+}
+
+sub end_report {
+ print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
}
END {
$finished = $inhibit_exit; # So that some keys may be disabled.
- $DB::single = 1;
- DB::fake::at_exit() unless $exiting;
+ # Do not stop in at_exit() and destructors on exit:
+ $DB::single = !$exiting && !$runnonstop;
+ DB::fake::at_exit() unless $exiting or $runnonstop;
}
package DB::fake;
sub at_exit {
- "Debuggee terminated. Use `q' to quit and `R' to restart.";
+ "Debugged program terminated. Use `q' to quit or `R' to restart.";
}
+package DB; # Do not trace this 1; below!
+
1;
https://perl5.git.perl.org / perl5.git / blobdiff