Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Can't rely on NEXT_STEPPING_EVENT for $DB::single. So we write our ow…

…n checks.

This makes 'next' slower.
Save last thread id for 'next'ing.
remove_history(): need to set default value of $which.
  • Loading branch information...
commit 773436362d4ed6352e7985e4a3dd6d49154534b0 1 parent dde7f6d
Rocky Bernstein authored
87 lib/Devel/Trepan/CmdProcessor.pm
View
@@ -70,6 +70,7 @@ sub new($;$$$) {
$self->{DB_single} = $DB::single;
$self->{last_command} = undef;
$self->{leave_cmd_loop} = undef;
+ $self->{next_level} = 30000; # Virtually infinite;
$self->{settings} = hash_merge($settings, DEFAULT_SETTINGS());
# Initial watch point expr value used when a new watch point is set.
@@ -301,11 +302,22 @@ sub process_after_eval($) {
@DB::eval_result = undef;
}
+sub skip_if_next($$)
+{
+ my ($self, $event) = @_;
+ return 0 if ('line' ne $event);
+ return 0 if eval { no warnings; $DB::tid ne $self->{last_tid} };
+ # print "+++event $event ", $self->{stack_size}, " ",
+ # $self->{next_level}, "\n";
+ return 1 if $self->{stack_size} > $self->{next_level};
+}
+
# This is the main entry point.
sub process_commands($$$;$)
{
my ($self, $frame, $event, $arg) = @_;
$event = 'unknown' unless defined($event);
+ my $next_skip = 0;
if ($event eq 'after_eval' or $event eq 'after_nest') {
process_after_eval($self);
if ($event eq 'after_nest') {
@@ -334,45 +346,52 @@ sub process_commands($$$;$)
$arg->old_value($arg->current_val);
}
- $self->{unconditional_prehooks}->run;
- if (index($self->{event}, 'brkpt') < 0) {
- if ($self->is_stepping_skip()) {
- # || $self->{stack_size} <= $self->{hide_level};
- $self->{dbgr}->step;
- return;
- }
- if ($self->{settings}{traceprint}) {
- $self->{dbgr}->step;
- return;
+ $next_skip = skip_if_next($self, $event);
+ unless ($next_skip) {
+ $self->{unconditional_prehooks}->run;
+ if (index($self->{event}, 'brkpt') < 0) {
+ if ($self->is_stepping_skip()) {
+ # || $self->{stack_size} <= $self->{hide_level};
+ $self->{dbgr}->step;
+ return;
+ }
+ if ($self->{settings}{traceprint}) {
+ $self->{dbgr}->step;
+ return;
+ }
}
- }
- $self->{prompt} = compute_prompt($self);
- $self->print_location unless $self->{settings}{traceprint};
- ## $self->{eventbuf}->add_mark if $self->{settings}{tracebuffer};
-
- $self->{cmdloop_prehooks}->run;
+ $self->{prompt} = compute_prompt($self);
+ $self->print_location unless $self->{settings}{traceprint};
+ ## $self->{eventbuf}->add_mark if $self->{settings}{tracebuffer};
+
+ $self->{cmdloop_prehooks}->run;
+ }
}
- $self->{leave_cmd_loop} = 0;
- while (!$self->{leave_cmd_loop}) {
- # begin
- $self->process_command_and_quit;
- # rescue systemexit
- # @dbgr.stop
- # raise
- #rescue exception => exc
- # if we are inside the script interface $self->errmsg may fail.
- # begin
- # $self->errmsg("internal debugger error: #{exc.inspect}")
- # rescue ioerror
- # $stderr.puts "internal debugger error: #{exc.inspect}"
- # }
- # exception_dump(exc, @settings[:debugexcept], $!.backtrace)
- # }
+ unless ($next_skip) {
+ $self->{leave_cmd_loop} = 0;
+ while (!$self->{leave_cmd_loop}) {
+ # begin
+ $self->process_command_and_quit;
+ # rescue systemexit
+ # @dbgr.stop
+ # raise
+ #rescue exception => exc
+ # if we are inside the script interface $self->errmsg may fail.
+ # begin
+ # $self->errmsg("internal debugger error: #{exc.inspect}")
+ # rescue ioerror
+ # $stderr.puts "internal debugger error: #{exc.inspect}"
+ # }
+ # exception_dump(exc, @settings[:debugexcept], $!.backtrace)
+ # }
+ }
}
$self->{cmdloop_posthooks}->run;
- $DB::single = $self->{DB_single};
- $DB::running = $self->{DB_running};
+ $self->{last_tid} = $DB::tid;
+ $DB::single = $self->{DB_single};
+ $DB::running = $self->{DB_running};
+
}
# run current_command, a string. @last_command is set after the
6 lib/Devel/Trepan/CmdProcessor/Running.pm
View
@@ -102,7 +102,10 @@ sub next($$)
my ($self, $opts) = @_;
$self->{different_pos} = $opts->{different_pos};
$self->{leave_cmd_loop} = 1;
- $self->{DB_single} = NEXT_STEPPING_EVENT;
+ # NEXT_STEPPING_EVENT is sometimes broken.
+ # $self->{DB_single} = NEXT_STEPPING_EVENT;
+ $self->{next_level} = $self->{stack_size};
+ $self->{DB_single} = SINGLE_STEPPING_EVENT;
$self->{DB_running} = 1;
}
@@ -112,6 +115,7 @@ sub step($$)
$self->{different_pos} = $opts->{different_pos};
$self->{leave_cmd_loop} = 1;
$self->{DB_single} = SINGLE_STEPPING_EVENT;
+ $self->{next_level} = 30000; # Virtually infinite
$self->{DB_running} = 1;
}
18 lib/Devel/Trepan/DB.pm
View
@@ -12,7 +12,7 @@ use English qw( -no_match_vars );
use vars qw($usrctxt $running $caller
$event @ret $ret $return_value @return_value
- $stop @clients $ready
+ $stop @clients $ready $tid
$init_dollar0 $OS_STARTUP_DIR);
use Devel::Trepan::DB::Backtrace;
@@ -43,15 +43,16 @@ BEGIN {
# these are hardcoded in perl source (some are magical)
- $DB::sub = ''; # name of current subroutine
- $DB::single = 0; # single-step flags. See constants at the
+ $DB::sub = ''; # name of current subroutine
+ $DB::single = 0; # single-step flags. See constants at the
# top of DB/Sub.pm
- $DB::signal = 0; # signal flag (will cause a stop at the next line)
- $DB::stop = 0; # value of last breakpoint condition evaluation
+ $DB::signal = 0; # signal flag (will cause a stop at the next line)
+ $DB::stop = 0; # value of last breakpoint condition evaluation
+ $DB::tid = undef; # Thread id
- @DB::args = (); # arguments of current subroutine or @ARGV array
- @DB::dbline = (); # list of lines in currently loaded file
- %DB::dbline = (); # actions in current file (keyed by line number)
+ @DB::args = (); # arguments of current subroutine or @ARGV array
+ @DB::dbline = (); # list of lines in currently loaded file
+ %DB::dbline = (); # actions in current file (keyed by line number)
@DB::clients = ();
# other "public" globals
@@ -128,7 +129,6 @@ sub DB {
# lock the debugger and get the thread id for the prompt
lock($DBGR);
- my $tid;
if ($ENV{PERL5DB_THREADED}) {
$tid = eval { "[".threads->tid."]" };
}
1  lib/Devel/Trepan/Interface/User.pm
View
@@ -67,6 +67,7 @@ sub add_history($$)
sub remove_history($;$)
{
my ($self, $which) = @_;
+ $which = -1 unless defined($which);
return unless ($self->{input}{readline});
if ($self->{input}{readline}->can("where_history")) {
my $where_history = $self->{input}{readline}->where_history();
Please sign in to comment.
Something went wrong with that request. Please try again.