line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# -*- coding: utf-8 -*- |
2
|
|
|
|
|
|
|
# Copyright (C) 2011-2015 Rocky Bernstein <rocky@cpan.org> |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
# A debugger command processor. This includes the debugger commands |
5
|
|
|
|
|
|
|
# and ties together the debugger core and I/O interface. |
6
|
|
|
|
|
|
|
package Devel::Trepan::CmdProcessor; |
7
|
|
|
|
|
|
|
|
8
|
12
|
|
|
12
|
|
10649
|
use English qw( -no_match_vars ); |
|
12
|
|
|
|
|
1674
|
|
|
12
|
|
|
|
|
88
|
|
9
|
12
|
|
|
12
|
|
4038
|
use warnings; no warnings 'redefine'; |
|
12
|
|
|
12
|
|
37
|
|
|
12
|
|
|
|
|
389
|
|
|
12
|
|
|
|
|
97
|
|
|
12
|
|
|
|
|
25
|
|
|
12
|
|
|
|
|
582
|
|
10
|
|
|
|
|
|
|
|
11
|
12
|
|
|
12
|
|
94
|
use vars qw(@ISA $eval_result); |
|
12
|
|
|
|
|
28
|
|
|
12
|
|
|
|
|
690
|
|
12
|
|
|
|
|
|
|
|
13
|
12
|
|
|
12
|
|
79
|
use rlib '../..'; |
|
12
|
|
|
|
|
26
|
|
|
12
|
|
|
|
|
92
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# Showing eval results can be done using either data dump package. |
16
|
|
|
|
|
|
|
unless (@ISA) { |
17
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Complete; |
18
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Load; |
19
|
|
|
|
|
|
|
require Devel::Trepan::BrkptMgr; |
20
|
|
|
|
|
|
|
eval {require Devel::Trepan::DB::Display}; |
21
|
|
|
|
|
|
|
require Devel::Trepan::Interface::User; |
22
|
|
|
|
|
|
|
require Devel::Trepan::Processor; |
23
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Alias; |
24
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Default; |
25
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Msg; |
26
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Help; |
27
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Hook; |
28
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Frame; |
29
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Location; |
30
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Eval; |
31
|
|
|
|
|
|
|
require Devel::Trepan::CmdProcessor::Validate; |
32
|
|
|
|
|
|
|
} |
33
|
12
|
|
|
12
|
|
6092
|
use strict; |
|
12
|
|
|
|
|
27
|
|
|
12
|
|
|
|
|
326
|
|
34
|
|
|
|
|
|
|
|
35
|
12
|
|
|
12
|
|
883
|
use Devel::Trepan::Util qw(hash_merge uniq_abbrev parse_eval_sigil); |
|
12
|
|
|
|
|
31
|
|
|
12
|
|
|
|
|
887
|
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
@ISA = qw(Devel::Trepan::Processor); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
BEGIN { |
40
|
12
|
|
|
12
|
|
78
|
no warnings; |
|
12
|
|
|
|
|
105
|
|
|
12
|
|
|
|
|
434
|
|
41
|
12
|
|
|
12
|
|
12346
|
@DB::D = (); # Place to save eval results; |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub new { |
45
|
13
|
|
|
13
|
0
|
199
|
my ($class, $interfaces, $dbgr, $settings) = @_; |
46
|
13
|
|
|
|
|
37
|
my $intf; |
47
|
13
|
100
|
|
|
|
86
|
if (defined $interfaces) { |
48
|
2
|
|
|
|
|
8
|
$intf = $interfaces->[0]; |
49
|
|
|
|
|
|
|
} else { |
50
|
|
|
|
|
|
|
$intf = Devel::Trepan::Interface::User->new(undef, undef, |
51
|
|
|
|
|
|
|
{readline => |
52
|
11
|
|
|
|
|
176
|
$settings->{readline}}); |
53
|
11
|
|
|
|
|
72
|
$interfaces = [$intf]; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
13
|
|
100
|
|
|
85
|
$settings ||= {}; |
57
|
13
|
|
|
|
|
145
|
my $self = { |
58
|
|
|
|
|
|
|
class => $class, |
59
|
|
|
|
|
|
|
interfaces => $interfaces, |
60
|
|
|
|
|
|
|
settings => $settings, |
61
|
|
|
|
|
|
|
}; |
62
|
13
|
|
|
|
|
90
|
bless ($self, $class); |
63
|
|
|
|
|
|
|
|
64
|
13
|
|
|
|
|
201
|
$self->{actions} = Devel::Trepan::BrkptMgr->new($dbgr); |
65
|
13
|
|
|
|
|
87
|
$self->{brkpts} = Devel::Trepan::BrkptMgr->new($dbgr); |
66
|
13
|
|
|
|
|
211
|
$self->{displays} = Devel::Trepan::DB::DisplayMgr->new($dbgr); |
67
|
13
|
|
|
|
|
61
|
$self->{completions} = []; |
68
|
13
|
|
|
|
|
70
|
$self->{dbgr} = $dbgr; |
69
|
13
|
|
|
|
|
71
|
$self->{event} = undef; |
70
|
13
|
|
|
|
|
56
|
$self->{cmd_queue} = []; |
71
|
13
|
|
|
|
|
53
|
$self->{DB_running} = $DB::running; |
72
|
13
|
|
|
|
|
94
|
$self->{DB_single} = $DB::single; |
73
|
13
|
|
|
|
|
52
|
$self->{last_command} = undef; |
74
|
13
|
|
|
|
|
53
|
$self->{leave_cmd_loop} = undef; |
75
|
13
|
|
|
|
|
60
|
$self->{next_level} = 30000; # Virtually infinite; |
76
|
13
|
|
|
|
|
192
|
$self->{settings} = hash_merge($settings, DEFAULT_SETTINGS()); |
77
|
13
|
|
|
|
|
69
|
$self->{terminated} = 0; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# Initial watch point expr value used when a new watch point is set. |
80
|
|
|
|
|
|
|
# Set in 'watch' command, and reset here after we get the value back. |
81
|
13
|
|
|
|
|
56
|
$self->{set_wp} = undef; |
82
|
|
|
|
|
|
|
|
83
|
13
|
|
|
|
|
58
|
$self->{skip_count} = 0; |
84
|
13
|
|
|
|
|
143
|
$self->load_cmds_initialize; |
85
|
13
|
|
|
|
|
229
|
$self->running_initialize; |
86
|
13
|
|
|
|
|
1222
|
$self->hook_initialize; |
87
|
|
|
|
|
|
|
$self->{unconditional_prehooks}->insert_if_new(10, |
88
|
|
|
|
|
|
|
$self->{trace_hook}[0], |
89
|
|
|
|
|
|
|
$self->{trace_hook}[1] |
90
|
13
|
50
|
|
|
|
106
|
) if $self->{settings}{traceprint}; |
91
|
|
|
|
|
|
|
|
92
|
13
|
50
|
|
|
|
128
|
if ($intf->has_completion) { |
93
|
|
|
|
|
|
|
my $list_completion = sub { |
94
|
0
|
|
|
0
|
|
0
|
my($text, $state) = @_; |
95
|
0
|
|
|
|
|
0
|
$self->list_complete($text, $state); |
96
|
13
|
|
|
|
|
91
|
}; |
97
|
|
|
|
|
|
|
my $completion = sub { |
98
|
0
|
|
|
0
|
|
0
|
my ($text, $line, $start, $end) = @_; |
99
|
0
|
|
|
|
|
0
|
$self->complete($text, $line, $start, $end); |
100
|
13
|
|
|
|
|
77
|
}; |
101
|
13
|
|
|
|
|
111
|
$intf->set_completion($completion, $list_completion); |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
# $B::Data::Dumper::Deparse = 1; |
104
|
13
|
|
|
|
|
239
|
return $self; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub set_prompt($) |
108
|
|
|
|
|
|
|
{ |
109
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
110
|
0
|
|
|
|
|
|
my $thread_str = ''; |
111
|
|
|
|
|
|
|
# if (1 == Thread.list.size) { |
112
|
|
|
|
|
|
|
# $thread_str = ''; |
113
|
|
|
|
|
|
|
# } elsif (Thread.current == Thread.main) { |
114
|
|
|
|
|
|
|
# $thread_str = '@main'; |
115
|
|
|
|
|
|
|
# } else { |
116
|
|
|
|
|
|
|
# $thread_str = "@#{Thread.current.object_id}"; |
117
|
|
|
|
|
|
|
# } |
118
|
0
|
|
|
|
|
|
my $prompt = sprintf("%s$self->{settings}{prompt}%s%s: ", |
119
|
|
|
|
|
|
|
'(' x $DB::level, $thread_str, ')' x $DB::level); |
120
|
0
|
|
|
|
|
|
return $prompt; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub terminated($) |
124
|
|
|
|
|
|
|
{ |
125
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
126
|
0
|
0
|
|
|
|
|
$self->msg(sprintf("%sThat's all, folks...", |
127
|
|
|
|
|
|
|
(defined($Devel::Trepan::PROGRAM) ? |
128
|
|
|
|
|
|
|
"${Devel::Trepan::PROGRAM}: " : ''))); |
129
|
0
|
|
|
|
|
|
foreach my $interface (@{$self->{interfaces}}) { |
|
0
|
|
|
|
|
|
|
130
|
0
|
|
|
|
|
|
$interface->close(); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
# breakpoint_finalize |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# Check that we meet the criteria that cmd specifies it needs |
136
|
|
|
|
|
|
|
sub ok_for_running ($$$$) { |
137
|
0
|
|
|
0
|
0
|
|
my ($self, $cmd, $name, $nargs) = @_; |
138
|
|
|
|
|
|
|
# TODO check execution_set against execution status. |
139
|
|
|
|
|
|
|
# Check we have frame is not null |
140
|
0
|
|
0
|
|
|
|
my $min_args = eval { $cmd->MIN_ARGS } || 0; |
141
|
0
|
0
|
|
|
|
|
if ($nargs < $min_args) { |
142
|
0
|
|
|
|
|
|
my $msg = |
143
|
|
|
|
|
|
|
sprintf("Command '%s' needs at least %d argument(s); " . |
144
|
|
|
|
|
|
|
"got %d.", $name, $min_args, $nargs); |
145
|
0
|
|
|
|
|
|
$self->errmsg($msg); |
146
|
0
|
|
|
|
|
|
return; |
147
|
|
|
|
|
|
|
} |
148
|
0
|
|
0
|
|
|
|
my $max_args = eval { $cmd->MAX_ARGS } || undef; |
149
|
0
|
0
|
0
|
|
|
|
if (defined($max_args) && $nargs > $max_args) { |
150
|
0
|
|
|
|
|
|
my $mess = |
151
|
|
|
|
|
|
|
sprintf("Command '%s' needs at most %d argument(s); " . |
152
|
|
|
|
|
|
|
"got %d.", $name, $max_args, $nargs); |
153
|
0
|
|
|
|
|
|
$self->errmsg($mess); |
154
|
0
|
|
|
|
|
|
return; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
0
|
0
|
0
|
|
|
|
if ($cmd->NEED_STACK && $self->{terminated}) { |
158
|
0
|
|
|
|
|
|
$self->errmsg("Command '$name' requires a running program."); |
159
|
0
|
|
|
|
|
|
return; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
0
|
0
|
0
|
|
|
|
if ($cmd->NEED_STACK && !defined $self->{frame}) { |
163
|
0
|
|
|
|
|
|
$self->errmsg("Command '$name' requires a running stack frame."); |
164
|
0
|
|
|
|
|
|
return; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
0
|
|
|
|
|
|
return 1; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Run one debugger command. 1 is returned if we want to quit. |
171
|
|
|
|
|
|
|
sub process_command_and_quit($) |
172
|
|
|
|
|
|
|
{ |
173
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
174
|
0
|
|
|
|
|
|
my $intf_ary = $self->{interfaces}; |
175
|
0
|
|
|
|
|
|
my $intf = $intf_ary->[-1]; |
176
|
0
|
|
|
|
|
|
my $intf_size = scalar @{$intf_ary}; |
|
0
|
|
|
|
|
|
|
177
|
0
|
0
|
0
|
|
|
|
return 1 if !defined $intf || $intf->is_input_eof && $intf_size == 1; |
|
|
|
0
|
|
|
|
|
178
|
0
|
|
0
|
|
|
|
while ($intf_size > 1 || !$intf->is_input_eof) { |
179
|
|
|
|
|
|
|
# begin |
180
|
0
|
|
|
|
|
|
$self->{current_command} = ''; |
181
|
0
|
|
|
|
|
|
my @cmd_queue = @{$self->{cmd_queue}}; |
|
0
|
|
|
|
|
|
|
182
|
0
|
0
|
|
|
|
|
if (scalar(@cmd_queue) == 0) { |
183
|
|
|
|
|
|
|
# Leave trailing blanks on for the "complete" command |
184
|
0
|
|
0
|
|
|
|
$self->{current_command} = $self->read_command() || ''; |
185
|
0
|
0
|
|
|
|
|
if ($intf->is_input_eof) { |
186
|
0
|
0
|
|
|
|
|
if ($intf_size > 1) { |
187
|
0
|
|
|
|
|
|
pop @$intf_ary; |
188
|
0
|
|
|
|
|
|
$intf_size = scalar @$intf_ary; |
189
|
0
|
|
|
|
|
|
$intf = $intf_ary->[-1]; |
190
|
0
|
|
|
|
|
|
$self->{last_command} = ''; |
191
|
|
|
|
|
|
|
# $self->print_location; |
192
|
|
|
|
|
|
|
} else { |
193
|
|
|
|
|
|
|
## FIXME: think of something better. |
194
|
0
|
|
|
|
|
|
$self->run_command("quit!"); |
195
|
0
|
|
|
|
|
|
return 1; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
} |
198
|
0
|
|
|
|
|
|
chomp $self->{current_command}; |
199
|
|
|
|
|
|
|
} else { |
200
|
0
|
|
|
|
|
|
$self->{current_command} = shift @cmd_queue; |
201
|
0
|
|
|
|
|
|
$self->{cmd_queue} = \@cmd_queue; |
202
|
|
|
|
|
|
|
} |
203
|
0
|
0
|
|
|
|
|
if ('' eq $self->{current_command}) { |
204
|
0
|
0
|
0
|
|
|
|
next unless $self->{last_command} && $intf->is_interactive; |
205
|
0
|
|
|
|
|
|
$self->{current_command} = $self->{last_command}; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
# Skip comment lines |
208
|
0
|
0
|
|
|
|
|
next if substr($self->{current_command}, 0, 1) eq '#'; |
209
|
0
|
|
|
|
|
|
last; |
210
|
|
|
|
|
|
|
# rescue IOError, Errno::EPIPE => e |
211
|
|
|
|
|
|
|
# } |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
0
|
|
|
|
|
|
eval { |
215
|
0
|
|
|
|
|
|
$self->run_command($self->{current_command}); |
216
|
|
|
|
|
|
|
}; |
217
|
0
|
0
|
|
|
|
|
if ($EVAL_ERROR) { |
218
|
0
|
|
|
|
|
|
$self->errmsg("internal error: $EVAL_ERROR") |
219
|
|
|
|
|
|
|
} else { |
220
|
|
|
|
|
|
|
# Save it to the history. |
221
|
|
|
|
|
|
|
$intf->add_history($self->{last_command}) if |
222
|
0
|
0
|
|
|
|
|
$self->{last_command}; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
sub skip_if_next($$) |
227
|
|
|
|
|
|
|
{ |
228
|
0
|
|
|
0
|
0
|
|
my ($self, $event) = @_; |
229
|
0
|
0
|
|
|
|
|
return 0 if ('line' ne $event); |
230
|
0
|
0
|
|
|
|
|
return 0 if $self->{terminated}; |
231
|
12
|
0
|
|
12
|
|
99
|
return 0 if eval { no warnings; $DB::tid ne $self->{last_tid} }; |
|
12
|
|
|
|
|
58
|
|
|
12
|
|
|
|
|
11817
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# print "+++event $event ", $self->{stack_size}, " ", |
233
|
|
|
|
|
|
|
# $self->{next_level}, "\n"; |
234
|
0
|
0
|
|
|
|
|
return 1 if $self->{stack_size} > $self->{next_level}; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
# This is the main entry point. |
238
|
|
|
|
|
|
|
sub process_commands($$$;$) |
239
|
|
|
|
|
|
|
{ |
240
|
0
|
|
|
0
|
0
|
|
my ($self, $frame, $event, $arg) = @_; |
241
|
|
|
|
|
|
|
|
242
|
0
|
0
|
|
|
|
|
if ($event eq 'terminated') { |
|
|
0
|
|
|
|
|
|
243
|
0
|
|
|
|
|
|
$self->{terminated} = 1; |
244
|
0
|
|
|
|
|
|
$self->section("Debugged program terminated. Use 'q' to quit or 'R' to restart."); |
245
|
|
|
|
|
|
|
} elsif (!defined($event)) { |
246
|
0
|
|
|
|
|
|
$event = 'unknown'; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
0
|
|
|
|
|
|
my $next_skip = 0; |
250
|
0
|
0
|
0
|
|
|
|
if ($event eq 'after_eval' or $event eq 'after_nest') { |
251
|
0
|
|
|
|
|
|
$self->handle_eval_result(); |
252
|
0
|
0
|
|
|
|
|
if ($event eq 'after_nest') { |
253
|
0
|
|
|
|
|
|
$self->msg("Leaving nested debug level $DB::level"); |
254
|
0
|
|
|
|
|
|
$self->{prompt} = set_prompt($self); |
255
|
0
|
|
|
|
|
|
$self->frame_setup(); |
256
|
0
|
|
|
|
|
|
$self->print_location; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} else { |
259
|
0
|
|
|
|
|
|
$self->{completions} = []; |
260
|
0
|
|
|
|
|
|
$self->{event} = $event; |
261
|
0
|
|
|
|
|
|
$self->frame_setup(); |
262
|
|
|
|
|
|
|
|
263
|
0
|
0
|
|
|
|
|
if ($event eq 'watch') { |
264
|
0
|
|
|
|
|
|
my $msg = sprintf("Watchpoint %s: %s changed", |
265
|
|
|
|
|
|
|
$arg->id, $arg->expr); |
266
|
0
|
|
|
|
|
|
$self->section($msg); |
267
|
0
|
0
|
|
|
|
|
my $old_value = defined($arg->old_value) ? $arg->old_value |
268
|
|
|
|
|
|
|
: 'undef'; |
269
|
0
|
|
|
|
|
|
$msg = sprintf("old value\t%s", $old_value); |
270
|
0
|
|
|
|
|
|
$self->msg($msg); |
271
|
0
|
0
|
|
|
|
|
my $new_value = defined($arg->current_val) ? $arg->current_val |
272
|
|
|
|
|
|
|
: 'undef'; |
273
|
0
|
|
|
|
|
|
$msg = sprintf("new value\t%s", $new_value); |
274
|
0
|
|
|
|
|
|
$self->msg($msg); |
275
|
0
|
|
|
|
|
|
$arg->old_value($arg->current_val); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
0
|
|
|
|
|
|
$next_skip = skip_if_next($self, $event); |
279
|
0
|
0
|
|
|
|
|
unless ($next_skip) { |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
# prehooks include traceprint, list, and event saving. |
282
|
0
|
|
|
|
|
|
$self->{unconditional_prehooks}->run; |
283
|
|
|
|
|
|
|
|
284
|
0
|
0
|
0
|
|
|
|
if (index($self->{event}, 'brkpt') < 0 && !$self->{terminated}) { |
285
|
|
|
|
|
|
|
# Not a breakpoint and not terminated. |
286
|
|
|
|
|
|
|
|
287
|
0
|
0
|
|
|
|
|
if ($event eq 'line') { |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# We may want to not stop because of "step n"; step different, or |
290
|
|
|
|
|
|
|
# "next" |
291
|
|
|
|
|
|
|
# use Enbugger; Enbugger->stop if 2 == $self->{next_level}; |
292
|
0
|
0
|
|
|
|
|
if ($self->is_stepping_skip()) { |
293
|
|
|
|
|
|
|
# || $self->{stack_size} <= $self->{hide_level}; |
294
|
0
|
|
|
|
|
|
$self->{dbgr}->step; |
295
|
0
|
|
|
|
|
|
return; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
# trace print sets stepping even when though otherwise |
298
|
|
|
|
|
|
|
# we may be are continuing, nexting, finishing, or |
299
|
|
|
|
|
|
|
# returning. |
300
|
0
|
0
|
|
|
|
|
if ($self->{settings}{traceprint}) { |
301
|
0
|
|
|
|
|
|
$self->{dbgr}->step; |
302
|
0
|
0
|
|
|
|
|
return unless 0 == $self->{skip_count}; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
|
307
|
0
|
|
|
|
|
|
$self->{prompt} = set_prompt($self); |
308
|
|
|
|
|
|
|
$self->print_location unless $self->{settings}{traceprint} || |
309
|
0
|
0
|
0
|
|
|
|
$self->{terminated}; |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
## $self->{eventbuf}->add_mark if $self->{settings}{tracebuffer}; |
312
|
|
|
|
|
|
|
|
313
|
0
|
|
|
|
|
|
$self->{cmdloop_prehooks}->run; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
} |
316
|
0
|
0
|
|
|
|
|
unless ($next_skip) { |
317
|
|
|
|
|
|
|
# Individual commands force a leave from by the below loop by |
318
|
|
|
|
|
|
|
# setting leave_cmd_loop. |
319
|
0
|
|
|
|
|
|
$self->{leave_cmd_loop} = 0; |
320
|
0
|
|
|
|
|
|
while (!$self->{leave_cmd_loop}) { |
321
|
|
|
|
|
|
|
# begin |
322
|
0
|
|
|
|
|
|
$self->process_command_and_quit; |
323
|
|
|
|
|
|
|
# rescue systemexit |
324
|
|
|
|
|
|
|
# @dbgr.stop |
325
|
|
|
|
|
|
|
# raise |
326
|
|
|
|
|
|
|
#rescue exception => exc |
327
|
|
|
|
|
|
|
# if we are inside the script interface $self->errmsg may fail. |
328
|
|
|
|
|
|
|
# begin |
329
|
|
|
|
|
|
|
# $self->errmsg("internal debugger error: #{exc.inspect}") |
330
|
|
|
|
|
|
|
# rescue ioerror |
331
|
|
|
|
|
|
|
# $stderr.puts "internal debugger error: #{exc.inspect}" |
332
|
|
|
|
|
|
|
# } |
333
|
|
|
|
|
|
|
# exception_dump(exc, @settings[:debugexcept], $!.backtrace) |
334
|
|
|
|
|
|
|
# } |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
} |
337
|
0
|
0
|
|
|
|
|
if ($self->{terminated}) { |
338
|
0
|
|
|
|
|
|
$DB::running = $self->{DB_running}; |
339
|
|
|
|
|
|
|
} else { |
340
|
0
|
|
|
|
|
|
$self->{cmdloop_posthooks}->run; |
341
|
0
|
|
|
|
|
|
$self->{last_tid} = $DB::tid; |
342
|
0
|
|
|
|
|
|
$DB::running = $self->{DB_running}; |
343
|
0
|
|
|
|
|
|
$DB::single = $self->{DB_single}; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
# run current_command, a string. @last_command is set after the |
348
|
|
|
|
|
|
|
# command is run if it is a command. |
349
|
|
|
|
|
|
|
sub run_command($$) |
350
|
|
|
|
|
|
|
{ |
351
|
0
|
|
|
0
|
0
|
|
my ($self, $current_command) = @_; |
352
|
0
|
|
|
|
|
|
my $eval_command = undef; |
353
|
0
|
|
|
|
|
|
my $cmd_name = undef; |
354
|
0
|
|
|
|
|
|
my @cmd_queue = @{$self->{cmd_queue}}; |
|
0
|
|
|
|
|
|
|
355
|
0
|
0
|
|
|
|
|
unless ($eval_command) { |
356
|
0
|
|
|
|
|
|
my @commands = split(';;', $current_command); |
357
|
0
|
0
|
|
|
|
|
if (scalar(@commands) > 1) { |
358
|
0
|
|
|
|
|
|
$current_command = shift @commands; |
359
|
0
|
|
|
|
|
|
$self->{cmd_queue} = \(@cmd_queue, @commands); |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
# Split on space trimming leading space. Note ' ' rather than say \s+ |
363
|
|
|
|
|
|
|
# which splits on leading spaces among others. |
364
|
0
|
|
|
|
|
|
my @args = split(' ', $current_command); |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
# Expand macros. FIXME: put in a procedure |
367
|
0
|
|
|
|
|
|
while (1) { |
368
|
0
|
0
|
|
|
|
|
return if scalar(@args) == 0; |
369
|
0
|
|
|
|
|
|
my $macro_cmd_name = $args[0]; |
370
|
0
|
0
|
|
|
|
|
last unless $self->{macros}{$macro_cmd_name}; |
371
|
0
|
|
|
|
|
|
my $debugging = $self->{settings}{debugmacro}; |
372
|
|
|
|
|
|
|
# if ($debugging) { |
373
|
|
|
|
|
|
|
# require Enbugger; Enbugger->stop(); |
374
|
|
|
|
|
|
|
# } |
375
|
0
|
|
|
|
|
|
shift @args; |
376
|
|
|
|
|
|
|
my $macro_expanded = |
377
|
0
|
|
|
|
|
|
$self->{macros}{$macro_cmd_name}[0]->(@args); |
378
|
0
|
0
|
|
|
|
|
if (ref $macro_expanded eq 'ARRAY' # && |
379
|
|
|
|
|
|
|
# current_command.all? {|val| val.is_a?(String)} |
380
|
|
|
|
|
|
|
) { |
381
|
0
|
|
|
|
|
|
my @new_commands = @{$macro_expanded}; |
|
0
|
|
|
|
|
|
|
382
|
0
|
0
|
|
|
|
|
$self->msg(join(' ', @new_commands)) if $debugging; |
383
|
0
|
0
|
|
|
|
|
if (scalar @new_commands > 0) { |
384
|
0
|
|
|
|
|
|
push @cmd_queue, @new_commands; |
385
|
0
|
|
|
|
|
|
$current_command = shift @cmd_queue; |
386
|
0
|
|
|
|
|
|
@args = split(' ', $current_command); |
387
|
|
|
|
|
|
|
} else { |
388
|
0
|
|
|
|
|
|
$current_command = '#'; |
389
|
0
|
|
|
|
|
|
@args = (); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
} else { |
392
|
0
|
0
|
|
|
|
|
$self->msg($macro_expanded) if $debugging; |
393
|
0
|
|
|
|
|
|
$current_command = $macro_expanded; |
394
|
0
|
|
|
|
|
|
@args = split(/\s+/, $current_command); |
395
|
|
|
|
|
|
|
# } else { |
396
|
|
|
|
|
|
|
# $self->errmsg("macro ${macro_cmd_name} should return a list " . |
397
|
|
|
|
|
|
|
# "of strings " . |
398
|
|
|
|
|
|
|
# # or a String |
399
|
|
|
|
|
|
|
# ". Got ${current_command.inspect}"); |
400
|
|
|
|
|
|
|
# return; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
0
|
|
|
|
|
|
my %commands = %{$self->{commands}}; |
|
0
|
|
|
|
|
|
|
405
|
0
|
|
|
|
|
|
$cmd_name = $self->{cmd_name} = $args[0]; |
406
|
0
|
|
|
|
|
|
my $run_cmd_name = $cmd_name; |
407
|
|
|
|
|
|
|
|
408
|
0
|
|
|
|
|
|
my %aliases = %{$self->{aliases}}; |
|
0
|
|
|
|
|
|
|
409
|
0
|
0
|
|
|
|
|
if (exists $aliases{$cmd_name}) { |
410
|
0
|
|
|
|
|
|
my @alias_expand = split(/\s+/, $aliases{$cmd_name}); |
411
|
0
|
|
|
|
|
|
$run_cmd_name = shift @alias_expand; |
412
|
0
|
|
|
|
|
|
splice(@args, 1, 0, @alias_expand); |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
$run_cmd_name = uniq_abbrev([keys %commands], $run_cmd_name) if |
416
|
0
|
0
|
0
|
|
|
|
!$commands{$run_cmd_name} && $self->{settings}{abbrev}; |
417
|
|
|
|
|
|
|
|
418
|
0
|
|
|
|
|
|
my $cmd = $commands{$run_cmd_name}; |
419
|
0
|
0
|
|
|
|
|
if ($cmd) { |
420
|
0
|
0
|
|
|
|
|
if ($self->ok_for_running($cmd, $run_cmd_name, scalar(@args)-1)) { |
421
|
|
|
|
|
|
|
# Get part of string after command name |
422
|
0
|
|
|
|
|
|
my $cmd_argstr = substr($current_command, length($cmd_name)); |
423
|
0
|
|
|
|
|
|
$self->{cmd_argstr} = $cmd_argstr; |
424
|
0
|
|
|
|
|
|
$cmd->run(\@args); |
425
|
0
|
|
|
|
|
|
$self->{last_command} = $current_command; |
426
|
|
|
|
|
|
|
} |
427
|
0
|
|
|
|
|
|
return; |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
# Eval anything that's not a command or has been |
432
|
|
|
|
|
|
|
# requested to be eval'd |
433
|
0
|
0
|
0
|
|
|
|
if ($self->{settings}{autoeval} || $eval_command) { |
434
|
0
|
|
|
|
|
|
my $return_type = parse_eval_sigil($current_command); |
435
|
0
|
0
|
|
|
|
|
$return_type = '$' unless $return_type; |
436
|
0
|
|
|
|
|
|
my $opts = {nest => 0, |
437
|
|
|
|
|
|
|
hide_position => 1, |
438
|
|
|
|
|
|
|
fix_file_and_line => 1, |
439
|
|
|
|
|
|
|
return_type => $return_type}; |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
# FIXME: 2 below is a magic fixup constant, also found in |
442
|
|
|
|
|
|
|
# DB::finish. Remove it. |
443
|
0
|
0
|
|
|
|
|
if (0 == $self->{frame_index}) { |
444
|
0
|
|
|
|
|
|
chomp $current_command; |
445
|
0
|
|
|
|
|
|
$self->eval($current_command, $opts, 2); |
446
|
|
|
|
|
|
|
} else { |
447
|
12
|
|
|
12
|
|
101
|
no warnings; |
|
12
|
|
|
|
|
34
|
|
|
12
|
|
|
|
|
761
|
|
448
|
|
|
|
|
|
|
my $return_type = $DB::eval_opts->{return_type} = |
449
|
0
|
|
|
|
|
|
$opts->{return_type}; |
450
|
12
|
|
|
12
|
|
73
|
use warnings; |
|
12
|
|
|
|
|
28
|
|
|
12
|
|
|
|
|
6056
|
|
451
|
0
|
0
|
|
|
|
|
if ('$' eq $opts->{return_type}) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
452
|
0
|
|
|
|
|
|
$DB::eval_result = $self->eval($current_command, $opts, 2); |
453
|
|
|
|
|
|
|
} elsif ('@' eq $opts->{return_type}) { |
454
|
0
|
|
|
|
|
|
@DB::eval_result = $self->eval($current_command, $opts, 2); |
455
|
|
|
|
|
|
|
} elsif ('%' eq $opts->{return_type}) { |
456
|
0
|
|
|
|
|
|
%DB::eval_result = $self->eval($current_command, $opts, 2); |
457
|
|
|
|
|
|
|
} else { |
458
|
0
|
|
|
|
|
|
$DB::eval_result = $self->eval($current_command, $opts, 2); |
459
|
|
|
|
|
|
|
} |
460
|
0
|
|
|
|
|
|
$self->handle_eval_result(); |
461
|
|
|
|
|
|
|
} |
462
|
0
|
|
|
|
|
|
return; |
463
|
|
|
|
|
|
|
} |
464
|
0
|
|
|
|
|
|
$self->undefined_command($cmd_name); |
465
|
0
|
|
|
|
|
|
return; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
# Error message when a command doesn't exist |
469
|
|
|
|
|
|
|
sub undefined_command($$) { |
470
|
0
|
|
|
0
|
0
|
|
my ($self, $cmd_name) = @_; |
471
|
0
|
|
|
|
|
|
my $msg = sprintf 'Undefined command: "%s". Try "help".', $cmd_name; |
472
|
0
|
|
|
|
|
|
eval { $self->errmsg($msg); }; |
|
0
|
|
|
|
|
|
|
473
|
0
|
0
|
|
|
|
|
print STDERR $msg if $EVAL_ERROR; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
unless (caller) { |
477
|
|
|
|
|
|
|
my $proc = Devel::Trepan::CmdProcessor->new; |
478
|
|
|
|
|
|
|
print $proc->{class}, "\n"; |
479
|
|
|
|
|
|
|
print join(', ', @{$proc->{interfaces}}), "\n"; |
480
|
|
|
|
|
|
|
$proc->msg("Hi, there!"); |
481
|
|
|
|
|
|
|
$proc->errmsg(['Two', 'lines']); |
482
|
|
|
|
|
|
|
$proc->errmsg("Something wrong?"); |
483
|
|
|
|
|
|
|
for my $fn (qw(errmsg msg section)) { |
484
|
|
|
|
|
|
|
$proc->$fn('testing'); |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
$DB::level = 1; |
487
|
|
|
|
|
|
|
my $prompt = $proc->{prompt} = set_prompt($proc); |
488
|
|
|
|
|
|
|
eval <<'EOE'; |
489
|
|
|
|
|
|
|
sub foo() { |
490
|
|
|
|
|
|
|
my @call_values = caller(0); |
491
|
|
|
|
|
|
|
return @call_values; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
EOE |
494
|
|
|
|
|
|
|
print "prompt setting: $prompt\n"; |
495
|
|
|
|
|
|
|
$DB::level = 2; |
496
|
|
|
|
|
|
|
$prompt = $proc->{prompt} = set_prompt($proc); |
497
|
|
|
|
|
|
|
print "prompt setting 2: $prompt\n"; |
498
|
|
|
|
|
|
|
my @call_values = foo(); |
499
|
|
|
|
|
|
|
## $proc->frame_setup(\@call_values, 0); |
500
|
|
|
|
|
|
|
my $sep = '=' x 40 . "\n"; |
501
|
|
|
|
|
|
|
$proc->undefined_command("foo"); |
502
|
|
|
|
|
|
|
print $sep; |
503
|
|
|
|
|
|
|
$proc->run_command("help *"); |
504
|
|
|
|
|
|
|
print $sep; |
505
|
|
|
|
|
|
|
$proc->run_command("help help;; kill 100"); |
506
|
|
|
|
|
|
|
# Note kill 100 is in queue - not run yet. |
507
|
|
|
|
|
|
|
if (scalar(@ARGV) > 0 && $proc->{interfaces}[-1]->is_interactive) { |
508
|
|
|
|
|
|
|
$proc->process_command_and_quit; # Handle's queued command |
509
|
|
|
|
|
|
|
$proc->process_command_and_quit; |
510
|
|
|
|
|
|
|
print $sep; |
511
|
|
|
|
|
|
|
$proc->process_commands([@call_values], 0, 'debugger-call'); |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
1; |