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 AnyEvent ();
use AnyEvent::Util ();
use AnyEvent::Socket ();

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

our $VERSION = 5.1;

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