File Coverage

blib/lib/Devel/hdb/App.pm
Criterion Covered Total %
statement 80 254 31.5
branch 7 58 12.0
condition 6 26 23.0
subroutine 22 49 44.9
pod 8 23 34.7
total 123 410 30.0


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;