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 very 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 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 = 6.53;

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) = Coro::Util::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 most 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 = Coro::Util::time;
         my @res = eval { &$sub };
         $t = Coro::Util::time - $t;
         print {$fh}
            "\rcommand: $cmd\n",
            "execution time: $t\n",
            "result: ", $@ ? $@ : (join " ", @res) . "\n",
            "> ";
      };

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

   local $| = 1;
}

=item session $fh

Run an interactive debugger session on the given filehandle. Each line entered
is simply passed to C<command> (with a few exceptions).

=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/SUPPORT/CONTACT

   Marc A. Lehmann <schmorp@schmorp.de>
   http://software.schmorp.de/pkg/Coro.html

=cut


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