File Coverage

blib/lib/Coro/Debug.pm
Criterion Covered Total %
statement 39 205 19.0
branch 0 130 0.0
condition 0 14 0.0
subroutine 13 39 33.3
pod 9 13 69.2
total 61 401 15.2


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Coro::Debug - various functions that help debugging Coro programs
4              
5             =head1 SYNOPSIS
6              
7             use Coro::Debug;
8              
9             our $server = new_unix_server Coro::Debug "/tmp/socketpath";
10              
11             $ socat readline unix:/tmp/socketpath
12              
13             =head1 DESCRIPTION
14              
15             This module is an L user, you need to make sure that you use and
16             run a supported event loop.
17              
18             This module provides some debugging facilities. Most will, if not handled
19             carefully, severely compromise the security of your program, so use it
20             only for debugging (or take other precautions).
21              
22             It mainly implements a very primitive debugger that is very easy to
23             integrate in your program:
24              
25             our $server = new_unix_server Coro::Debug "/tmp/somepath";
26             # see new_unix_server, below, for more info
27              
28             It lets you list running coroutines:
29              
30             state (rUnning, Ready, New or neither)
31             |cctx allocated
32             || resident set size (octets)
33             || | scheduled this many times
34             > ps || | |
35             PID SC RSS USES Description Where
36             14572344 UC 62k 128k [main::] [dm-support.ext:47]
37             14620056 -- 2260 13 [coro manager] [Coro.pm:358]
38             14620128 -- 2260 166 [unblock_sub scheduler] [Coro.pm:358]
39             17764008 N- 152 0 [EV idle process] -
40             13990784 -- 2596 10k timeslot manager [cf.pm:454]
41             81424176 -- 18k 4758 [async pool idle] [Coro.pm:257]
42             23513336 -- 2624 1 follow handler [follow.ext:52]
43             40548312 -- 15k 5597 player scheduler [player-scheduler.ext:13]
44             29138032 -- 2548 431 music scheduler [player-env.ext:77]
45             43449808 -- 2260 3493 worldmap updater [item-worldmap.ext:115]
46             33352488 -- 19k 2845 [async pool idle] [Coro.pm:257]
47             81530072 -- 13k 43k map scheduler [map-scheduler.ext:65]
48             30751144 -- 15k 2204 [async pool idle] [Coro.pm:257]
49              
50             Lets you do backtraces on about any coroutine:
51              
52             > bt 18334288
53             coroutine is at /opt/cf/ext/player-env.ext line 77
54             eval {...} called at /opt/cf/ext/player-env.ext line 77
55             ext::player_env::__ANON__ called at -e line 0
56             Coro::_run_coro called at -e line 0
57              
58             Or lets you eval perl code:
59              
60             > 5+7
61             12
62              
63             Or lets you eval perl code within other coroutines:
64              
65             > eval 18334288 caller(1); $DB::args[0]->method
66             1
67              
68             It can also trace subroutine entry/exits for most coroutines (those not
69             having recursed into a C function), resulting in output similar to:
70              
71             > loglevel 5
72             > trace 94652688
73             2007-09-27Z20:30:25.1368 (5) [94652688] enter Socket::sockaddr_in with (8481,\x{7f}\x{00}\x{00}\x{01})
74             2007-09-27Z20:30:25.1369 (5) [94652688] leave Socket::sockaddr_in returning (\x{02}\x{00}...)
75             2007-09-27Z20:30:25.1370 (5) [94652688] enter Net::FCP::Util::touc with (client_get)
76             2007-09-27Z20:30:25.1371 (5) [94652688] leave Net::FCP::Util::touc returning (ClientGet)
77             2007-09-27Z20:30:25.1372 (5) [94652688] enter AnyEvent::Impl::Event::io with (AnyEvent,fh,GLOB(0x9256250),poll,w,cb,CODE(0x8c963a0))
78             2007-09-27Z20:30:25.1373 (5) [94652688] enter Event::Watcher::__ANON__ with (Event,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
79             2007-09-27Z20:30:25.1374 (5) [94652688] enter Event::io::new with (Event::io,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
80             2007-09-27Z20:30:25.1375 (5) [94652688] enter Event::Watcher::init with (Event::io=HASH(0x8bfb120),HASH(0x9b7940))
81              
82             If your program uses the Coro::Debug::log facility:
83              
84             Coro::Debug::log 0, "important message";
85             Coro::Debug::log 9, "unimportant message";
86              
87             Then you can even receive log messages in any debugging session:
88              
89             > loglevel 5
90             2007-09-26Z02:22:46 (9) unimportant message
91              
92             Other commands are available in the shell, use the C command for a list.
93              
94             =head1 FUNCTIONS
95              
96             None of the functions are being exported.
97              
98             =over 4
99              
100             =cut
101              
102             package Coro::Debug;
103              
104 1     1   852 use common::sense;
  1         3  
  1         5  
105              
106 1     1   43 use overload ();
  1         2  
  1         11  
107              
108 1     1   3 use Carp ();
  1         2  
  1         11  
109 1     1   4 use Scalar::Util ();
  1         1  
  1         12  
110              
111 1     1   4 use Guard;
  1         2  
  1         41  
112              
113 1     1   10 use AnyEvent ();
  1         1  
  1         12  
114 1     1   4 use AnyEvent::Util ();
  1         1  
  1         14  
115 1     1   4 use AnyEvent::Socket ();
  1         2  
  1         13  
116              
117 1     1   3 use Coro ();
  1         2  
  1         16  
118 1     1   4 use Coro::Handle ();
  1         2  
  1         12  
119 1     1   3 use Coro::State ();
  1         2  
  1         10  
120 1     1   3 use Coro::AnyEvent ();
  1         2  
  1         73  
121 1     1   5 use Coro::Timer ();
  1         2  
  1         2702  
122              
123             our $VERSION = 6.513;
124              
125             our %log;
126             our $SESLOGLEVEL = exists $ENV{PERL_CORO_DEFAULT_LOGLEVEL} ? $ENV{PERL_CORO_DEFAULT_LOGLEVEL} : -1;
127             our $ERRLOGLEVEL = exists $ENV{PERL_CORO_STDERR_LOGLEVEL} ? $ENV{PERL_CORO_STDERR_LOGLEVEL} : -1;
128              
129             sub find_coro {
130 0     0 0   my ($pid) = @_;
131              
132 0 0         if (my ($coro) = grep $_ == $pid, Coro::State::list) {
133 0           $coro
134             } else {
135 0           print "$pid: no such coroutine\n";
136             undef
137 0           }
138             }
139              
140             sub format_msg($$) {
141 0     0 0   my ($time, $micro) = Coro::Util::gettimeofday;
142 0           my ($sec, $min, $hour, $day, $mon, $year) = gmtime $time;
143 0           my $date = sprintf "%04d-%02d-%02dZ%02d:%02d:%02d.%04d",
144             $year + 1900, $mon + 1, $day, $hour, $min, $sec, $micro / 100;
145 0           sprintf "%s (%d) %s", $date, $_[0], $_[1]
146             }
147              
148             sub format_num4($) {
149 0     0 0   my ($v) = @_;
150              
151 0 0         return sprintf "%4d" , $v if $v < 1e4;
152             # 1e5 redundant
153 0 0         return sprintf "%3.0fk", $v / 1_000 if $v < 1e6;
154 0 0         return sprintf "%1.1fM", $v / 1_000_000 if $v < 1e7 * .995;
155 0 0         return sprintf "%3.0fM", $v / 1_000_000 if $v < 1e9;
156 0 0         return sprintf "%1.1fG", $v / 1_000_000_000 if $v < 1e10 * .995;
157 0 0         return sprintf "%3.0fG", $v / 1_000_000_000 if $v < 1e12;
158 0 0         return sprintf "%1.1fT", $v / 1_000_000_000_000 if $v < 1e13 * .995;
159 0 0         return sprintf "%3.0fT", $v / 1_000_000_000_000 if $v < 1e15;
160              
161 0           "++++"
162             }
163              
164             =item log $level, $msg
165              
166             Log a debug message of the given severity level (0 is highest, higher is
167             less important) to all interested parties.
168              
169             =item stderr_loglevel $level
170              
171             Set the loglevel for logging to stderr (defaults to the value of the
172             environment variable PERL_CORO_STDERR_LOGLEVEL, or -1 if missing).
173              
174             =item session_loglevel $level
175              
176             Set the default loglevel for new coro debug sessions (defaults to the
177             value of the environment variable PERL_CORO_DEFAULT_LOGLEVEL, or -1 if
178             missing).
179              
180             =cut
181              
182             sub log($$) {
183 0     0 1   my ($level, $msg) = @_;
184 0           $msg =~ s/\s*$/\n/;
185 0           $_->($level, $msg) for values %log;
186 0 0         printf STDERR format_msg $level, $msg if $level <= $ERRLOGLEVEL;
187             }
188              
189             sub session_loglevel($) {
190 0     0 1   $SESLOGLEVEL = shift;
191             }
192              
193             sub stderr_loglevel($) {
194 0     0 1   $ERRLOGLEVEL = shift;
195             }
196              
197             =item trace $coro, $loglevel
198              
199             Enables tracing the given coroutine at the given loglevel. If loglevel is
200             omitted, use 5. If coro is omitted, trace the current coroutine. Tracing
201             incurs a very high runtime overhead.
202              
203             It is not uncommon to enable tracing on oneself by simply calling
204             C.
205              
206             A message will be logged at the given loglevel if it is not possible to
207             enable tracing.
208              
209             =item untrace $coro
210              
211             Disables tracing on the given coroutine.
212              
213             =cut
214              
215             sub trace {
216 0     0 1   my ($coro, $loglevel) = @_;
217              
218 0   0       $coro ||= $Coro::current;
219 0 0         $loglevel = 5 unless defined $loglevel;
220              
221             (Coro::async {
222 0 0   0     if (eval { Coro::State::trace $coro, Coro::State::CC_TRACE | Coro::State::CC_TRACE_SUB; 1 }) {
  0            
  0            
223 0           Coro::Debug::log $loglevel, sprintf "[%d] tracing enabled", $coro + 0;
224             $coro->{_trace_line_cb} = sub {
225 0           Coro::Debug::log $loglevel, sprintf "[%d] at %s:%d\n", $Coro::current+0, @_;
226 0           };
227             $coro->{_trace_sub_cb} = sub {
228             Coro::Debug::log $loglevel, sprintf "[%d] %s %s %s\n",
229             $Coro::current+0,
230             $_[0] ? "enter" : "leave",
231             $_[1],
232             $_[2] ? ($_[0] ? "with (" : "returning (") . (
233             join ",",
234             map {
235 0 0         my $x = ref $_ ? overload::StrVal $_ : $_;
236 0 0         (substr $x, 40) = "..." if 40 + 3 < length $x;
237 0           $x =~ s/([^\x20-\x5b\x5d-\x7e])/sprintf "\\x{%02x}", ord $1/ge;
  0            
238 0           $x
239 0 0         } @{$_[2]}
  0 0          
    0          
240             ) . ")" : "";
241 0           };
242              
243 0           undef $coro; # the subs keep a reference which we do not want them to do
244             } else {
245 0           Coro::Debug::log $loglevel, sprintf "[%d] unable to enable tracing: %s", $Coro::current + 0, $@;
246             }
247 0           })->prio (Coro::PRIO_MAX);
248              
249 0           Coro::cede;
250             }
251              
252             sub untrace {
253 0     0 1   my ($coro) = @_;
254              
255 0   0       $coro ||= $Coro::current;
256              
257             (Coro::async {
258 0     0     Coro::State::trace $coro, 0;
259 0           delete $coro->{_trace_sub_cb};
260 0           delete $coro->{_trace_line_cb};
261 0           })->prio (Coro::PRIO_MAX);
262              
263 0           Coro::cede;
264             }
265              
266             sub ps_listing {
267 0     0 0   my $times = Coro::State::enable_times;
268 0           my $flags = $1;
269 0           my $verbose = $flags =~ /v/;
270 0 0         my $desc_format = $flags =~ /w/ ? "%-24s" : "%-24.24s";
271 0 0         my $tim0_format = $times ? " %9s %8s " : " ";
272 0 0         my $tim1_format = $times ? " %9.3f %8.3f " : " ";
273 0 0         my $buf = sprintf "%20s %s%s %4s %4s$tim0_format$desc_format %s\n",
274             "PID", "S", "C", "RSS", "USES",
275             $times ? ("t_real", "t_cpu") : (),
276             "Description", "Where";
277 0           for my $coro (reverse Coro::State::list) {
278 0           my @bt;
279             Coro::State::call ($coro, sub {
280             # we try to find *the* definite frame that gives most useful info
281             # by skipping Coro frames and pseudo-frames.
282 0     0     for my $frame (1..10) {
283 0           my @frame = caller $frame;
284 0 0         @bt = @frame if $frame[2];
285 0 0         last unless $bt[0] =~ /^Coro/;
286             }
287 0           });
288 0 0 0       $bt[1] =~ s/^.*[\/\\]// if @bt && !$verbose;
289 0 0         $buf .= sprintf "%20s %s%s %4s %4s$tim1_format$desc_format %s\n",
    0          
    0          
    0          
    0          
    0          
    0          
290             $coro+0,
291             $coro->is_new ? "N" : $coro->is_running ? "U" : $coro->is_ready ? "R" : "-",
292             $coro->is_traced ? "T" : $coro->has_cctx ? "C" : "-",
293             format_num4 $coro->rss,
294             format_num4 $coro->usecount,
295             $times ? $coro->times : (),
296             $coro->debug_desc,
297             (@bt ? sprintf "[%s:%d]", $bt[1], $bt[2] : "-");
298             }
299              
300             $buf
301 0           }
302              
303             =item command $string
304              
305             Execute a debugger command, sending any output to STDOUT. Used by
306             C, below.
307              
308             =cut
309              
310             sub command($) {
311 0     0 1   my ($cmd) = @_;
312              
313 0           $cmd =~ s/\s+$//;
314              
315 0 0         if ($cmd =~ /^ps (?:\s* (\S+))? $/x) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
316 0           print ps_listing;
317              
318             } elsif ($cmd =~ /^bt\s+(\d+)$/) {
319 0 0         if (my $coro = find_coro $1) {
320 0           my $bt;
321             Coro::State::call ($coro, sub {
322 0     0     local $Carp::CarpLevel = 2;
323 0   0       $bt = eval { Carp::longmess "coroutine is" } || "$@";
324 0           });
325 0 0         if ($bt) {
326 0           print $bt;
327             } else {
328 0           print "$1: unable to get backtrace\n";
329             }
330             }
331              
332             } elsif ($cmd =~ /^(?:e|eval)\s+(\d+)\s+(.*)$/) {
333 0 0         if (my $coro = find_coro $1) {
334 0           my $cmd = eval "sub { $2 }";
335 0           my @res;
336 0     0     Coro::State::call ($coro, sub { @res = eval { &$cmd } });
  0            
  0            
337 0 0         print $@ ? $@ : (join " ", @res, "\n");
338             }
339              
340             } elsif ($cmd =~ /^(?:tr|trace)\s+(\d+)$/) {
341 0 0         if (my $coro = find_coro $1) {
342 0           trace $coro;
343             }
344              
345             } elsif ($cmd =~ /^(?:ut|untrace)\s+(\d+)$/) {
346 0 0         if (my $coro = find_coro $1) {
347 0           untrace $coro;
348             }
349              
350             } elsif ($cmd =~ /^cancel\s+(\d+)$/) {
351 0 0         if (my $coro = find_coro $1) {
352 0           $coro->cancel;
353             }
354              
355             } elsif ($cmd =~ /^ready\s+(\d+)$/) {
356 0 0         if (my $coro = find_coro $1) {
357 0           $coro->ready;
358             }
359              
360             } elsif ($cmd =~ /^kill\s+(\d+)(?:\s+(.*))?$/) {
361 0 0         my $reason = defined $2 ? $2 : "killed";
362              
363 0 0         if (my $coro = find_coro $1) {
364 0           $coro->throw ($reason);
365             }
366              
367             } elsif ($cmd =~ /^enable_times(\s+\S.*)?\s*$/) {
368 0 0         my $enable = defined $1 ? 1*eval $1 : !Coro::State::enable_times;
369              
370 0           Coro::State::enable_times $enable;
371              
372 0 0         print "per-thread real and process time gathering ", $enable ? "enabled" : "disabled", ".\n";
373              
374             } elsif ($cmd =~ /^help$/) {
375 0           print <
376             ps [w|v] show the list of all coroutines (wide, verbose)
377             bt show a full backtrace of coroutine
378             eval evaluate expression in context of
379             trace enable tracing for this coroutine
380             untrace disable tracing for this coroutine
381             kill throws the given string in
382             cancel cancels this coroutine
383             ready force into the ready queue
384             enable_times enable or disable time profiling in ps
385             evaluate as perl and print results
386             & same as above, but evaluate asynchronously
387             you can use (find_coro ) in perl expressions
388             to find the coro with the given pid, e.g.
389             (find_coro 9768720)->ready
390             EOF
391              
392             } elsif ($cmd =~ /^(.*)&$/) {
393 0           my $cmd = $1;
394 0           my $sub = eval "sub { $cmd }";
395 0           my $fh = select;
396             Coro::async_pool {
397 0     0     $Coro::current->{desc} = $cmd;
398 0           my $t = Coro::Util::time;
399 0           my @res = eval { &$sub };
  0            
400 0           $t = Coro::Util::time - $t;
401 0 0         print {$fh}
  0            
402             "\rcommand: $cmd\n",
403             "execution time: $t\n",
404             "result: ", $@ ? $@ : (join " ", @res) . "\n",
405             "> ";
406 0           };
407              
408             } else {
409 0           my @res = eval $cmd;
410 0 0         print $@ ? $@ : (join " ", @res) . "\n";
411             }
412              
413 0           local $| = 1;
414             }
415              
416             =item session $fh
417              
418             Run an interactive debugger session on the given filehandle. Each line entered
419             is simply passed to C (with a few exceptions).
420              
421             =cut
422              
423             sub session($) {
424 0     0 1   my ($fh) = @_;
425              
426 0           $fh = Coro::Handle::unblock $fh;
427 0           my $old_fh = select $fh;
428 0     0     my $guard = guard { select $old_fh };
  0            
429              
430 0           my $loglevel = $SESLOGLEVEL;
431             local $log{$Coro::current} = sub {
432 0 0   0     return unless $_[0] <= $loglevel;
433 0           print $fh "\015", (format_msg $_[0], $_[1]), "> ";
434 0           };
435              
436 0           print "coro debug session. use help for more info\n\n";
437              
438 0           while ((print "> "), defined (my $cmd = $fh->readline ("\012"))) {
439 0 0         if ($cmd =~ /^exit\s*$/) {
    0          
    0          
    0          
440 0           print "bye.\n";
441 0           last;
442              
443             } elsif ($cmd =~ /^(?:ll|loglevel)\s*(\d+)?\s*/) {
444 0 0         $loglevel = defined $1 ? $1 : -1;
445              
446             } elsif ($cmd =~ /^(?:w|watch)\s*([0-9.]*)\s+(.*)/) {
447 0   0       my ($time, $cmd) = ($1*1 || 1, $2);
448 0           my $cancel;
449              
450             Coro::async {
451 0     0     $Coro::current->{desc} = "watch $cmd";
452 0           select $fh;
453 0           until ($cancel) {
454 0           command $cmd;
455 0           Coro::Timer::sleep $time;
456             }
457 0           };
458              
459 0           $fh->readable;
460 0           $cancel = 1;
461              
462             } elsif ($cmd =~ /^help\s*/) {
463 0           command $cmd;
464 0           print <
465             loglevel enable logging for messages of level and lower
466             watch
467             exit end this session
468             EOF
469             } else {
470 0           command $cmd;
471             }
472              
473 0           Coro::cede;
474             }
475             }
476              
477             =item $server = new_unix_server Coro::Debug $path
478              
479             Creates a new unix domain socket that listens for connection requests and
480             runs C on any connection. Normal unix permission checks and umask
481             applies, so you can protect your socket by puttint it into a protected
482             directory.
483              
484             The C utility is an excellent way to connect to this socket:
485              
486             socat readline /path/to/socket
487              
488             Socat also offers history support:
489              
490             socat readline:history=/tmp/hist.corodebug /path/to/socket
491              
492             The server accepts connections until it is destroyed, so you must keep
493             the return value around as long as you want the server to stay available.
494              
495             =cut
496              
497             sub new_unix_server {
498 0     0 1   my ($class, $path) = @_;
499              
500 0           unlink $path;
501 0     0     my $unlink_guard = guard { unlink $path };
  0            
502              
503             AnyEvent::Socket::tcp_server "unix/", $path, sub {
504 0     0     my ($fh) = @_;
505 0           $unlink_guard; # mention it
506             Coro::async_pool {
507 0           $Coro::current->desc ("[Coro::Debug session]");
508 0           session $fh;
509 0           };
510 0 0         } or Carp::croak "Coro::Debug::new_unix_server($path): $!";
511             }
512              
513             =item $server = new_tcp_server Coro::Debug $port
514              
515             Similar to C, but binds on a TCP port. I
516             usually results in a gaping security hole>.
517              
518             Currently, only a TCPv4 socket is created, in the future, a TCPv6 socket
519             might also be created.
520              
521             =cut
522              
523             sub new_tcp_server {
524 0     0 1   my ($class, $port) = @_;
525              
526             AnyEvent::Socket::tcp_server undef, $port, sub {
527 0     0     my ($fh) = @_;
528             Coro::async_pool {
529 0           $Coro::current->desc ("[Coro::Debug session]");
530 0           session $fh;
531 0           };
532 0 0         } or Carp::croak "Coro::Debug::new_tcp_server($port): $!";
533             }
534              
535             sub DESTROY {
536 0     0     my ($self) = @_;
537              
538 0 0         unlink $self->{path} if exists $self->{path};
539 0           %$self = ();
540             }
541              
542             1;
543              
544             =back
545              
546             =head1 AUTHOR/SUPPORT/CONTACT
547              
548             Marc A. Lehmann
549             http://software.schmorp.de/pkg/Coro.html
550              
551             =cut
552              
553