X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fperl5db.pl;h=9718fede67737bf0d07f9d22684f20e575de83bf;hb=864e1151dff76e2e8a34ce75279d790529b51d28;hp=38ae29763e6fa2ff1af9d12fb483e4e0e5a1d7de;hpb=08a4aec0f8cf03ed75a2a45bbd19128b4b70440a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 38ae297..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.9904; +$VERSION = 0.9909; $header = "perl5db.pl patch level $VERSION"; # Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) @@ -157,7 +157,6 @@ warn ( # Do not ;-) $dumpvar::quoteHighBit, $dumpvar::printUndef, $dumpvar::globPrint, - $readline::Tk_toloop, $dumpvar::usageOnly, @ARGS, $Carp::CarpLevel, @@ -189,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, @@ -212,6 +210,7 @@ $inhibit_exit = $option{PrintRet} = 1; signalLevel => \&signalLevel, warnLevel => \&warnLevel, dieLevel => \&dieLevel, + tkRunning => \&tkRunning, ); %optionRequire = ( @@ -262,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); @@ -411,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; @@ -650,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) { + for $line (sort {$a <=> $b} keys %$db) { print $OUT " $line:\n"; - my ($stop,$action) = split(/\0/, $db{$line}); + my ($stop,$action) = split(/\0/, $$db{$line}); print $OUT " break if (", $stop, ")\n" if $stop; print $OUT " action: ", $action, "\n" @@ -856,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... @@ -1075,7 +1076,9 @@ sub DB { } } # CMD: $exiting = 1 unless defined $cmd; - map {$evalarg = $_; &eval} @$post; + foreach $evalarg (@$post) { + &eval; + } } # if ($single || $signal) ($@, $!, $,, $/, $\, $^W) = @saved; (); @@ -1086,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; @@ -1100,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; } } @@ -1184,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 { @@ -1355,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; @@ -1522,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 @_; @@ -1734,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', $$; } @@ -1985,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 : '? '); + $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" }