line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
4
|
|
|
4
|
|
90612
|
use warnings; |
|
4
|
|
|
|
|
26
|
|
|
4
|
|
|
|
|
137
|
|
2
|
4
|
|
|
4
|
|
17
|
use strict; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
112
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package Devel::hdb::App; |
5
|
|
|
|
|
|
|
|
6
|
4
|
|
|
4
|
|
1821
|
use Devel::Chitin 0.15; |
|
4
|
|
|
|
|
210846
|
|
|
4
|
|
|
|
|
200
|
|
7
|
4
|
|
|
4
|
|
32
|
use base 'Devel::Chitin'; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
322
|
|
8
|
4
|
|
|
4
|
|
1808
|
use Devel::hdb::Server; |
|
4
|
|
|
|
|
16
|
|
|
4
|
|
|
|
|
120
|
|
9
|
4
|
|
|
4
|
|
24
|
use IO::File; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
423
|
|
10
|
4
|
|
|
4
|
|
1912
|
use LWP::UserAgent; |
|
4
|
|
|
|
|
82510
|
|
|
4
|
|
|
|
|
127
|
|
11
|
4
|
|
|
4
|
|
468
|
use Data::Dumper; |
|
4
|
|
|
|
|
4733
|
|
|
4
|
|
|
|
|
215
|
|
12
|
4
|
|
|
4
|
|
1717
|
use Sys::Hostname; |
|
4
|
|
|
|
|
3556
|
|
|
4
|
|
|
|
|
179
|
|
13
|
4
|
|
|
4
|
|
26
|
use IO::Socket::INET; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
53
|
|
14
|
4
|
|
|
4
|
|
3394
|
use JSON qw(); |
|
4
|
|
|
|
|
24432
|
|
|
4
|
|
|
|
|
92
|
|
15
|
4
|
|
|
4
|
|
1263
|
use Data::Transform::ExplicitMetadata; |
|
4
|
|
|
|
|
13647
|
|
|
4
|
|
|
|
|
212
|
|
16
|
4
|
|
|
4
|
|
1546
|
use Sub::Name qw(subname); |
|
4
|
|
|
|
|
1718
|
|
|
4
|
|
|
|
|
186
|
|
17
|
|
|
|
|
|
|
|
18
|
4
|
|
|
4
|
|
1607
|
use Devel::hdb::Router; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
112
|
|
19
|
|
|
|
|
|
|
|
20
|
4
|
|
|
4
|
|
22
|
use vars qw( $parent_pid ); # when running in the test harness |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
8935
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
our $VERSION = '0.23_15'; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
our $APP_OBJ; |
25
|
|
|
|
|
|
|
sub get { |
26
|
1
|
50
|
|
1
|
0
|
2
|
return $APP_OBJ if $APP_OBJ; # get() is a singleton |
27
|
|
|
|
|
|
|
|
28
|
1
|
|
|
|
|
2
|
my $class = shift; |
29
|
|
|
|
|
|
|
|
30
|
1
|
|
|
|
|
1
|
my $self = $APP_OBJ = bless {}, $class; |
31
|
|
|
|
|
|
|
|
32
|
1
|
|
|
|
|
3
|
$self->_make_json_encoder(); |
33
|
1
|
|
|
|
|
2
|
$self->_make_listen_socket(); |
34
|
|
|
|
|
|
|
|
35
|
1
|
50
|
|
|
|
3
|
$parent_pid = eval { getppid() } if ($Devel::hdb::TESTHARNESS); |
|
0
|
|
|
|
|
0
|
|
36
|
1
|
|
|
|
|
2
|
return $self; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub _make_json_encoder { |
40
|
1
|
|
|
1
|
|
1
|
my $self = shift; |
41
|
1
|
|
|
|
|
19
|
$self->{json} = JSON->new->utf8->allow_nonref(); |
42
|
1
|
|
|
|
|
2
|
return $self; |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub encode_json { |
46
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
47
|
0
|
|
|
|
|
0
|
my $json = $self->{json}; |
48
|
0
|
|
|
|
|
0
|
return map { $json->encode($_) } @_; |
|
0
|
|
|
|
|
0
|
|
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub decode_json { |
52
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
53
|
0
|
|
|
|
|
0
|
my $json = $self->{json}; |
54
|
0
|
|
|
|
|
0
|
my @rv = map { $json->decode($_) } @_; |
|
0
|
|
|
|
|
0
|
|
55
|
|
|
|
|
|
|
return wantarray |
56
|
|
|
|
|
|
|
? @rv |
57
|
0
|
0
|
|
|
|
0
|
: $rv[0]; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub _make_listen_socket { |
61
|
1
|
|
|
1
|
|
1
|
my $self = shift; |
62
|
1
|
|
|
|
|
3
|
my %server_params = @_; |
63
|
|
|
|
|
|
|
|
64
|
1
|
|
50
|
|
|
5
|
$Devel::hdb::HOST = $server_params{host} = $Devel::hdb::HOST || '127.0.0.1'; |
65
|
1
|
50
|
33
|
|
|
4
|
if (!exists($server_params{port}) and defined($Devel::hdb::PORT)) { |
66
|
0
|
|
|
|
|
0
|
$server_params{port} = $Devel::hdb::PORT; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
1
|
50
|
|
|
|
2
|
$server_params{listen_sock} = $Devel::hdb::LISTEN_SOCK if defined $Devel::hdb::LISTEN_SOCK; |
70
|
|
|
|
|
|
|
|
71
|
1
|
50
|
|
|
|
3
|
unless (exists $server_params{server_ready}) { |
72
|
1
|
|
|
0
|
|
3
|
$server_params{server_ready} = sub { $self->init_debugger }; |
|
0
|
|
|
|
|
0
|
|
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
1
|
0
|
33
|
|
|
2
|
if (exists($server_params{port}) and !defined($server_params{port}) and $self->{server}) { |
|
|
|
33
|
|
|
|
|
76
|
|
|
|
|
|
|
# This was a forked child process |
77
|
0
|
|
|
|
|
0
|
my $new_sock = $self->_open_new_listen_sock_after_fork(); |
78
|
0
|
0
|
|
|
|
0
|
if ($new_sock) { |
79
|
0
|
|
|
|
|
0
|
$server_params{listen_sock} = $new_sock; |
80
|
0
|
|
|
|
|
0
|
delete $server_params{port}; |
81
|
|
|
|
|
|
|
} else { |
82
|
0
|
|
|
|
|
0
|
local($SIG{__WARN__}); |
83
|
0
|
|
|
|
|
0
|
my $current_port = $self->{server}->{listen_sock}->sockport; |
84
|
0
|
|
|
|
|
0
|
warn 'Could not find an open TCP port near ' |
85
|
|
|
|
|
|
|
. ($current_port + 1) |
86
|
|
|
|
|
|
|
. " for child process $$. Letting the system pick one..."; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
1
|
|
|
|
|
2
|
$Devel::hdb::LISTEN_SOCK = undef; |
91
|
1
|
|
|
|
|
6
|
$self->{server} = Devel::hdb::Server->new( %server_params ); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub _open_new_listen_sock_after_fork { |
95
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# try making a new listen socket that's 1 port higher |
98
|
0
|
|
|
|
|
0
|
my $current_local_addr = $self->{server}->{listen_sock}->sockhost; |
99
|
0
|
|
|
|
|
0
|
my $current_port = $self->{server}->{listen_sock}->sockport; |
100
|
0
|
|
|
|
|
0
|
my $new_sock; |
101
|
0
|
|
0
|
|
|
0
|
for(my $tries = 1; !$new_sock && $tries < 20; $tries++) { |
102
|
0
|
|
|
|
|
0
|
$new_sock = IO::Socket::INET->new(Listen => 5, |
103
|
|
|
|
|
|
|
LocalAddr => $current_local_addr, |
104
|
|
|
|
|
|
|
LocalPort => $current_port + $tries, |
105
|
|
|
|
|
|
|
Proto => 'tcp', |
106
|
|
|
|
|
|
|
ReuseAddr => 1); |
107
|
|
|
|
|
|
|
} |
108
|
0
|
|
|
|
|
0
|
return $new_sock; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub router { |
112
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
113
|
0
|
0
|
|
|
|
0
|
unless (ref $self) { |
114
|
0
|
|
|
|
|
0
|
$self = $self->get() |
115
|
|
|
|
|
|
|
} |
116
|
0
|
0
|
|
|
|
0
|
if (@_) { |
117
|
0
|
|
|
|
|
0
|
$self->{router} = shift; |
118
|
|
|
|
|
|
|
} |
119
|
0
|
|
|
|
|
0
|
return $self->{router}; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub init_debugger { |
123
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
124
|
|
|
|
|
|
|
|
125
|
0
|
0
|
0
|
|
|
0
|
if ($parent_pid and !kill(0, $parent_pid)) { |
126
|
|
|
|
|
|
|
# The parent PID for testing is gone |
127
|
0
|
|
|
|
|
0
|
exit(); |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
0
|
0
|
|
|
|
0
|
return if $self->{__init__}; |
131
|
0
|
|
|
|
|
0
|
$self->{__init__} = 1; |
132
|
|
|
|
|
|
|
|
133
|
0
|
|
|
|
|
0
|
$self->_announce(); |
134
|
|
|
|
|
|
|
|
135
|
0
|
|
|
|
|
0
|
$self->router( Devel::hdb::Router->new() ); |
136
|
|
|
|
|
|
|
|
137
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Stack; |
138
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Control; |
139
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::ProgramName; |
140
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Assets; |
141
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Config; |
142
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Terminate; |
143
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::PackageInfo; |
144
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Breakpoint; |
145
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Action; |
146
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::SourceFile; |
147
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::Eval; |
148
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::AnnounceChild; |
149
|
0
|
|
|
|
|
0
|
require Devel::hdb::App::WatchPoint; |
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
0
|
eval { $self->load_settings_from_file() }; |
|
0
|
|
|
|
|
0
|
|
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub _gui_url { |
156
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
157
|
0
|
|
|
|
|
0
|
return $self->{base_url} . '/debugger-gui'; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
sub _announce { |
161
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# HTTP::Server::PSGI doesn't have a method to get the listen socket :( |
164
|
0
|
|
|
|
|
0
|
my $s = $self->{server}->{listen_sock}; |
165
|
0
|
|
|
|
|
0
|
my $hostname = $s->sockhost; |
166
|
0
|
0
|
|
|
|
0
|
if ($hostname eq '0.0.0.0') { |
|
|
0
|
|
|
|
|
|
167
|
0
|
|
|
|
|
0
|
$hostname = Sys::Hostname::hostname(); |
168
|
|
|
|
|
|
|
} elsif ($hostname ne '127.0.0.1') { |
169
|
0
|
|
|
|
|
0
|
$hostname = gethostbyaddr($s->sockaddr, AF_INET); |
170
|
|
|
|
|
|
|
} |
171
|
0
|
|
|
|
|
0
|
$self->{base_url} = sprintf('http://%s:%d', |
172
|
|
|
|
|
|
|
$hostname, $s->sockport); |
173
|
|
|
|
|
|
|
|
174
|
0
|
|
|
|
|
0
|
my $announce_url = $self->_gui_url; |
175
|
|
|
|
|
|
|
|
176
|
0
|
0
|
|
|
|
0
|
STDOUT->printflush("Debugger pid $$ listening on $announce_url\n") unless ($Devel::hdb::TESTHARNESS); |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub on_notify_stopped { |
180
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
181
|
0
|
0
|
|
|
|
0
|
if (@_) { |
182
|
0
|
|
|
|
|
0
|
$self->{at_next_breakpoint} = shift; |
183
|
|
|
|
|
|
|
} |
184
|
0
|
|
|
|
|
0
|
return $self->{at_next_breakpoint}; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
sub notify_stopped { |
188
|
0
|
|
|
0
|
1
|
0
|
my($self, $location) = @_; |
189
|
|
|
|
|
|
|
|
190
|
0
|
|
|
|
|
0
|
$self->current_location($location); |
191
|
0
|
|
|
|
|
0
|
my $cb = $self->on_notify_stopped; |
192
|
0
|
|
|
|
|
0
|
$self->on_notify_stopped(undef); |
193
|
0
|
0
|
|
|
|
0
|
$cb && $cb->(); |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub current_location { |
197
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
198
|
0
|
0
|
|
|
|
0
|
if (@_) { |
199
|
0
|
|
|
|
|
0
|
$self->{current_location} = shift; |
200
|
|
|
|
|
|
|
} |
201
|
0
|
|
|
|
|
0
|
return $self->{current_location}; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# Called in the parent process after a fork |
205
|
|
|
|
|
|
|
sub notify_fork_parent { |
206
|
0
|
|
|
0
|
1
|
0
|
my($self, $location, $child_pid) = @_; |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
my $gotit = sub { |
209
|
0
|
|
|
0
|
|
0
|
my($rv,$env) = @_; |
210
|
0
|
|
|
|
|
0
|
$env->{'psgix.harakiri.commit'} = Plack::Util::TRUE; |
211
|
0
|
|
|
|
|
0
|
}; |
212
|
0
|
|
|
|
|
0
|
$self->{router}->once_after('POST','/announce_child', $gotit); |
213
|
0
|
|
|
|
|
0
|
$self->run(); |
214
|
0
|
|
|
|
|
0
|
$self->step; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
{ |
218
|
|
|
|
|
|
|
my $parent_process_base_url; |
219
|
|
|
|
|
|
|
sub _parent_process_base_url { |
220
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
221
|
0
|
0
|
|
|
|
0
|
if (@_) { |
222
|
0
|
|
|
|
|
0
|
$parent_process_base_url = shift; |
223
|
|
|
|
|
|
|
} |
224
|
0
|
|
|
|
|
0
|
return $parent_process_base_url; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# called in the child process after a fork |
229
|
|
|
|
|
|
|
sub notify_fork_child { |
230
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
231
|
0
|
|
|
|
|
0
|
my $location = shift; |
232
|
|
|
|
|
|
|
|
233
|
0
|
|
|
|
|
0
|
$self->on_notify_stopped(undef); |
234
|
0
|
|
|
|
|
0
|
$self->dequeue_events(); |
235
|
|
|
|
|
|
|
|
236
|
0
|
|
|
|
|
0
|
$parent_pid = undef; |
237
|
0
|
|
|
|
|
0
|
my $parent_base_url = $self->_parent_process_base_url($self->{base_url}); |
238
|
|
|
|
|
|
|
|
239
|
0
|
|
|
|
|
0
|
my $announced; |
240
|
|
|
|
|
|
|
my $when_ready = sub { |
241
|
0
|
0
|
|
0
|
|
0
|
unless ($announced) { |
242
|
0
|
|
|
|
|
0
|
$announced = 1; |
243
|
0
|
|
|
|
|
0
|
$self->_announce(); |
244
|
0
|
|
|
|
|
0
|
my $ua = LWP::UserAgent->new(); |
245
|
|
|
|
|
|
|
my $resp = $ua->post($parent_base_url |
246
|
0
|
|
|
|
|
0
|
. '/announce_child', { pid => $$, uri => $self->{base_url}, gui => $self->_gui_url }); |
247
|
0
|
0
|
|
|
|
0
|
unless ($resp->is_success()) { |
248
|
0
|
|
|
|
|
0
|
print STDERR "sending announce failed... exiting\n"; |
249
|
0
|
0
|
|
|
|
0
|
exit(1) if ($Devel::hdb::TESTHARNESS); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
} |
252
|
0
|
|
|
|
|
0
|
}; |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# Force it to pick a new port |
255
|
0
|
|
|
|
|
0
|
$self->_make_listen_socket(port => undef, server_ready => $when_ready); |
256
|
0
|
|
|
|
|
0
|
$self->step; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub app { |
261
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
262
|
0
|
0
|
|
|
|
0
|
unless ($self->{app}) { |
263
|
0
|
|
|
0
|
|
0
|
$self->{app} = sub { $self->{router}->route(@_); }; |
|
0
|
|
|
|
|
0
|
|
264
|
|
|
|
|
|
|
} |
265
|
0
|
|
|
|
|
0
|
return $self->{app}; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
sub run { |
269
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
270
|
0
|
|
|
|
|
0
|
$self->{server}->run($self->app); |
271
|
0
|
|
|
|
|
0
|
1; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
*idle = \&run; |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# If we're in trace mode, then don't stop |
276
|
|
|
|
|
|
|
sub poll { |
277
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
278
|
0
|
|
|
|
|
0
|
return ! $self->{trace}; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
sub notify_trace_diff { |
282
|
0
|
|
|
0
|
0
|
0
|
my($self, $trace_data) = @_; |
283
|
|
|
|
|
|
|
|
284
|
0
|
|
|
|
|
0
|
my $follower = delete $self->{follow}; |
285
|
0
|
|
|
|
|
0
|
$follower->shutdown(); |
286
|
0
|
|
|
|
|
0
|
$self->step(); |
287
|
|
|
|
|
|
|
|
288
|
0
|
|
|
|
|
0
|
$trace_data->{type} = 'trace_diff'; |
289
|
0
|
|
|
|
|
0
|
$self->enqueue_event($trace_data); |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
sub notify_uncaught_exception { |
293
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
294
|
0
|
|
|
|
|
0
|
my $exception = shift; |
295
|
|
|
|
|
|
|
|
296
|
0
|
|
|
|
|
0
|
my %event = ( type => 'exception', |
297
|
|
|
|
|
|
|
value => Data::Transform::ExplicitMetadata::encode($exception->exception) ); |
298
|
|
|
|
|
|
|
@event{'subroutine','package','filename','line'} |
299
|
0
|
|
|
|
|
0
|
= map { $exception->$_ } qw(subroutine package filename line); |
|
0
|
|
|
|
|
0
|
|
300
|
0
|
|
|
|
|
0
|
$self->enqueue_event(\%event); |
301
|
|
|
|
|
|
|
|
302
|
0
|
|
|
|
|
0
|
my $exception_as_comment = '# ' . join("\n# ", split(/\n/, $exception->exception)); |
303
|
0
|
|
|
|
|
0
|
my $stopped = subname '__exception__' => eval qq(sub { \$self->step && (local \$DB::in_debugger = 0);\n# Uncaught exception:\n$exception_as_comment\n1;\n}\n); |
304
|
|
|
|
|
|
|
|
305
|
0
|
|
|
|
|
0
|
@_ = (); |
306
|
0
|
|
|
|
|
0
|
goto &$stopped; |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
sub exit_code { |
310
|
1
|
|
|
1
|
0
|
2
|
my $self = shift; |
311
|
1
|
50
|
|
|
|
11
|
if (@_) { |
312
|
1
|
|
|
|
|
11
|
$self->{exit_code} = shift; |
313
|
|
|
|
|
|
|
} |
314
|
1
|
|
|
|
|
2
|
return $self->{exit_code}; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
sub notify_program_terminated { |
318
|
1
|
|
|
1
|
1
|
202
|
my $self = shift; |
319
|
1
|
|
|
|
|
2
|
my $exit_code = shift; |
320
|
|
|
|
|
|
|
|
321
|
1
|
|
|
|
|
65
|
$self->exit_code($exit_code); |
322
|
1
|
|
|
|
|
5
|
$self->enqueue_event({ type => 'exit', value => $exit_code}); |
323
|
|
|
|
|
|
|
|
324
|
1
|
50
|
|
|
|
44
|
print STDERR "Debugged program pid $$ terminated with exit code $exit_code\n" unless ($Devel::hdb::TESTHARNESS); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
sub notify_program_exit { |
328
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
329
|
0
|
|
|
|
|
0
|
$self->enqueue_event({ type => 'hangup' }); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
sub enqueue_event { |
333
|
1
|
|
|
1
|
0
|
2
|
my $self = shift; |
334
|
1
|
|
50
|
|
|
6
|
my $queue = $self->{'queued_events'} ||= []; |
335
|
1
|
|
|
|
|
3
|
push @$queue, @_; |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
sub dequeue_events { |
339
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
340
|
0
|
|
|
|
|
0
|
return delete $self->{'queued_events'}; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
sub settings_file { |
344
|
1
|
|
|
1
|
0
|
1321
|
my $class = shift; |
345
|
1
|
|
|
|
|
3
|
my $prefix = shift; |
346
|
1
|
|
33
|
|
|
12
|
return ((defined($prefix) && $prefix) || $0) . '.hdb'; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
sub load_settings_from_file { |
350
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
351
|
0
|
|
|
|
|
|
my $file = shift; |
352
|
|
|
|
|
|
|
|
353
|
0
|
0
|
|
|
|
|
unless (defined $file) { |
354
|
0
|
|
|
|
|
|
$file = $self->settings_file(); |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
0
|
0
|
|
|
|
|
return 0 unless -f $file; |
358
|
|
|
|
|
|
|
|
359
|
0
|
|
|
|
|
|
my $buffer; |
360
|
|
|
|
|
|
|
{ |
361
|
0
|
|
|
|
|
|
local($/); |
|
0
|
|
|
|
|
|
|
362
|
0
|
|
0
|
|
|
|
my $fh = IO::File->new($file, 'r') || die "Can't open file $file for reading: $!"; |
363
|
0
|
|
|
|
|
|
$buffer = <$fh>; |
364
|
|
|
|
|
|
|
} |
365
|
0
|
|
|
|
|
|
my $settings = eval $buffer; |
366
|
0
|
0
|
|
|
|
|
die $@ if $@; |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
|
369
|
0
|
|
|
|
|
|
my @set_breakpoints; |
370
|
0
|
|
|
|
|
|
foreach my $bp ( @{ $settings->{breakpoints}} ) { |
|
0
|
|
|
|
|
|
|
371
|
0
|
|
|
|
|
|
push @set_breakpoints, |
372
|
|
|
|
|
|
|
Devel::hdb::App::Breakpoint->set_and_respond($self, $bp); |
373
|
|
|
|
|
|
|
} |
374
|
0
|
|
|
|
|
|
foreach my $action ( @{ $settings->{actions}} ) { |
|
0
|
|
|
|
|
|
|
375
|
0
|
|
|
|
|
|
push @set_breakpoints, |
376
|
|
|
|
|
|
|
Devel::hdb::App::Action->set_and_respond($self, $action); |
377
|
|
|
|
|
|
|
} |
378
|
0
|
|
|
|
|
|
return 1; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
sub save_settings_to_file { |
382
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
383
|
0
|
|
|
|
|
|
my $file = shift; |
384
|
|
|
|
|
|
|
|
385
|
0
|
0
|
|
|
|
|
unless (defined $file) { |
386
|
0
|
|
|
|
|
|
$file = $self->settings_file(); |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
my $serializer = sub { |
390
|
0
|
|
|
0
|
|
|
my %it = map { $_ => $_[0]->$_ } qw(line code inactive); |
|
0
|
|
|
|
|
|
|
391
|
0
|
|
|
|
|
|
$it{filename} = $_[0]->file; |
392
|
0
|
|
|
|
|
|
return \%it; |
393
|
0
|
|
|
|
|
|
}; |
394
|
|
|
|
|
|
|
|
395
|
0
|
|
|
|
|
|
my @breakpoints = map { $serializer->($_) } $self->get_breaks(); |
|
0
|
|
|
|
|
|
|
396
|
0
|
|
|
|
|
|
my @actions = map { $serializer->($_) } $self->get_actions(); |
|
0
|
|
|
|
|
|
|
397
|
0
|
|
0
|
|
|
|
my $fh = IO::File->new($file, 'w') || die "Can't open $file for writing: $!"; |
398
|
0
|
|
|
|
|
|
my $config = { breakpoints => \@breakpoints, actions => \@actions }; |
399
|
0
|
|
|
|
|
|
$fh->print( Data::Dumper->new([ $config ])->Terse(1)->Dump()); |
400
|
0
|
|
|
|
|
|
return $file; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
1; |