Coro/Coro/Debug.pm

=head1 NAME

Coro::Debug - various functions that help debugging Coro programs

=head1 SYNOPSIS

 use Coro::Debug;

 our $server = new_unix_server Coro::Debug "/tmp/socketpath";

 $ socat readline unix:/tmp/socketpath

=head1 DESCRIPTION

This module is an L<AnyEvent> user, you need to make sure that you use and
run a supported event loop.

This module provides some debugging facilities. Most will, if not handled
carefully, severely compromise the security of your program, so use it
only for debugging (or take other precautions).

It mainly implements a very primitive debugger that is evry easy to
integrate in your program:

   our $server = new_unix_server Coro::Debug "/tmp/somepath";
   # see new_unix_server, below, for more info

It lets you list running coroutines:

            state (rUnning, Ready, New or neither)
            |cctx allocated
            ||  resident set size (octets)
            ||  |   scheduled this many times
   > ps     ||  |   |
        PID SC  RSS USES Description              Where
   14572344 UC  62k 128k [main::]                 [dm-support.ext:47]
   14620056 -- 2260   13 [coro manager]           [Coro.pm:358]
   14620128 -- 2260  166 [unblock_sub scheduler]  [Coro.pm:358]
   17764008 N-  152    0 [EV idle process]        -
   13990784 -- 2596  10k timeslot manager         [cf.pm:454]
   81424176 --  18k 4758 [async pool idle]        [Coro.pm:257]
   23513336 -- 2624    1 follow handler           [follow.ext:52]
   40548312 --  15k 5597 player scheduler         [player-scheduler.ext:13]
   29138032 -- 2548  431 music scheduler          [player-env.ext:77]
   43449808 -- 2260 3493 worldmap updater         [item-worldmap.ext:115]
   33352488 --  19k 2845 [async pool idle]        [Coro.pm:257]
   81530072 --  13k  43k map scheduler            [map-scheduler.ext:65]
   30751144 --  15k 2204 [async pool idle]        [Coro.pm:257]

Lets you do backtraces on about any coroutine:

   > bt 18334288
   coroutine is at /opt/cf/ext/player-env.ext line 77
           eval {...} called at /opt/cf/ext/player-env.ext line 77
           ext::player_env::__ANON__ called at -e line 0
           Coro::_run_coro called at -e line 0

Or lets you eval perl code:

   > 5+7
   12

Or lets you eval perl code within other coroutines:

   > eval 18334288 caller(1); $DB::args[0]->method
   1

