X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=de75bd7d868a3c9620e69b4e059e8873468988ba;hb=cc8461762c7674cd719f8f7e4a4e54252a249ef9;hp=ea072e0f3b8df27a2c5afceaae57acec697fd158;hpb=39e571d41067215a80f26089b260f1418caeb36b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index ea072e0..de75bd7 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,7 +2,7 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.02; +$VERSION = 1.05; $header = "perl5db.pl version $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -76,6 +76,8 @@ $header = "perl5db.pl version $VERSION"; # LineInfo - file or pipe to print line number info to. If it is a # pipe, a short "emacs like" message is used. # +# RemotePort - host:port to connect to on remote host for remote debugging. +# # Example $rcfile: (delete leading hashes!) # # &parse_options("NonStop=1 LineInfo=db.out"); @@ -173,26 +175,32 @@ $trace = $signal = $single = 0; # Uninitialized warning suppression # (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 AutoTrace TTY noTTY ReadLine NonStop LineInfo maxTraceLen recallCommand ShellBang pager tkRunning ornaments - signalLevel warnLevel dieLevel inhibit_exit); + signalLevel warnLevel dieLevel inhibit_exit + ImmediateStop bareStringify + RemotePort); %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, UsageOnly => \$dumpvar::usageOnly, + bareStringify => \$dumpvar::bareStringify, frame => \$frame, AutoTrace => \$trace, inhibit_exit => \$inhibit_exit, maxTraceLen => \$maxtrace, + ImmediateStop => \$ImmediateStop, + RemotePort => \$remoteport, ); %optionAction = ( @@ -212,6 +220,7 @@ $inhibit_exit = $option{PrintRet} = 1; dieLevel => \&dieLevel, tkRunning => \&tkRunning, ornaments => \&ornaments, + RemotePort => \&RemotePort, ); %optionRequire = ( @@ -231,7 +240,11 @@ $pretype = [] unless defined $pretype; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager(defined($ENV{PAGER}) ? $ENV{PAGER} : "|more") unless defined $pager; +&pager((defined($ENV{PAGER}) + ? $ENV{PAGER} + : ($^O eq 'os2' + ? 'cmd /c more' + : 'more'))) unless defined $pager; &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; $maxtrace = 400 unless defined $maxtrace; @@ -288,7 +301,10 @@ if ($notty) { #require Term::ReadLine; - if (-e "/dev/tty") { + if ($^O eq 'cygwin') { + # /dev/tty is binary. use stdin for textmode + undef $console; + } elsif (-e "/dev/tty") { $console = "/dev/tty"; } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { $console = "con"; @@ -305,21 +321,36 @@ if ($notty) { $console = undef; } + if ($^O eq 'epoc') { + $console = undef; + } + $console = $tty if defined $tty; - if (defined $console) { - open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN"); - open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR") - || open(OUT,">&STDOUT"); # so we don't dongle stdout - } else { - open(IN,"<&STDIN"); - open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout - $console = 'STDIN/OUT'; + if (defined $remoteport) { + require IO::Socket; + $OUT = new IO::Socket::INET( Timeout => '10', + PeerAddr => $remoteport, + Proto => 'tcp', + ); + if (!$OUT) { die "Could not create socket to connect to remote host."; } + $IN = $OUT; } - # so open("|more") can read from STDOUT and so we don't dingle stdin - $IN = \*IN; + else { + if (defined $console) { + open(IN,"+<$console") || open(IN,"<$console") || open(IN,"<&STDIN"); + open(OUT,"+>$console") || open(OUT,">$console") || open(OUT,">&STDERR") + || open(OUT,">&STDOUT"); # so we don't dongle stdout + } else { + open(IN,"<&STDIN"); + open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout + $console = 'STDIN/OUT'; + } + # so open("|more") can read from STDOUT and so we don't dingle stdin + $IN = \*IN; - $OUT = \*OUT; + $OUT = \*OUT; + } select($OUT); $| = 1; # for DB::OUT select(STDOUT); @@ -335,7 +366,7 @@ if ($notty) { print $OUT ("Emacs support ", $emacs ? "enabled" : "available", ".\n"); - print $OUT "\nEnter h or `h h' for help.\n\n"; + print $OUT "\nEnter h or `h h' for help, run `perldoc perldebug' for more help.\n\n"; } } @@ -357,18 +388,21 @@ sub DB { # _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; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } $single = 0; # 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) = $main::{'_<' . $filename}; $max = $#dbline; @@ -376,7 +410,7 @@ sub DB { if ($stop eq '1') { $signal |= 1; } elsif ($stop) { - $evalarg = "\$DB::signal |= do {$stop;}"; &eval; + $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval; $dbline{$line} =~ s/;9($|\0)/$1/; } } @@ -384,14 +418,15 @@ sub DB { if ($trace & 2) { for (my $n = 0; $n <= $#to_watch; $n++) { $evalarg = $to_watch[$n]; + local $onetimeDump; # Do not output results my ($val) = &eval; # Fix context (&eval is doing array)? $val = ( (defined $val) ? "'$val'" : 'undef' ); if ($val ne $old_watch[$n]) { $signal = 1; print $OUT < to quit or B to restart, + use B I to avoid stopping after program termination, + B, B or B to get additional info. +EOP + $package = 'main'; + $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . + "package $package;"; # this won't let them modify, alas } else { $sub =~ s/\'/::/; $prefix = $sub =~ /::/ ? "" : "${'package'}::"; @@ -422,7 +466,7 @@ EOP $position = "$prefix$line$infix$dbline[$line]$after"; } if ($frame) { - print $LINEINFO ' ' x $#stack, "$line:\t$dbline[$line]$after"; + print $LINEINFO ' ' x $stack_depth, "$line:\t$dbline[$line]$after"; } else { print $LINEINFO $position; } @@ -433,7 +477,7 @@ EOP $incr_pos = "$prefix$i$infix$dbline[$i]$after"; $position .= $incr_pos; if ($frame) { - print $LINEINFO ' ' x $#stack, "$i:\t$dbline[$i]$after"; + print $LINEINFO ' ' x $stack_depth, "$i:\t$dbline[$i]$after"; } else { print $LINEINFO $incr_pos; } @@ -446,11 +490,11 @@ EOP foreach $evalarg (@$pre) { &eval; } - print $OUT $#stack . " levels deep in subroutine calls!\n" + print $OUT $stack_depth . " levels deep in subroutine calls!\n" if $single & 4; $start = $line; $incr = -1; # for backward motion. - @typeahead = @$pretype, @typeahead; + @typeahead = (@$pretype, @typeahead); CMD: while (($term || &setterm), ($term_pid == $$ or &resetterm), @@ -553,16 +597,26 @@ EOP } }; $cmd =~ s/^l\s+-\s*$/-/; - $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*)/ && do { + $cmd =~ /^([lb])\b\s*(\$.*)/s && do { + $evalarg = $2; + my ($s) = &eval; + print($OUT "Error: $@\n"), next CMD if $@; + $s = CvGV_name($s); + print($OUT "Interpreted as: $1 $s\n"); + $cmd = "$1 $s"; + }; + $cmd =~ /^l\b\s*([\':A-Za-z_][\':\w]*(\[.*\])?)/s && do { $subname = $1; $subname =~ s/\'/::/; $subname = $package."::".$subname unless $subname =~ /::/; $subname = "main".$subname if substr($subname,0,2) eq "::"; - @pieces = split(/:/,find_sub($subname)); + @pieces = split(/:/,find_sub($subname) || $sub{$subname}); $subrange = pop @pieces; $file = join(':', @pieces); if ($file ne $filename) { + print $OUT "Switching to file '$file'.\n" + unless $emacs; *dbline = $main::{'_<' . $file}; $max = $#dbline; $filename = $file; @@ -623,8 +677,9 @@ EOP $arrow .= 'b' if $stop; $arrow .= 'a' if $action; print $OUT "$i$arrow\t", $dbline[$i]; - last if $signal; + $i++, last if $signal; } + print $OUT "\n" unless $dbline[$i-1] =~ /\n$/; } $start = $i; # remember in case they want more $start = $max if $start > $max; @@ -660,7 +715,7 @@ EOP for ($i = 1; $i <= $max; $i++) { if (defined $dbline{$i}) { - print "$file:\n" unless $was++; + print $OUT "$file:\n" unless $was++; print $OUT " $i:\t", $dbline[$i]; ($stop,$action) = split(/\0/, $dbline{$i}); print $OUT " break if (", $stop, ")\n" @@ -737,7 +792,7 @@ EOP $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; next CMD; }; - $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do { + $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do { $subname = $1; $cond = $2 || '1'; $subname =~ s/\'/::/; @@ -748,8 +803,8 @@ EOP ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/); $i += 0; if ($i) { - $filename = $file; - *dbline = $main::{'_<' . $filename}; + local $filename = $file; + local *dbline = $main::{'_<' . $filename}; $had_breakpoints{$filename} = 1; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; @@ -839,6 +894,10 @@ EOP $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do { end_report(), next CMD if $finished and $level <= 1; $subname = $i = $1; + # Probably not needed, since we finish an interactive + # sub-session anyway... + # local $filename = $filename; + # local *dbline = *dbline; # XXX Would this work?! if ($i =~ /\D/) { # subroutine name $subname = $package."::".$subname unless $subname =~ /::/; @@ -862,14 +921,14 @@ EOP } $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. } - for ($i=0; $i <= $#stack; ) { + for ($i=0; $i <= $stack_depth; ) { $stack[$i++] &= ~1; } last CMD; }; $cmd =~ /^r$/ && do { end_report(), next CMD if $finished and $level <= 1; - $stack[$#stack] |= 1; - $doret = $option{PrintRet} ? $#stack - 1 : -2; + $stack[$stack_depth] |= 1; + $doret = $option{PrintRet} ? $stack_depth - 1 : -2; last CMD; }; $cmd =~ /^R$/ && do { print $OUT "Warning: some settings and command-line options may be lost!\n"; @@ -1028,8 +1087,8 @@ EOP $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do { pop(@hist) if length($cmd) > 1; $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist); - $cmd = $hist[$i] . "\n"; - print $OUT $cmd; + $cmd = $hist[$i]; + print $OUT $cmd, "\n"; redo CMD; }; $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do { &system($1); @@ -1044,8 +1103,8 @@ EOP print $OUT "No such command!\n\n"; next CMD; } - $cmd = $hist[$i] . "\n"; - print $OUT $cmd; + $cmd = $hist[$i]; + print $OUT $cmd, "\n"; redo CMD; }; $cmd =~ /^$sh$/ && do { &system($ENV{SHELL}||"/bin/sh"); @@ -1140,7 +1199,7 @@ EOP &eval; } } # if ($single || $signal) - ($@, $!, $,, $/, $\, $^W) = @saved; + ($@, $!, $^E, $,, $/, $\, $^W) = @saved; (); } @@ -1152,24 +1211,30 @@ sub sub { if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { $al = " for $$sub"; } - push(@stack, $single); + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + $#stack = $stack_depth; + $stack[-1] = $single; $single &= 1; - $single |= 4 if $#stack == $deep; + $single |= 4 if $stack_depth == $deep; ($frame & 4 - ? ( (print $LINEINFO ' ' x ($#stack - 1), "in "), + ? ( (print $LINEINFO ' ' x ($stack_depth - 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; + : print $LINEINFO ' ' x ($stack_depth - 1), "entering $sub$al\n") if $frame; if (wantarray) { @ret = &$sub; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "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; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh ' ' x $stack_depth if $frame & 16; + print $fh "list context return from $sub:\n"; + dumpit($fh, \@ret ); + $doret = -2; + } @ret; } else { if (defined wantarray) { @@ -1177,32 +1242,37 @@ sub sub { } else { &$sub; undef $ret; }; - $single |= pop(@stack); + $single |= $stack[$stack_depth--]; ($frame & 4 - ? ( (print $LINEINFO ' ' x $#stack, "out "), + ? ( (print $LINEINFO ' ' x $stack_depth, "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; + : print $LINEINFO ' ' x $stack_depth, "exited $sub$al\n") if $frame & 2; + if ($doret eq $stack_depth or $frame & 16 and defined wantarray) { + my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO); + print $fh (' ' x $stack_depth) if $frame & 16; + print $fh (defined wantarray + ? "scalar context return from $sub: " + : "void context return from $sub\n"); + dumpit( $fh, $ret ) if defined wantarray; + $doret = -2; + } $ret; } } sub save { - @saved = ($@, $!, $,, $/, $\, $^W); + @saved = ($@, $!, $^E, $,, $/, $\, $^W); $, = ""; $/ = "\n"; $\ = ""; $^W = 0; } # The following takes its argument via $evalarg to preserve current @_ sub eval { - my @res; + local @res; # 'my' would make it visible from user code { - local (@stack) = @stack; # guard against recursive debugging - my $otrace = $trace; - my $osingle = $single; - my $od = $^D; + local $otrace = $trace; + local $osingle = $single; + local $od = $^D; @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug $trace = $otrace; $single = $osingle; @@ -1210,11 +1280,11 @@ sub eval { } my $at = $@; local $saved[0]; # Preserve the old value of $@ - eval "&DB::save"; + eval { &DB::save }; if ($at) { print $OUT $at; } elsif ($onetimeDump eq 'dump') { - dumpit(\@res); + dumpit($OUT, \@res); } elsif ($onetimeDump eq 'methods') { methods($res[0]); } @@ -1245,6 +1315,10 @@ sub postponed_sub { } 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 @@ -1253,7 +1327,7 @@ sub postponed { $filename =~ s/^_&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(@_); @@ -1401,7 +1475,6 @@ sub system { sub setterm { local $frame = 0; local $doret = -2; - local @stack = @stack; # Prevent growth by failing `use'. eval { require Term::ReadLine } or die $@; if ($notty) { if ($tty) { @@ -1460,8 +1533,14 @@ sub resetterm { # We forked, so we need a different TTY TTY($fork_TTY); undef $fork_TTY; } else { - print $OUT "Forked, but do not know how to change a TTY.\n", - "Define \$DB::fork_TTY or get_fork_TTY().\n"; + print_help(< Forked, but do not know how to change a B. I<#########> + Define B<\$DB::fork_TTY> + - or a function B which will set B<\$DB::fork_TTY>. + The value of B<\$DB::fork_TTY> should be the name of I to use. + On I-like systems one can get the name of a I for the given window + by typing B, and disconnect the I from I by B. +EOP } } @@ -1476,7 +1555,15 @@ sub readline { } local $frame = 0; local $doret = -2; - $term->readline(@_); + if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { + print $OUT @_; + my $stuff; + $IN->recv( $stuff, 2048 ); + $stuff; + } + else { + $term->readline(@_); + } } sub dump_option { @@ -1624,6 +1711,14 @@ sub ReadLine { $rl; } +sub RemotePort { + if ($term) { + &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; + } + $remoteport = shift if @_; + $remoteport; +} + sub tkRunning { if ($ {$term->Features}{tkRunning}) { return $term->tkRunning(@_); @@ -1710,13 +1805,7 @@ sub list_versions { } $version{$file} .= $INC{$file}; } - do 'dumpvar.pl' unless defined &main::dumpValue; - if (defined &main::dumpValue) { - local $frame = 0; - &main::dumpValue(\%version); - } else { - print $OUT "dumpvar.pl not available.\n"; - } + dumpit($OUT,\%version); } sub sethelp { @@ -1732,11 +1821,18 @@ B IB<+>I List I+1 lines starting at I. B IB<->I List lines I through I. B I List single I. B I List first window of lines from subroutine. +B I<$var> List first window of lines from subroutine referenced by I<$var>. B List next window of lines. B<-> List previous window of lines. B [I] List window around I. B<.> Return to the executed line. -B I Switch to viewing I. Must be loaded. +B I Switch to viewing I. File must be already loaded. + I may be either the full name of the file, or a regular + expression matching the full file name: + B I and B I may access the same file. + Evals (with saved bodies) are considered to be filenames: + B I<(eval 7)> and B I access the body of the 7th eval + (in the order of execution). BIB Search forwards for I; final B is optional. BIB Search backwards for I; final B is optional. B List all breakpoints and actions. @@ -1748,6 +1844,7 @@ B [I] [I] I breaks if it evaluates to true, defaults to '1'. B I [I] Set breakpoint at first line of subroutine. +B I<$var> Set breakpoint at first line of subroutine referenced by I<$var>. B B I Set breakpoint on `require'ing the given file. B B I [I] Set breakpoint at first line of subroutine after @@ -1779,13 +1876,17 @@ B [I[B<=>I]] [IB<\">IB<\">] [IB]... I: run Tk while prompting (with ReadLine); I I I: level of verbosity; I Allows stepping off the end of the script. + I Debugger should stop as early as possible. + I: Remote hostname:port for remote debugging The following options affect what happens with B, B, and B commands: I, I: print only first N elements ('' for all); I, I: change style of array and hash dump; I: whether to print contents of globs; I: dump arrays holding debugged files; I: dump symbol tables of packages; + I: dump contents of \"reused\" addresses; I, I, I: change style of string dump; + I: Do not print the overload-stringified value; Option I affects printing of return value after B command, I affects printing messages on entry and exit from subroutines. I affects printing messages on every possible breaking point. @@ -1793,7 +1894,8 @@ B [I[B<=>I]] [IB<\">IB<\">] [IB]... I affects screen appearance of the command line. During startup options are initialized from \$ENV{PERLDB_OPTS}. You can put additional initialization options I, I, - I, and I there (or use `B' after you set them). + I, I, and I there (or use + `B' after you set them). B<<> I Define Perl command to run before each prompt. B<<<> I Add to the list of Perl commands to run before each prompt. B<>> I Define Perl command to run after each prompt. @@ -1821,8 +1923,10 @@ B Pure-man-restart of debugger, some of debugger state history, breakpoints and actions, debugger Bptions and the following command-line options: I<-w>, I<-I>, I<-e>. B [I] Get help [on a specific debugger command], enter B<|h> to page. + Complete description of debugger is available in B + section of Perl documention B Summary of debugger commands. -B or B<^D> Quit. Set \$DB::finished to 0 to debug global destruction. +B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. "; $summary = <<"END_SUM"; @@ -1830,18 +1934,17 @@ I I B [I|I] List source code B Stack trace B<-> or B<.> List previous/current line B [I] Single step [in expr] B [I] List around line B [I] Next, steps over subs - B I View source in file > Repeat last B or B + B I View source in file /B> Repeat last B or B BIB BIB Search forw/backw B Return from subroutine B Show versions of modules B [I|I] Continue until position I B List break/watch/actions B [...] Set debugger options B [I] Toggle trace [trace expr] - B<<>[B<<>] or B<{>[B<{>] [I] Do before prompt B [I|I] [I] Set breakpoint - B<>>[B<>>] [I] Do after prompt B I [I] Set breakpoint for sub + B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint B<$prc> [I|I] Redo a previous command B [I] or B Delete a/all breakpoints B [I<-num>] Display last num commands B [I] I Do cmd before line B<=> [I I] Define/list an alias B I Add a watch expression B [I] Get help on command B or B Delete all actions/watch - B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess + B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess B or B<^D> Quit B Attempt a restart I B Execute perl code, also see: B,B,B I B|B I Evals expr in array context, dumps the result or lists methods. @@ -1849,6 +1952,7 @@ I B Execute perl code, also see: B,B,B< 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]\". +I BI<:> Type B I Run B for more help. END_SUM # ')}}; # Fix balance of Emacs parsing } @@ -1969,10 +2073,31 @@ sub signalLevel { $signalLevel; } +sub CvGV_name { + my $in = shift; + my $name = CvGV_name_or_bust($in); + defined $name ? $name : $in; +} + +sub CvGV_name_or_bust { + my $in = shift; + return if $skipCvGV; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + sub find_sub { my $subr = shift; - return unless defined &$subr; $sub{$subr} or do { + return unless defined &$subr; + my $name = CvGV_name_or_bust($subr); + my $data; + $data = $sub{$name} if defined $name; + return $data if defined $data; + + # Old stupid way... $subr = \&$subr; # Hard reference my $s; for (keys %sub) { @@ -2033,6 +2158,7 @@ BEGIN { # This does not compile, alas. # @stack and $doret are needed in sub sub, which is called for DB::postponed. # Triggers bug (?) in perl is we postpone this until runtime: @postponed = @stack = (0); + $stack_depth = 0; # Localized $#stack $doret = -2; $frame = 0; }