X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=9718fede67737bf0d07f9d22684f20e575de83bf;hb=864e1151dff76e2e8a34ce75279d790529b51d28;hp=fce77570f0404059b2d9bac96fd4d6b154620c57;hpb=8ebc5c0145d2e3559bce3073437e6d027dcdffcc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index fce7757..9718fed 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 = 0.9801; +$VERSION = 0.9909; $header = "perl5db.pl patch level $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -24,7 +24,7 @@ $header = "perl5db.pl patch level $VERSION"; # {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). # @@ -33,16 +33,16 @@ $header = "perl5db.pl patch level $VERSION"; # 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 of the package DB). In fact the same is @@ -137,6 +137,11 @@ $header = "perl5db.pl patch level $VERSION"; # `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'). #################################################################### @@ -152,7 +157,6 @@ warn ( # Do not ;-) $dumpvar::quoteHighBit, $dumpvar::printUndef, $dumpvar::globPrint, - $readline::Tk_toloop, $dumpvar::usageOnly, @ARGS, $Carp::CarpLevel, @@ -184,7 +188,6 @@ $inhibit_exit = $option{PrintRet} = 1; HighBit => \$dumpvar::quoteHighBit, undefPrint => \$dumpvar::printUndef, globPrint => \$dumpvar::globPrint, - tkRunning => \$readline::Tk_toloop, UsageOnly => \$dumpvar::usageOnly, frame => \$frame, AutoTrace => \$trace, @@ -207,6 +210,7 @@ $inhibit_exit = $option{PrintRet} = 1; signalLevel => \&signalLevel, warnLevel => \&warnLevel, dieLevel => \&dieLevel, + tkRunning => \&tkRunning, ); %optionRequire = ( @@ -257,7 +261,8 @@ if (exists $ENV{PERLDB_RESTART}) { %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); @@ -406,7 +411,9 @@ sub DB { $evalarg = $action, &eval if $action; 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; @@ -423,12 +430,12 @@ sub DB { $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; next CMD; }; @@ -484,6 +491,7 @@ sub DB { $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"; @@ -491,8 +499,9 @@ sub DB { } 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}) { @@ -504,12 +513,17 @@ sub DB { $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(/:/,find_sub($subname)); $subrange = pop @pieces; @@ -638,12 +652,11 @@ sub DB { 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" @@ -663,7 +676,7 @@ sub DB { } 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}; @@ -844,12 +857,12 @@ sub DB { for (0 .. $#had_breakpoints) { my $file = $had_breakpoints[$_]; *dbline = $main::{'_<' . $file}; - next unless %dbline or %{$postponed_file{$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... @@ -1063,7 +1076,9 @@ sub DB { } } # CMD: $exiting = 1 unless defined $cmd; - map {$evalarg = $_; &eval} @$post; + foreach $evalarg (@$post) { + &eval; + } } # if ($single || $signal) ($@, $!, $,, $/, $\, $^W) = @saved; (); @@ -1074,8 +1089,8 @@ sub DB { sub sub { my ($al, $ret, @ret) = ""; - if ($sub =~ /(.*)::AUTOLOAD$/) { - $al = " for $ {$1 . '::AUTOLOAD'}"; + if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') { + $al = " for $$sub"; } push(@stack, $single); $single &= 1; @@ -1088,22 +1103,24 @@ sub sub { if (wantarray) { @ret = &$sub; $single |= pop(@stack); - print ($OUT "list context return from $sub:\n"), dumpit( \@ret ), - $doret = -2 if $doret eq $#stack; ($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; $single |= pop(@stack); - print ($OUT "scalar context return from $sub: "), dumpit( $ret ), - $doret = -2 if $doret eq $#stack; ($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; } } @@ -1172,14 +1189,14 @@ sub postponed { $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}}; + 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 { @@ -1343,15 +1360,13 @@ sub setterm { } 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; @@ -1510,6 +1525,15 @@ sub ReadLine { $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 @_; @@ -1722,11 +1746,14 @@ sub diesignal { 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', $$; } @@ -1857,7 +1884,7 @@ sub methods_via { my $name; for $name (grep {defined &{$ {"$ {class}::"}{$_}}} sort keys %{"$ {class}::"}) { - next if $seen{ \&{$ {"$ {class}::"}{$name}} }++; + next if $seen{ $name }++; print $DB::OUT "$prepend$name\n"; } return unless shift; # Recurse? @@ -1900,13 +1927,40 @@ BEGIN {$^W = $ini_warn;} # Switch warnings back #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) . '::'; @@ -1917,7 +1971,7 @@ sub db_complete { 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) . '::'; @@ -1929,13 +1983,9 @@ sub db_complete { 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 compile) # subroutines - if (substr $line, 0, $start) =~ /^[bl]\s+((postpone|compile)\s+)?$/; - return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages - if (substr $line, 0, $start) =~ /^V\s+$/; - if ((substr $line, 0, $start) =~ /^O\b.*\s$/) { # Options after a space + 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 = '? '; @@ -1950,12 +2000,10 @@ sub db_complete { $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 and `R' to restart. `h q' for details.\n" }