It can also trace subroutine entry/exits for most coroutines (those not
having recursed into a C function), resulting in output similar to:

   > loglevel 5
   > trace 94652688
   2007-09-27Z20:30:25.1368 (5) [94652688] enter Socket::sockaddr_in with (8481,\x{7f}\x{00}\x{00}\x{01})
   2007-09-27Z20:30:25.1369 (5) [94652688] leave Socket::sockaddr_in returning (\x{02}\x{00}...)
   2007-09-27Z20:30:25.1370 (5) [94652688] enter Net::FCP::Util::touc with (client_get)
   2007-09-27Z20:30:25.1371 (5) [94652688] leave Net::FCP::Util::touc returning (ClientGet)
   2007-09-27Z20:30:25.1372 (5) [94652688] enter AnyEvent::Impl::Event::io with (AnyEvent,fh,GLOB(0x9256250),poll,w,cb,CODE(0x8c963a0))
   2007-09-27Z20:30:25.1373 (5) [94652688] enter Event::Watcher::__ANON__ with (Event,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
   2007-09-27Z20:30:25.1374 (5) [94652688] enter Event::io::new with (Event::io,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
   2007-09-27Z20:30:25.1375 (5) [94652688] enter Event::Watcher::init with (Event::io=HASH(0x8bfb120),HASH(0x9b7940))

If your program uses the Coro::Debug::log facility:

   Coro::Debug::log 0, "important message";
   Coro::Debug::log 9, "unimportant message";

Then you can even receive log messages in any debugging session:

   > loglevel 5
   2007-09-26Z02:22:46 (9) unimportant message

Other commands are available in the shell, use the C<help> command for a list.

=head1 FUNCTIONS

None of the functions are being exported.

=over 4

=cut

package Coro::Debug;

use strict qw(subs vars);
no warnings;

use overload ();

use Carp ();
use Time::HiRes ();
use Scalar::Util ();

use Guard;

use AnyEvent ();
use AnyEvent::Util ();
use AnyEvent::Socket ();

use Coro ();
use Coro::Handle ();
use Coro::State ();
use Coro::AnyEvent ();
use Coro::Timer ();

our $VERSION = 5.14;

our %log;
our $SESLOGLEVEL = exists $ENV{PERL_CORO_DEFAULT_LOGLEVEL} ? $ENV{PERL_CORO_DEFAULT_LOGLEVEL} : -1;
our $ERRLOGLEVEL = exists $ENV{PERL_CORO_STDERR_LOGLEVEL}  ? $ENV{PERL_CORO_STDERR_LOGLEVEL}  : -1;

sub find_coro {
   my ($pid) = @_;

   if (my ($coro) = grep $_ == $pid, Coro::State::list) {
      $coro
   } else {
      print "$pid: no such coroutine\n";
      undef
   }
}

sub format_msg($$) {
   my ($time, $micro) = Time::HiRes::gettimeofday;
   my ($sec, $min, $hour, $day, $mon, $year) = gmtime $time;
   my $date = sprintf "%04d-%02d-%02dZ%02d:%02d:%02d.%04d",
                      $year + 1900, $mon + 1, $day, $hour, $min, $sec, $micro / 100;
   sprintf "%s (%d) %s", $date, $_[0], $_[1]
}

sub format_num4($) {
   my ($v) = @_;

   return sprintf "%4d"   , $v                     if $v <  1e4;
   # 1e5 redundant
   return sprintf "%3.0fk", $v /             1_000 if $v <  1e6;
   return sprintf "%1.1fM", $v /         1_000_000 if $v <  1e7 * .995;
   return sprintf "%3.0fM", $v /         1_000_000 if $v <  1e9;
   return sprintf "%1.1fG", $v /     1_000_000_000 if $v < 1e10 * .995;
   return sprintf "%3.0fG", $v /     1_000_000_000 if $v < 1e12;
   return sprintf "%1.1fT", $v / 1_000_000_000_000 if $v < 1e13 * .995;
   return sprintf "%3.0fT", $v / 1_000_000_000_000 if $v < 1e15;

   "++++"
}

=item log $level, $msg

Log a debug message of the given severity level (0 is highest, higher is
less important) to all interested parties.

=item stderr_loglevel $level

Set the loglevel for logging to stderr (defaults to the value of the
environment variable PERL_CORO_STDERR_LOGLEVEL, or -1 if missing).

=item session_loglevel $level

Set the default loglevel for new coro debug sessions (defaults to the
value of the environment variable PERL_CORO_DEFAULT_LOGLEVEL, or -1 if
missing).

=cut

sub log($$) {
   my ($level, $msg) = @_;
   $msg =~ s/\s*$/\n/;
   $_->($level, $msg) for values %log;
   printf STDERR format_msg $level, $msg if $level <= $ERRLOGLEVEL;
}

sub session_loglevel($) {
   $SESLOGLEVEL = shift;
}

sub stderr_loglevel($) {
   $ERRLOGLEVEL = shift;
}

=item trace $coro, $loglevel

Enables tracing the given coroutine at the given loglevel. If loglevel is
omitted, use 5. If coro is omitted, trace the current coroutine. Tracing
incurs a very high runtime overhead.

It is not uncommon to enable tracing on oneself by simply calling
C<Coro::Debug::trace>.

A message will be logged at the given loglevel if it is not possible to
enable tracing.

=item untrace $coro

Disables tracing on the given coroutine.

=cut

sub trace {
   my ($coro, $loglevel) = @_;

   $coro ||= $Coro::current;
   $loglevel = 5 unless defined $loglevel;

   (Coro::async {
      if (eval { Coro::State::trace $coro, Coro::State::CC_TRACE | Coro::State::CC_TRACE_SUB; 1 }) {
         Coro::Debug::log $loglevel, sprintf "[%d] tracing enabled", $coro + 0;
         $coro->{_trace_line_cb} = sub {
            Coro::Debug::log $loglevel, sprintf "[%d] at %s:%d\n", $Coro::current+0, @_;
         };
         $coro->{_trace_sub_cb} = sub {
            Coro::Debug::log $loglevel, sprintf "[%d] %s %s %s\n",
               $Coro::current+0,
               $_[0] ? "enter" : "leave",
               $_[1],
               $_[2] ? ($_[0] ? "with (" : "returning (") . (
                  join ",",
                     map {
                        my $x = ref $_ ? overload::StrVal $_ : $_;
                        (substr $x, 40) = "..." if 40 + 3 < length $x;
                        $x =~ s/([^\x20-\x5b\x5d-\x7e])/sprintf "\\x{%02x}", ord $1/ge;
                        $x
                     } @{$_[2]}
               ) . ")" : "";
         };

         undef $coro; # the subs keep a reference which we do not want them to do
      } else {
         Coro::Debug::log $loglevel, sprintf "[%d] unable to enable tracing: %s", $Coro::current + 0, $@;
      }
   })->prio (Coro::PRIO_MAX);

   Coro::cede;
}

sub untrace {
   my ($coro) = @_;

   $coro ||= $Coro::current;

   (Coro::async {
      Coro::State::trace $coro, 0;
      delete $coro->{_trace_sub_cb};
      delete $coro->{_trace_line_cb};
   })->prio (Coro::PRIO_MAX);

   Coro::cede;
}

=item command $string

Execute a debugger command, sending any output to STDOUT. Used by
C<session>, below.

=cut

sub command($) {
   my ($cmd) = @_;

   $cmd =~ s/\s+$//;

   if ($cmd =~ /^ps (?:\s* (\S+))? $/x) {
      my $times = Coro::State::enable_times;
      my $flags = $1;
      my $verbose = $flags =~ /v/;
      my $desc_format = $flags =~ /w/ ? "%-24s" : "%-24.24s";
      my $tim0_format = $times ? " %7s %7s " : " ";
      my $tim1_format = $times ? " %7.3f %7.3f " : " ";
      my $buf = sprintf "%20s %s%s %4s %4s$tim0_format$desc_format %s\n",
                        "PID", "S", "C", "RSS", "USES",
                        $times ? ("t_real", "t_cpu") : (),
                        "Description", "Where";
      for my $coro (reverse Coro::State::list) {
         my @bt;
         Coro::State::call ($coro, sub {
            # we try to find *the* definite frame that gives msot useful info
            # by skipping Coro frames and pseudo-frames.
            for my $frame (1..10) {
               my @frame = caller $frame;
               @bt = @frame if $frame[2];
               last unless $bt[0] =~ /^Coro/;
            }
         });
         $bt[1] =~ s/^.*[\/\\]// if @bt && !$verbose;
         $buf .= sprintf "%20s %s%s %4s %4s$tim1_format$desc_format %s\n",
                         $coro+0,
                         $coro->is_new ? "N" : $coro->is_running ? "U" : $coro->is_ready ? "R" : "-",
                         $coro->is_traced ? "T" : $coro->has_cctx ? "C" : "-",
                         format_num4 $coro->rss,
                         format_num4 $coro->usecount,
                         $times ? $coro->times : (),
                         $coro->debug_desc,
                         (@bt ? sprintf "[%s:%d]", $bt[1], $bt[2] : "-");
      }
      print $buf;

   } elsif ($cmd =~ /^bt\s+(\d+)$/) {
      if (my $coro = find_coro $1) {
         my $bt;
         Coro::State::call ($coro, sub {
            local $Carp::CarpLevel = 2;
            $bt = eval { Carp::longmess "coroutine is" } || "$@";
         });
         if ($bt) {
            print $bt;
         } else {
            print "$1: unable to get backtrace\n";
         }
      }

   } elsif ($cmd =~ /^(?:e|eval)\s+(\d+)\s+(.*)$/) {
      if (my $coro = find_coro $1) {
         my $cmd = eval "sub { $2 }";
         my @res;
         Coro::State::call ($coro, sub { @res = eval { &$cmd } });
         print $@ ? $@ : (join " ", @res, "\n");
      }

   } elsif ($cmd =~ /^(?:tr|trace)\s+(\d+)$/) {
      if (my $coro = find_coro $1) {
         trace $coro;
      }

   } elsif ($cmd =~ /^(?:ut|untrace)\s+(\d+)$/) {
      if (my $coro = find_coro $1) {
         untrace $coro;
      }

   } elsif ($cmd =~ /^cancel\s+(\d+)$/) {
      if (my $coro = find_coro $1) {
         $coro->cancel;
      }

   } elsif ($cmd =~ /^ready\s+(\d+)$/) {
      if (my $coro = find_coro $1) {
         $coro->ready;
      }

   } elsif ($cmd =~ /^kill\s+(\d+)(?:\s+(.*))?$/) {
      my $reason = defined $2 ? $2 : "killed";

      if (my $coro = find_coro $1) {
         $coro->throw ($reason);
      }

   } elsif ($cmd =~ /^enable_times(\s+\S.*)?\s*$/) {
      my $enable = defined $1 ? 1*eval $1 : !Coro::State::enable_times;

      Coro::State::enable_times $enable;

      print "per-thread real and process time gathering ", $enable ? "enabled" : "disabled", ".\n";

   } elsif ($cmd =~ /^help$/) {
      print <<EOF;
ps [w|v]                show the list of all coroutines (wide, verbose)
bt <pid>                show a full backtrace of coroutine <pid>
eval <pid> <perl>       evaluate <perl> expression in context of <pid>
trace <pid>             enable tracing for this coroutine
untrace <pid>           disable tracing for this coroutine
kill <pid> <reason>     throws the given <reason> string in <pid>
cancel <pid>            cancels this coroutine
ready <pid>             force <pid> into the ready queue
enable_times <enable>   enable or disable time profiling in ps
<anything else>         evaluate as perl and print results
<anything else> &       same as above, but evaluate asynchronously
                        you can use (find_coro <pid>) in perl expressions
                        to find the coro with the given pid, e.g.
                        (find_coro 9768720)->ready
EOF

   } elsif ($cmd =~ /^(.*)&$/) {
      my $cmd = $1;
      my $sub = eval "sub { $cmd }";
      my $fh = select;
      Coro::async_pool {
         $Coro::current->{desc} = $cmd;
         my $t = Time::HiRes::time;
         my @res = eval { &$sub };
         $t = Time::HiRes::time - $t;
         print {$fh}
            "\rcommand: $cmd\n",
            "execution time: $t\n",
            "result: ", $@ ? $@ : (join " ", @res) . "\n",
            "> ";
      };

   } else {
      my @res = eval $cmd;
      print $@ ? $@ : (join " ", @res) . "\n";
   }
}

=item session $fh

Run an interactive debugger session on the given filehandle. Each line entered
is simply passed to C<command>.

=cut

sub session($) {
   my ($fh) = @_;

   $fh = Coro::Handle::unblock $fh;
   my $old_fh = select $fh;
   my $guard = guard { select $old_fh };

   my $loglevel = $SESLOGLEVEL;
   local $log{$Coro::current} = sub {
      return unless $_[0] <= $loglevel;
      print $fh "\015", (format_msg $_[0], $_[1]), "> ";
   };

   print "coro debug session. use help for more info\n\n";

   while ((print "> "), defined (my $cmd = $fh->readline ("\012"))) {
      if ($cmd =~ /^exit\s*$/) {
         print "bye.\n";
         last;

      } elsif ($cmd =~ /^(?:ll|loglevel)\s*(\d+)?\s*/) {
         $loglevel = defined $1 ? $1 : -1;

      } elsif ($cmd =~ /^(?:w|watch)\s*([0-9.]*)\s+(.*)/) {
         my ($time, $cmd) = ($1*1 || 1, $2);
         my $cancel;

         Coro::async {
            $Coro::current->{desc} = "watch $cmd";
            select $fh;
            until ($cancel) {
               command $cmd;
               Coro::Timer::sleep $time;
            }
         };

         $fh->readable;
         $cancel = 1;

      } elsif ($cmd =~ /^help\s*/) {
         command $cmd;
         print <<EOF;
loglevel <int>          enable logging for messages of level <int> and lower
watch <time> <command>  repeat the given command until STDIN becomes readable
exit                    end this session
EOF
      } else {
         command $cmd;
      }

      Coro::cede;
   }
}

=item $server = new_unix_server Coro::Debug $path

Creates a new unix domain socket that listens for connection requests and
runs C<session> on any connection. Normal unix permission checks and umask
applies, so you can protect your socket by puttint it into a protected
directory.

The C<socat> utility is an excellent way to connect to this socket:

   socat readline /path/to/socket

Socat also offers history support:

   socat readline:history=/tmp/hist.corodebug /path/to/socket

The server accepts connections until it is destroyed, so you must keep
the return value around as long as you want the server to stay available.

=cut

sub new_unix_server {
   my ($class, $path) = @_;

   unlink $path;
   my $unlink_guard = guard { unlink $path };

   AnyEvent::Socket::tcp_server "unix/", $path, sub {
      my ($fh) = @_;
      $unlink_guard; # mention it
      Coro::async_pool {
         $Coro::current->desc ("[Coro::Debug session]");
         session $fh;
      };
   } or Carp::croak "Coro::Debug::new_unix_server($path): $!";
}

=item $server = new_tcp_server Coro::Debug $port

Similar to C<new_unix_server>, but binds on a TCP port. I<Note that this is
usually results in a gaping security hole>.

Currently, only a TCPv4 socket is created, in the future, a TCPv6 socket
might also be created.

=cut

sub new_tcp_server {
   my ($class, $port) = @_;

   AnyEvent::Socket::tcp_server undef, $port, sub {
      my ($fh) = @_;
      Coro::async_pool {
         $Coro::current->desc ("[Coro::Debug session]");
         session $fh;
      };
   } or Carp::croak "Coro::Debug::new_tcp_server($port): $!";
}

sub DESTROY {
   my ($self) = @_;

   unlink $self->{path} if exists $self->{path};
   %$self = ();
}

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut


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