X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=bc545c6c8b1717aa29b558d7c5604c3444a993af;hb=8c99d73ee7ce90de2561496f683f3850d1269e1d;hp=de75bd7d868a3c9620e69b4e059e8873468988ba;hpb=cb50131aab68ac6dda048612c6e853b8cb08701e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index de75bd7..bc545c6 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -2,17 +2,9 @@ package DB; # Debugger for Perl 5.00x; perl5db.pl patch level: -$VERSION = 1.05; +$VERSION = 1.07; $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 - -# modified Perl debugger, to be run from Emacs in perldb-mode -# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 -# Johan Vromans -- upgrade to 4.0 pl 10 -# Ilya Zakharevich -- patches after 5.001 (and some before ;-) - # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. @@ -88,6 +80,15 @@ $header = "perl5db.pl version $VERSION"; # reset LineInfo to something "interactive"!) # ################################################################## + +# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) +# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl + +# modified Perl debugger, to be run from Emacs in perldb-mode +# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 +# Johan Vromans -- upgrade to 4.0 pl 10 +# Ilya Zakharevich -- patches after 5.001 (and some before ;-) + # Changelog: # A lot of things changed after 0.94. First of all, core now informs @@ -144,6 +145,48 @@ $header = "perl5db.pl version $VERSION"; # `b load' strips trailing whitespace. # completion ignores leading `|'; takes into account current package # when completing a subroutine name (same for `l'). +# Changes: 1.07: Many fixed by tchrist 13-March-2000 +# BUG FIXES: +# + Added bare mimimal security checks on perldb rc files, plus +# comments on what else is needed. +# + Fixed the ornaments that made "|h" completely unusable. +# They are not used in print_help if they will hurt. Strip pod +# if we're paging to less. +# + Fixed mis-formatting of help messages caused by ornaments +# to restore Larry's original formatting. +# + Fixed many other formatting errors. The code is still suboptimal, +# and needs a lot of work at restructuing. It's also misindented +# in many places. +# + Fixed bug where trying to look at an option like your pager +# shows "1". +# + Fixed some $? processing. Note: if you use csh or tcsh, you will +# lose. You should consider shell escapes not using their shell, +# or else not caring about detailed status. This should really be +# unified into one place, too. +# + Fixed bug where invisible trailing whitespace on commands hoses you, +# tricking Perl into thinking you wern't calling a debugger command! +# + Fixed bug where leading whitespace on commands hoses you. (One +# suggests a leading semicolon or any other irrelevant non-whitespace +# to indicate literal Perl code.) +# + Fixed bugs that ate warnings due to wrong selected handle. +# + Fixed a precedence bug on signal stuff. +# + Fixed some unseemly wording. +# + Fixed bug in help command trying to call perl method code. +# + Fixed to call dumpvar from exception handler. SIGPIPE killed us. +# ENHANCEMENTS: +# + Added some comments. This code is still nasty spaghetti. +# + Added message if you clear your pre/post command stacks which was +# very easy to do if you just typed a bare >, <, or {. (A command +# without an argument should *never* be a destructive action; this +# API is fundamentally screwed up; likewise option setting, which +# is equally buggered.) +# + Added command stack dump on argument of "?" for >, <, or {. +# + Added a semi-built-in doc viewer command that calls man with the +# proper %Config::Config path (and thus gets caching, man -k, etc), +# or else perldoc on obstreperous platforms. +# + Added to and rearranged the help information. +# + Detected apparent misuse of { ... } to declare a block; this used +# to work but now is a command, and mysteriously gave no complaint. #################################################################### @@ -237,36 +280,86 @@ $signalLevel = 1 unless defined $signalLevel; $pre = [] unless defined $pre; $post = [] unless defined $post; $pretype = [] unless defined $pretype; + warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -&pager((defined($ENV{PAGER}) + +&pager( + (defined($ENV{PAGER}) ? $ENV{PAGER} : ($^O eq 'os2' ? 'cmd /c more' : 'more'))) unless defined $pager; +setman(); &recallCommand("!") unless defined $prc; &shellBang("!") unless defined $psh; $maxtrace = 400 unless defined $maxtrace; -if (-e "/dev/tty") { +if (-e "/dev/tty") { # this is the wrong metric! $rcfile=".perldb"; } else { $rcfile="perldb.ini"; } +# This isn't really safe, because there's a race +# between checking and opening. The solution is to +# open and fstat the handle, but then you have to read and +# eval the contents. But then the silly thing gets +# your lexical scope, which is unfortunately at best. +sub safe_do { + my $file = shift; + + # Just exactly what part of the word "CORE::" don't you understand? + local $SIG{__WARN__}; + local $SIG{__DIE__}; + + unless (is_safe_file($file)) { + CORE::warn <' x $level) . - " "))) { + " "))) + { $single = 0; $signal = 0; $cmd =~ s/\\$/\n/ && do { @@ -511,7 +605,15 @@ EOP push(@hist,$cmd) if length($cmd) > 1; PIPE: { ($i) = split(/\s+/,$cmd); - eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; + #eval "\$cmd =~ $alias{$i}", print $OUT $@ if $alias{$i}; + if ($alias{$i}) { + print STDERR "ALIAS $cmd INTO "; + eval "\$cmd =~ $alias{$i}"; + print "$cmd\n"; + print $OUT $@; + } + $cmd =~ s/^\s+//s; # trim annoying leading whitespace + $cmd =~ s/\s+$//s; # trim annoying trailing whitespace $cmd =~ /^q$/ && ($exiting = 1) && exit 0; $cmd =~ /^h$/ && do { print_help($help); @@ -519,10 +621,14 @@ EOP $cmd =~ /^h\s+h$/ && do { print_help($summary); next CMD; }; - $cmd =~ /^h\s+(\S)$/ && do { - my $asked = "\Q$1"; - if ($help =~ /^(?:[IB]<)$asked/m) { - while ($help =~ /^((?:[IB]<)$asked([\s\S]*?)\n)(?!\s)/mg) { + # support long commands; otherwise bogus errors + # happen when you ask for h on for example + $cmd =~ /^h\s+(\S.*)$/ && do { + my $asked = $1; # for proper errmsg + my $qasked = quotemeta($asked); # for searching + # XXX: finds CR but not + if ($help =~ /^\s*(.*)/ && do { - $post = [], next CMD unless $1; + unless ($1) { + print OUT "All > actions cleared.\n"; + $post = []; + next CMD; + } + if ($1 eq '?') { + unless (@$post) { + print OUT "No post-prompt Perl actions.\n"; + next CMD; + } + print OUT "Perl commands run after each prompt:\n"; + for my $action ( @$post ) { + print "\t> -- $action\n"; + } + next CMD; + } $post = [action($1)]; next CMD; }; $cmd =~ /^\{\{\s*(.*)/ && do { + if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) { + print OUT "{{ is now a debugger command\n", + "use `;{{' if you mean Perl code\n"; + $cmd = "h {{"; + redo CMD; + } push @$pretype, $1; next CMD; }; $cmd =~ /^\{\s*(.*)/ && do { - $pretype = [], next CMD unless $1; + unless ($1) { + print OUT "All { actions cleared.\n"; + $pretype = []; + next CMD; + } + if ($1 eq '?') { + unless (@$pretype) { + print OUT "No pre-prompt debugger actions.\n"; + next CMD; + } + print OUT "Debugger commands run before each prompt:\n"; + for my $action ( @$pretype ) { + print "\t{ -- $action\n"; + } + next CMD; + } + if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) { + print OUT "{ is now a debugger command\n", + "use `;{' if you mean Perl code\n"; + $cmd = "h {"; + redo CMD; + } $pretype = [$1]; next CMD; }; - $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do { - $i = $1; $j = $3; - if ($dbline[$i] == 0) { - print $OUT "Line $i may not have an action.\n"; + $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do { + $i = $1 || $line; $j = $2; + if (length $j) { + if ($dbline[$i] == 0) { + print $OUT "Line $i may not have an action.\n"; + } else { + $had_breakpoints{$filename} |= 2; + $dbline{$i} =~ s/\0[^\0]*//; + $dbline{$i} .= "\0" . action($j); + } } else { $dbline{$i} =~ s/\0[^\0]*//; - $dbline{$i} .= "\0" . action($j); + delete $dbline{$i} if $dbline{$i} eq ''; } next CMD; }; $cmd =~ /^n$/ && do { @@ -906,7 +1087,7 @@ EOP if ($i) { $filename = $file; *dbline = $main::{'_<' . $filename}; - $had_breakpoints{$filename}++; + $had_breakpoints{$filename} |= 1; $max = $#dbline; ++$i while $dbline[$i] == 0 && $i < $max; } else { @@ -943,7 +1124,7 @@ EOP set_list("PERLDB_INC", @ini_INC); if ($0 eq '-e') { for (1..$#{'::_<-e'}) { # The first line is PERL5DB - chomp ($cl = $ {'::_<-e'}[$_]); + chomp ($cl = ${'::_<-e'}[$_]); push @script, '-e', $cl; } } else { @@ -1007,8 +1188,8 @@ EOP 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 "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS"; + exec $^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS; print $OUT "exec failed: $!\n"; last CMD; }; $cmd =~ /^T$/ && do { @@ -1045,7 +1226,7 @@ EOP $start = 1 if ($start > $max); last if ($start == $end); if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { - if ($emacs) { + if ($slave_editor) { print $OUT "\032\032$filename:$start:0\n"; } else { print $OUT "$start:\t", $dbline[$start], "\n"; @@ -1074,7 +1255,7 @@ EOP $start = $max if ($start <= 0); last if ($start == $end); if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) { - if ($emacs) { + if ($slave_editor) { print $OUT "\032\032$filename:$start:0\n"; } else { print $OUT "$start:\t", $dbline[$start], "\n"; @@ -1086,7 +1267,7 @@ EOP next CMD; }; $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do { pop(@hist) if length($cmd) > 1; - $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist); + $i = $1 ? ($#hist-($2||1)) : ($2||$#hist); $cmd = $hist[$i]; print $OUT $cmd, "\n"; redo CMD; }; @@ -1110,16 +1291,21 @@ EOP &system($ENV{SHELL}||"/bin/sh"); next CMD; }; $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do { + # XXX: using csh or tcsh destroys sigint retvals! + #&system($1); # use this instead &system($ENV{SHELL}||"/bin/sh","-c",$1); next CMD; }; $cmd =~ /^H\b\s*(-(\d+))?/ && do { - $end = $2?($#hist-$2):0; + $end = $2 ? ($#hist-$2) : 0; $hist = 0 if $hist < 0; for ($i=$#hist; $i>$end; $i--) { print $OUT "$i: ",$hist[$i],"\n" unless $hist[$i] =~ /^.?$/; }; next CMD; }; + $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do { + runman($1); + next CMD; }; $cmd =~ s/^p$/print {\$DB::OUT} \$_/; $cmd =~ s/^p\b/print {\$DB::OUT} /; $cmd =~ /^=/ && do { @@ -1143,25 +1329,29 @@ EOP } else { open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT"); } + fix_less(); unless ($piped=open(OUT,$pager)) { &warn("Can't pipe output to `$pager'"); if ($pager =~ /^\|/) { - open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); + open(OUT,">&STDOUT") # XXX: lost message + || &warn("Can't restore DB::OUT"); open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); close(SAVEOUT); } else { - open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); + open(OUT,">&STDOUT") # XXX: lost message + || &warn("Can't restore DB::OUT"); } next CMD; } $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/ - && "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE}; + && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE}); $selected= select(OUT); $|= 1; select( $selected ), $selected= "" unless $cmd =~ /^\|\|/; $cmd =~ s/^\|+\s*//; - redo PIPE; }; + redo PIPE; + }; # XXX Local variants do not work! $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'}; @@ -1176,14 +1366,27 @@ EOP } continue { # CMD: if ($piped) { if ($pager =~ /^\|/) { - $?= 0; close(OUT) || &warn("Can't close DB::OUT"); - &warn( "Pager `$pager' failed: ", - ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), - ( $? & 128 ) ? " (core dumped)" : "", - ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?; + $? = 0; + # we cannot warn here: the handle is missing --tchrist + close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; + + # most of the $? crud was coping with broken cshisms + if ($?) { + print SAVEOUT "Pager `$pager' failed: "; + if ($? == -1) { + print SAVEOUT "shell returned -1\n"; + } elsif ($? >> 8) { + print SAVEOUT + ( $? & 127 ) ? " (SIG#".($?&127).")" : "", + ( $? & 128 ) ? " -- core dumped" : "", "\n"; + } else { + print SAVEOUT "status ", ($? >> 8), "\n"; + } + } + open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT"); open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); - $SIG{PIPE}= "DEFAULT" if $SIG{PIPE} eq \&DB::catch; + $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; # Will stop ignoring SIGPIPE if done like nohup(1) # does SIGINT but Perl doesn't give us a choice. } else { @@ -1268,7 +1471,9 @@ sub save { # The following takes its argument via $evalarg to preserve current @_ sub eval { - local @res; # 'my' would make it visible from user code + # 'my' would make it visible from user code + # but so does local! --tchrist + local @res; { local $otrace = $trace; local $osingle = $single; @@ -1301,7 +1506,7 @@ sub postponed_sub { $i += $offset; local *dbline = $main::{'_<' . $file}; local $^W = 0; # != 0 is magical below - $had_breakpoints{$file}++; + $had_breakpoints{$file} |= 1; my $max = $#dbline; ++$i until $dbline[$i] != 0 or $i >= $max; $dbline{$i} = delete $postponed{$subname}; @@ -1329,11 +1534,11 @@ sub postponed { if $break_on_load{$filename}; print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame; return unless $postponed_file{$filename}; - $had_breakpoints{$filename}++; + $had_breakpoints{$filename} |= 1; #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic my $key; for $key (keys %{$postponed_file{$filename}}) { - $dbline{$key} = $ {$postponed_file{$filename}}{$key}; + $dbline{$key} = ${$postponed_file{$filename}}{$key}; } delete $postponed_file{$filename}; } @@ -1449,6 +1654,20 @@ sub action { $action; } +sub unbalanced { + # i hate using globals! + $balanced_brace_re ||= qr{ + ^ \{ + (?: + (?> [^{}] + ) # Non-parens without backtracking + | + (??{ $balanced_brace_re }) # Group with matching parens + ) * + \} $ + }x; + return $_[0] !~ m/$balanced_brace_re/; +} + sub gets { local($.); #; @@ -1457,19 +1676,30 @@ sub gets { sub system { # We save, change, then restore STDIN and STDOUT to avoid fork() since - # many non-Unix systems can do system() but have problems with fork(). + # some non-Unix systems can do system() but have problems with fork(). open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN"); open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT"); open(STDIN,"<&IN") || &warn("Can't redirect STDIN"); open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT"); + + # XXX: using csh or tcsh destroys sigint retvals! system(@_); open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN"); open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT"); - close(SAVEIN); close(SAVEOUT); - &warn( "(Command returned ", ($?>>8) > 128 ? ($?>>8)-256 : ($?>>8), ")", - ( $? & 128 ) ? " (core dumped)" : "", - ( $? & 127 ) ? " (SIG ".($?&127).")" : "", "\n" ) if $?; - $?; + close(SAVEIN); + close(SAVEOUT); + + + # most of the $? crud was coping with broken cshisms + if ($? >> 8) { + &warn("(Command exited ", ($? >> 8), ")\n"); + } elsif ($?) { + &warn( "(Command died of SIG#", ($? & 127), + (($? & 128) ? " -- core dumped" : "") , ")", "\n"); + } + + return $?; + } sub setterm { @@ -1558,7 +1788,7 @@ sub readline { if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) { print $OUT @_; my $stuff; - $IN->recv( $stuff, 2048 ); + $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread? $stuff; } else { @@ -1577,15 +1807,15 @@ sub option_val { my ($opt, $default)= @_; my $val; if (defined $optionVars{$opt} - and defined $ {$optionVars{$opt}}) { - $val = $ {$optionVars{$opt}}; + and defined ${$optionVars{$opt}}) { + $val = ${$optionVars{$opt}}; } elsif (defined $optionAction{$opt} and defined &{$optionAction{$opt}}) { $val = &{$optionAction{$opt}}(); } elsif (defined $optionAction{$opt} and not defined $option{$opt} or defined $optionVars{$opt} - and not defined $ {$optionVars{$opt}}) { + and not defined ${$optionVars{$opt}}) { $val = $default; } else { $val = $option{$opt}; @@ -1595,8 +1825,16 @@ sub option_val { sub parse_options { local($_)= @_; - while ($_ ne "") { - s/^(\w+)(\s*$|\W)// or print($OUT "Invalid option `$_'\n"), last; + # too dangerous to let intuitive usage overwrite important things + # defaultion should never be the default + my %opt_needs_val = map { ( $_ => 1 ) } qw{ + arrayDepth hashDepth LineInfo maxTraceLen noTTY ornaments + pager quote ReadLine recallCommand RemotePort ShellBang TTY + }; + while (length) { + my $val_defaulted; + s/^\s+// && next; + s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last; my ($opt,$sep) = ($1,$2); my $val; if ("?" eq $sep) { @@ -1604,59 +1842,83 @@ sub parse_options { if /^\S/; #&dump_option($opt); } elsif ($sep !~ /\S/) { - $val = "1"; + $val_defaulted = 1; + $val = "1"; # this is an evil default; make 'em set it! } elsif ($sep eq "=") { - s/^(\S*)($|\s+)//; + + if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { + my $quote = $1; + ($val = $2) =~ s/\\([$quote\\])/$1/g; + } else { + s/^(\S*)//; $val = $1; + print OUT qq(Option better cleared using $opt=""\n) + unless length $val; + } + } else { #{ to "let some poor schmuck bounce on the % key in B." my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #} s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or print($OUT "Unclosed option value `$opt$sep$_'\n"), last; - $val = $1; - $val =~ s/\\([\\$end])/$1/g; + ($val = $1) =~ s/\\([\\$end])/$1/g; } - my ($option); - my $matches = - grep( /^\Q$opt/ && ($option = $_), @options ); - $matches = grep( /^\Q$opt/i && ($option = $_), @options ) - unless $matches; - print $OUT "Unknown option `$opt'\n" unless $matches; - print $OUT "Ambiguous option `$opt'\n" if $matches > 1; - $option{$option} = $val if $matches == 1 and defined $val; - eval "local \$frame = 0; local \$doret = -2; - require '$optionRequire{$option}'" - if $matches == 1 and defined $optionRequire{$option} and defined $val; - $ {$optionVars{$option}} = $val - if $matches == 1 - and defined $optionVars{$option} and defined $val; - & {$optionAction{$option}} ($val) - if $matches == 1 - and defined $optionAction{$option} - and defined &{$optionAction{$option}} and defined $val; - &dump_option($option) if $matches == 1 && $OUT ne \*STDERR; # Not $rcfile - s/^\s+//; + + my $option; + my $matches = grep( /^\Q$opt/ && ($option = $_), @options ) + || grep( /^\Q$opt/i && ($option = $_), @options ); + + print($OUT "Unknown option `$opt'\n"), next unless $matches; + print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1; + + if ($opt_needs_val{$option} && $val_defaulted) { + print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n"; + next; + } + + $option{$option} = $val if defined $val; + + eval qq{ + local \$frame = 0; + local \$doret = -2; + require '$optionRequire{$option}'; + 1; + } || die # XXX: shouldn't happen + if defined $optionRequire{$option} && + defined $val; + + ${$optionVars{$option}} = $val + if defined $optionVars{$option} && + defined $val; + + &{$optionAction{$option}} ($val) + if defined $optionAction{$option} && + defined &{$optionAction{$option}} && + defined $val; + + # Not $rcfile + dump_option($option) unless $OUT eq \*STDERR; } } sub set_list { my ($stem,@list) = @_; my $val; - $ENV{"$ {stem}_n"} = @list; + $ENV{"${stem}_n"} = @list; for $i (0 .. $#list) { $val = $list[$i]; $val =~ s/\\/\\\\/g; $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg; - $ENV{"$ {stem}_$i"} = $val; + $ENV{"${stem}_$i"} = $val; } } sub get_list { my $stem = shift; my @list; - my $n = delete $ENV{"$ {stem}_n"}; + my $n = delete $ENV{"${stem}_n"}; my $val; for $i (0 .. $n - 1) { - $val = delete $ENV{"$ {stem}_$i"}; + $val = delete $ENV{"${stem}_$i"}; $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; push @list, $val; } @@ -1720,7 +1982,7 @@ sub RemotePort { } sub tkRunning { - if ($ {$term->Features}{tkRunning}) { + if (${$term->Features}{tkRunning}) { return $term->tkRunning(@_); } else { print $OUT "tkRunning not supported by current ReadLine package.\n"; @@ -1782,7 +2044,7 @@ sub LineInfo { return $lineinfo unless @_; $lineinfo = shift; my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo"; - $emacs = ($stream =~ /^\|/); + $slave_editor = ($stream =~ /^\|/); open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write"); $LINEINFO = \*LINEINFO; my $save = select($LINEINFO); @@ -1800,8 +2062,8 @@ sub list_versions { s,/,::,g ; s/^perl5db$/DB/; s/^Term::ReadLine::readline$/readline/; - if (defined $ { $_ . '::VERSION' }) { - $version{$file} = "$ { $_ . '::VERSION' } from "; + if (defined ${ $_ . '::VERSION' }) { + $version{$file} = "${ $_ . '::VERSION' } from "; } $version{$file} .= $INC{$file}; } @@ -1809,6 +2071,10 @@ sub list_versions { } sub sethelp { + # XXX: make sure these are tabs between the command and explantion, + # or print_help will screw up your formatting if you have + # eeevil ornaments enabled. This is an insane mess. + $help = " B Stack trace. B [I] Single step [in I]. @@ -1821,7 +2087,7 @@ 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 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. @@ -1844,7 +2110,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 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 @@ -1854,10 +2120,12 @@ B B I B [I] Delete the breakpoint for I. B Delete all breakpoints. B [I] I - Set an action to be done before the I is executed. + Set an action to be done before the I is executed; + I defaults to the current execution line. Sequence is: check for breakpoint/watchpoint, print line if necessary, do action, prompt user if necessary, - execute expression. + execute line. +B [I] Delete the action for I. B Delete all actions. B I Add a global watch-expression. B Delete all watch-expressions. @@ -1868,39 +2136,16 @@ B I Evals expression in array context, dumps the result. B I Evals expression in array context, prints methods callable on the first element of the result. B I Prints methods callable via the given class. -B [I[B<=>I]] [IB<\">IB<\">] [IB]... - Set or query values of options. I defaults to 1. I can - be abbreviated. Several options can be listed. - I, I: chars used to recall command or spawn shell; - I: program for output of \"|cmd\"; - 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. - I gives maximal length of evals/args listed in stack trace. - 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, I, and I there (or use - `B' after you set them). + +B<<> ? List Perl commands to run before each prompt. 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<>> ? List Perl commands to run after each prompt. B<>> I Define Perl command to run after each prompt. -B<>>B<>> I Add to the list of Perl commands to run after each prompt. +B<>>B<>> I Add to the list of Perl commands to run after each prompt. B<{> I Define debugger command to run before each prompt. +B<{> ? List debugger commands to run before each prompt. +B<<> I Define Perl command to run before each prompt. B<{{> I Add to the list of debugger commands to run before each prompt. B<$prc> I Redo a previous command (default previous command). B<$prc> I<-number> Redo number'th-to-last command. @@ -1922,13 +2167,49 @@ B Pure-man-restart of debugger, some of debugger state Currently the following setting are preserved: history, breakpoints and actions, debugger Bptions and the following command-line options: I<-w>, I<-I>, I<-e>. + +B [I] ... Set boolean option to true +B [IB] Query options +B [IB<=>I] [I=B<\">IB<\">] ... + Set options. Use quotes in spaces in value. + I, I chars used to recall command or spawn shell; + I program for output of \"|cmd\"; + 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; + Other options include: + 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. + I gives maximal length of evals/args listed in stack trace. + 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, I, and I there (or use + `B' after you set them). + +B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. 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 B<\$DB::finished = 0> to debug global destruction. +B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the + named Perl I, or on B<$doccmd> itself if omitted. + Set B<\$DB::doccmd> to change viewer. + +Type `|h' for a paged display if this was too hard to read. + +"; # Fix balance of vi % matching: } }} -"; $summary = <<"END_SUM"; I I B [I|I] List source code B Stack trace @@ -1952,18 +2233,71 @@ 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. +For more help, type B I, or run B<$doccmd perldebug> for all docs. END_SUM - # ')}}; # Fix balance of Emacs parsing + # ')}}; # Fix balance of vi % matching } 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; + local $_ = shift; + + # Restore proper alignment destroyed by eeevil I<> and B<> + # ornaments: A pox on both their houses! + # + # A help command will have everything up to and including + # the first tab sequence paddeed into a field 16 (or if indented 20) + # wide. If it's wide than that, an extra space will be added. + s{ + ^ # only matters at start of line + ( \040{4} | \t )* # some subcommands are indented + ( < ? # so works + [BI] < [^\t\n] + ) # find an eeevil ornament + ( \t+ ) # original separation, discarded + ( .* ) # this will now start (no earlier) than + # column 16 + } { + my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); + my $clean = $command; + $clean =~ s/[BI]<([^>]*)>/$1/g; + # replace with this whole string: + (length($leadwhite) ? " " x 4 : "") + . $command + . ((" " x (16 + (length($leadwhite) ? 4 : 0) - length($clean))) || " ") + . $text; + + }mgex; + + s{ # handle bold ornaments + B < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[2] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[3] + }gex; + + s{ # handle italic ornaments + I < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[0] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[1] + }gex; + + print $OUT $_; +} + +sub fix_less { + return if defined $ENV{LESS} && $ENV{LESS} =~ /r/; + my $is_less = $pager =~ /\bless\b/; + if ($pager =~ /\bmore\b/) { + my @st_more = stat('/usr/bin/more'); + my @st_less = stat('/usr/bin/less'); + $is_less = @st_more && @st_less + && $st_more[0] == $st_less[0] + && $st_more[1] == $st_less[1]; + } + # changes environment! + $ENV{LESS} .= 'r' if $is_less; } sub diesignal { @@ -2014,8 +2348,10 @@ sub dbdie { } 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); @@ -2122,18 +2458,81 @@ sub methods_via { my $prefix = shift; my $prepend = $prefix ? "via $prefix: " : ''; my $name; - for $name (grep {defined &{$ {"$ {class}::"}{$_}}} - sort keys %{"$ {class}::"}) { + 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"}) { + for $name (@{"${class}::ISA"}) { $prepend = $prefix ? $prefix . " -> $name" : $name; methods_via($name, $prepend, 1); } } +sub setman { + $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS)\z/s + ? "man" # O Happy Day! + : "perldoc"; # Alas, poor unfortunates +} + +sub runman { + my $page = shift; + unless ($page) { + &system("$doccmd $doccmd"); + return; + } + # this way user can override, like with $doccmd="man -Mwhatever" + # or even just "man " to disable the path check. + unless ($doccmd eq 'man') { + &system("$doccmd $page"); + return; + } + + $page = 'perl' if lc($page) eq 'help'; + + require Config; + my $man1dir = $Config::Config{'man1dir'}; + my $man3dir = $Config::Config{'man3dir'}; + for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ } + my $manpath = ''; + $manpath .= "$man1dir:" if $man1dir =~ /\S/; + $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; + chop $manpath if $manpath; + # harmless if missing, I figure + my $oldpath = $ENV{MANPATH}; + $ENV{MANPATH} = $manpath if $manpath; + my $nopathopt = $^O =~ /dunno what goes here/; + if (system($doccmd, + # I just *know* there are men without -M + (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), + split ' ', $page) ) + { + unless ($page =~ /^perl\w/) { + if (grep { $page eq $_ } qw{ + 5004delta 5005delta amiga api apio book boot bot call compile + cygwin data dbmfilter debug debguts delta diag doc dos dsc embed + faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork + form func guts hack hist hpux intern ipc lexwarn locale lol mod + modinstall modlib number obj op opentut os2 os390 pod port + ref reftut run sec style sub syn thrtut tie toc todo toot tootc + trap unicode var vms win32 xs xstut + }) + { + $page =~ s/^/perl/; + system($doccmd, + (($manpath && !$nopathopt) ? ("-M", $manpath) : ()), + $page); + } + } + } + if (defined $oldpath) { + $ENV{MANPATH} = $manpath; + } else { + delete $ENV{MANPATH}; + } +} + # The following BEGIN is very handy if debugger goes havoc, debugging debugger? BEGIN { # This does not compile, alas. @@ -2171,7 +2570,7 @@ sub db_complete { # Specific code for b c l V m f O, &blah, $blah, @blah, %blah my($text, $line, $start) = @_; my ($itext, $search, $prefix, $pack) = - ($text, "^\Q$ {'package'}::\E([^:]+)\$"); + ($text, "^\Q${'package'}::\E([^:]+)\$"); return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines (map { /$search/ ? ($1) : () } keys %sub)