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