ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Coro/Coro/Debug.pm
Revision: 1.72
Committed: Mon Nov 24 07:55:28 2008 UTC (15 years, 6 months ago) by root
Branch: MAIN
CVS Tags: rel-5_1, rel-5_11
Changes since 1.71: +1 -1 lines
Log Message:
5.1

File Contents

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