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 common::sense;

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.22;

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;
}

sub ps_listing {
   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 ? " %9s %8s " : " ";
   my $tim1_format = $times ? " %9.3f %8.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] : "-");
   }

   $buf
}

=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) {
      print ps_listing;

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