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
            |cctx allocated
            ||   resident set size (kb)
   > ps     ||   |
        PID SC  RSS Description          Where
   11014896 UC  835 [main::]             [/opt/cf/ext/dm-support.ext:45]
   11015088 --    2 [coro manager]       [/opt/perl/lib/perl5/Coro.pm:170]
   11015408 --    2 [unblock_sub schedul [/opt/perl/lib/perl5/Coro.pm:548]
   15607952 --    2 timeslot manager     [/opt/cf/cf.pm:382]
   18492336 --    5 player scheduler     [/opt/cf/ext/login.ext:501]
   20170640 --    6 map scheduler        [/opt/cf/ext/map-scheduler.ext:62]
   24559856 --   14 [async_pool idle]    [/opt/perl/lib/perl5/Coro.pm:256]
   18334288 --    4 music scheduler      [/opt/cf/ext/player-env.ext:77]
   46127008 --    5 worldmap updater     [/opt/cf/ext/item-worldmap.ext:116]
   43383424 --   10 [async_pool idle]    [/opt/perl/lib/perl5/Coro.pm:256]

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
recursing 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.0";

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.71
Committed:	Thu Nov 20 09:37:21 2008 UTC (15 years, 6 months ago) by root
Branch:	MAIN
CVS Tags:	rel-5_0
Changes since 1.70:	+1 -1 lines
Log Message:	5.0
#	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.18	state
31			\|cctx allocated
32			\|\| resident set size (kb)
33			> ps \|\| \|
34	root	1.49	PID SC RSS Description Where
35			11014896 UC 835 [main::] [/opt/cf/ext/dm-support.ext:45]
36	root	1.37	11015088 -- 2 [coro manager] [/opt/perl/lib/perl5/Coro.pm:170]
37			11015408 -- 2 [unblock_sub schedul [/opt/perl/lib/perl5/Coro.pm:548]
38			15607952 -- 2 timeslot manager [/opt/cf/cf.pm:382]
39			18492336 -- 5 player scheduler [/opt/cf/ext/login.ext:501]
40			20170640 -- 6 map scheduler [/opt/cf/ext/map-scheduler.ext:62]
41			24559856 -- 14 [async_pool idle] [/opt/perl/lib/perl5/Coro.pm:256]
42			18334288 -- 4 music scheduler [/opt/cf/ext/player-env.ext:77]
43			46127008 -- 5 worldmap updater [/opt/cf/ext/item-worldmap.ext:116]
44	root	1.16	43383424 -- 10 [async_pool idle] [/opt/perl/lib/perl5/Coro.pm:256]
45	root	1.1
46			Lets you do backtraces on about any coroutine:
47
48	root	1.12	> bt 18334288
49			coroutine is at /opt/cf/ext/player-env.ext line 77
50			eval {...} called at /opt/cf/ext/player-env.ext line 77
51			ext::player_env::__ANON__ called at -e line 0
52			Coro::_run_coro called at -e line 0
53	root	1.1
54			Or lets you eval perl code:
55
56	root	1.18	> 5+7
57	root	1.1	12
58
59			Or lets you eval perl code within other coroutines:
60
61	root	1.18	> eval 18334288 caller(1); $DB::args[0]->method
62	root	1.1	1
63
64	root	1.26	It can also trace subroutine entry/exits for most coroutines (those not
65	root	1.28	recursing into a C function), resulting in output similar to:
66
67			> loglevel 5
68			> trace 94652688
69			2007-09-27Z20:30:25.1368 (5) [94652688] enter Socket::sockaddr_in with (8481,\x{7f}\x{00}\x{00}\x{01})
70			2007-09-27Z20:30:25.1369 (5) [94652688] leave Socket::sockaddr_in returning (\x{02}\x{00}...)
71			2007-09-27Z20:30:25.1370 (5) [94652688] enter Net::FCP::Util::touc with (client_get)
72			2007-09-27Z20:30:25.1371 (5) [94652688] leave Net::FCP::Util::touc returning (ClientGet)
73			2007-09-27Z20:30:25.1372 (5) [94652688] enter AnyEvent::Impl::Event::io with (AnyEvent,fh,GLOB(0x9256250),poll,w,cb,CODE(0x8c963a0))
74			2007-09-27Z20:30:25.1373 (5) [94652688] enter Event::Watcher::__ANON__ with (Event,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
75			2007-09-27Z20:30:25.1374 (5) [94652688] enter Event::io::new with (Event::io,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
76			2007-09-27Z20:30:25.1375 (5) [94652688] enter Event::Watcher::init with (Event::io=HASH(0x8bfb120),HASH(0x9b7940))
77	root	1.26
78	root	1.19	If your program uses the Coro::Debug::log facility:
79
80			Coro::Debug::log 0, "important message";
81			Coro::Debug::log 9, "unimportant message";
82
83			Then you can even receive log messages in any debugging session:
84
85			> loglevel 5
86			2007-09-26Z02:22:46 (9) unimportant message
87
88	root	1.47	Other commands are available in the shell, use the C<help> command for a list.
89
90	root	1.29	=head1 FUNCTIONS
91
92			None of the functions are being exported.
93
94	root	1.1	=over 4
95
96			=cut
97
98			package Coro::Debug;
99
100	root	1.53	use strict qw(subs vars);
101	root	1.52	no warnings;
102	root	1.1
103	root	1.51	use overload ();
104
105	root	1.1	use Carp ();
106	root	1.51	use Time::HiRes ();
107	root	1.39	use Scalar::Util ();
108	root	1.51
109			use AnyEvent ();
110	root	1.66	use AnyEvent::Util ();
111	root	1.61	use AnyEvent::Socket ();
112	root	1.1
113	root	1.3	use Coro ();
114			use Coro::Handle ();
115			use Coro::State ();
116	root	1.51	use Coro::AnyEvent ();
117	root	1.1
118	root	1.71	our $VERSION = "5.0";
119	root	1.53
120	root	1.19	our %log;
121	root	1.23	our $SESLOGLEVEL = exists $ENV{PERL_CORO_DEFAULT_LOGLEVEL} ? $ENV{PERL_CORO_DEFAULT_LOGLEVEL} : -1;
122			our $ERRLOGLEVEL = exists $ENV{PERL_CORO_STDERR_LOGLEVEL} ? $ENV{PERL_CORO_STDERR_LOGLEVEL} : -1;
123	root	1.19
124	root	1.1	sub find_coro {
125			my ($pid) = @_;
126	root	1.30
127	root	1.31	if (my ($coro) = grep $_ == $pid, Coro::State::list) {
128	root	1.1	$coro
129			} else {
130			print "$pid: no such coroutine\n";
131			undef
132			}
133			}
134
135	root	1.23	sub format_msg($$) {
136			my ($time, $micro) = Time::HiRes::gettimeofday;
137			my ($sec, $min, $hour, $day, $mon, $year) = gmtime $time;
138			my $date = sprintf "%04d-%02d-%02dZ%02d:%02d:%02d.%04d",
139			$year + 1900, $mon + 1, $day, $hour, $min, $sec, $micro / 100;
140			sprintf "%s (%d) %s", $date, $_[0], $_[1]
141			}
142
143	root	1.32	sub format_num4($) {
144			my ($v) = @_;
145
146			return sprintf "%4d" , $v if $v < 1e4;
147			# 1e5 redundant
148			return sprintf "%3.0fk", $v / 1_000 if $v < 1e6;
149			return sprintf "%1.1fM", $v / 1_000_000 if $v < 1e7 * .995;
150			return sprintf "%3.0fM", $v / 1_000_000 if $v < 1e9;
151			return sprintf "%1.1fG", $v / 1_000_000_000 if $v < 1e10 * .995;
152			return sprintf "%3.0fG", $v / 1_000_000_000 if $v < 1e12;
153			return sprintf "%1.1fT", $v / 1_000_000_000_000 if $v < 1e13 * .995;
154			return sprintf "%3.0fT", $v / 1_000_000_000_000 if $v < 1e15;
155
156			"++++"
157			}
158
159	root	1.19	=item log $level, $msg
160
161			Log a debug message of the given severity level (0 is highest, higher is
162			less important) to all interested parties.
163
164	root	1.23	=item stderr_loglevel $level
165
166			Set the loglevel for logging to stderr (defaults to the value of the
167			environment variable PERL_CORO_STDERR_LOGLEVEL, or -1 if missing).
168
169			=item session_loglevel $level
170	root	1.22
171			Set the default loglevel for new coro debug sessions (defaults to the
172			value of the environment variable PERL_CORO_DEFAULT_LOGLEVEL, or -1 if
173			missing).
174
175	root	1.19	=cut
176
177			sub log($$) {
178			my ($level, $msg) = @_;
179			$msg =~ s/\s*$/\n/;
180			$_->($level, $msg) for values %log;
181	root	1.23	printf STDERR format_msg $level, $msg if $level <= $ERRLOGLEVEL;
182	root	1.19	}
183
184	root	1.23	sub session_loglevel($) {
185			$SESLOGLEVEL = shift;
186			}
187
188			sub stderr_loglevel($) {
189			$ERRLOGLEVEL = shift;
190	root	1.22	}
191
192			=item trace $coro, $loglevel
193
194			Enables tracing the given coroutine at the given loglevel. If loglevel is
195			omitted, use 5. If coro is omitted, trace the current coroutine. Tracing
196			incurs a very high runtime overhead.
197
198			It is not uncommon to enable tracing on oneself by simply calling
199			C<Coro::Debug::trace>.
200
201			A message will be logged at the given loglevel if it is not possible to
202			enable tracing.
203
204			=item untrace $coro
205
206			Disables tracing on the given coroutine.
207
208			=cut
209
210			sub trace {
211			my ($coro, $loglevel) = @_;
212
213			$coro \|\|= $Coro::current;
214			$loglevel = 5 unless defined $loglevel;
215
216	root	1.40	(Coro::async {
217	root	1.25	if (eval { Coro::State::trace $coro, Coro::State::CC_TRACE \| Coro::State::CC_TRACE_SUB; 1 }) {
218	root	1.24	Coro::Debug::log $loglevel, sprintf "[%d] tracing enabled", $coro + 0;
219	root	1.23	$coro->{_trace_line_cb} = sub {
220	root	1.24	Coro::Debug::log $loglevel, sprintf "[%d] at %s:%d\n", $Coro::current+0, @_;
221	root	1.23	};
222			$coro->{_trace_sub_cb} = sub {
223			Coro::Debug::log $loglevel, sprintf "[%d] %s %s %s\n",
224			$Coro::current+0,
225			$_[0] ? "enter" : "leave",
226			$_[1],
227			$_[2] ? ($_[0] ? "with (" : "returning (") . (
228			join ",",
229			map {
230			my $x = ref $_ ? overload::StrVal $_ : $_;
231			(substr $x, 40) = "..." if 40 + 3 < length $x;
232			$x =~ s/([^\x20-\x5b\x5d-\x7e])/sprintf "\\x{%02x}", ord $1/ge;
233			$x
234			} @{$_[2]}
235			) . ")" : "";
236	root	1.22	};
237	root	1.39
238			undef $coro; # the subs keep a reference which we do not want them to do
239	root	1.22	} else {
240			Coro::Debug::log $loglevel, sprintf "[%d] unable to enable tracing: %s", $Coro::current + 0, $@;
241			}
242			})->prio (Coro::PRIO_MAX);
243
244			Coro::cede;
245			}
246
247			sub untrace {
248			my ($coro) = @_;
249
250	root	1.32	$coro \|\|= $Coro::current;
251
252	root	1.40	(Coro::async {
253	root	1.32	Coro::State::trace $coro, 0;
254	root	1.39	delete $coro->{_trace_sub_cb};
255	root	1.32	delete $coro->{_trace_line_cb};
256			})->prio (Coro::PRIO_MAX);
257
258			Coro::cede;
259	root	1.22	}
260
261	root	1.1	=item command $string
262
263			Execute a debugger command, sending any output to STDOUT. Used by
264			C<session>, below.
265
266			=cut
267
268			sub command($) {
269			my ($cmd) = @_;
270
271	root	1.18	$cmd =~ s/\s+$//;
272	root	1.1
273	root	1.57	if ($cmd =~ /^ps (?:\s* (\S+))? $/x) {
274	root	1.56	my $flags = $1;
275			my $desc = $flags =~ /w/ ? "%-24s" : "%-24.24s";
276	root	1.70	my $verbose = $flags =~ /v/;
277	root	1.57	my $buf = sprintf "%20s %s%s %4s %4s $desc %s\n",
278			"PID", "S", "C", "RSS", "USES", "Description", "Where";
279	root	1.37	for my $coro (reverse Coro::State::list) {
280	root	1.1	my @bt;
281	root	1.17	Coro::State::call ($coro, sub {
282	root	1.7	# we try to find the definite frame that gives msot useful info
283			# by skipping Coro frames and pseudo-frames.
284			for my $frame (1..10) {
285			my @frame = caller $frame;
286			@bt = @frame if $frame[2];
287			last unless $bt[0] =~ /^Coro/;
288			}
289			});
290	root	1.70	$bt[1] =~ s/^.*[\/\\]// if @bt && !$verbose;
291	root	1.57	$buf .= sprintf "%20s %s%s %4s %4s $desc %s\n",
292			$coro+0,
293			$coro->is_new ? "N" : $coro->is_running ? "U" : $coro->is_ready ? "R" : "-",
294			$coro->is_traced ? "T" : $coro->has_cctx ? "C" : "-",
295			format_num4 $coro->rss,
296			format_num4 $coro->usecount,
297			$coro->debug_desc,
298			(@bt ? sprintf "[%s:%d]", $bt[1], $bt[2] : "-");
299	root	1.1	}
300	root	1.57	print $buf;
301	root	1.1
302	root	1.18	} elsif ($cmd =~ /^bt\s+(\d+)$/) {
303	root	1.1	if (my $coro = find_coro $1) {
304			my $bt;
305	root	1.44	Coro::State::call ($coro, sub {
306	root	1.45	local $Carp::CarpLevel = 2;
307	root	1.44	$bt = eval { Carp::longmess "coroutine is" } \|\| "$@";
308			});
309	root	1.1	if ($bt) {
310			print $bt;
311			} else {
312			print "$1: unable to get backtrace\n";
313			}
314			}
315
316	root	1.26	} elsif ($cmd =~ /^(?:e\|eval)\s+(\d+)\s+(.*)$/) {
317	root	1.1	if (my $coro = find_coro $1) {
318	root	1.26	my $cmd = eval "sub { $2 }";
319	root	1.1	my @res;
320	root	1.26	Coro::State::call ($coro, sub { @res = eval { &$cmd } });
321	root	1.1	print $@ ? $@ : (join " ", @res, "\n");
322			}
323
324	root	1.26	} elsif ($cmd =~ /^(?:tr\|trace)\s+(\d+)$/) {
325	root	1.22	if (my $coro = find_coro $1) {
326			trace $coro;
327			}
328
329	root	1.26	} elsif ($cmd =~ /^(?:ut\|untrace)\s+(\d+)$/) {
330	root	1.22	if (my $coro = find_coro $1) {
331			untrace $coro;
332			}
333
334	root	1.47	} elsif ($cmd =~ /^cancel\s+(\d+)$/) {
335			if (my $coro = find_coro $1) {
336			$coro->cancel;
337			}
338
339			} elsif ($cmd =~ /^ready\s+(\d+)$/) {
340			if (my $coro = find_coro $1) {
341			$coro->ready;
342			}
343
344			} elsif ($cmd =~ /^kill\s+(\d+)(?:\s+(.*))?$/) {
345	root	1.50	my $reason = defined $2 ? $2 : "killed";
346
347	root	1.47	if (my $coro = find_coro $1) {
348	root	1.50	$coro->throw ($reason);
349	root	1.47	}
350
351	root	1.18	} elsif ($cmd =~ /^help$/) {
352	root	1.1	print <<EOF;
353	root	1.70	ps [w\|v] show the list of all coroutines (wide, verbose)
354	root	1.20	bt <pid> show a full backtrace of coroutine <pid>
355			eval <pid> <perl> evaluate <perl> expression in context of <pid>
356	root	1.22	trace <pid> enable tracing for this coroutine
357			untrace <pid> disable tracing for this coroutine
358	root	1.47	kill <pid> <reason> throws the given <reason> string in <pid>
359			cancel <pid> cancels this coroutine
360			ready <pid> force <pid> into the ready queue
361	root	1.18	<anything else> evaluate as perl and print results
362	root	1.20	<anything else> & same as above, but evaluate asynchronously
363	root	1.47	you can use (find_coro <pid>) in perl expressions
364			to find the coro with the given pid, e.g.
365			(find_coro 9768720)->ready
366	root	1.1	EOF
367
368	root	1.20	} elsif ($cmd =~ /^(.*)&$/) {
369	root	1.27	my $cmd = $1;
370			my $sub = eval "sub { $cmd }";
371	root	1.20	my $fh = select;
372			Coro::async_pool {
373	root	1.26	$Coro::current->{desc} = $cmd;
374	root	1.20	my $t = Time::HiRes::time;
375	root	1.27	my @res = eval { &$sub };
376	root	1.20	$t = Time::HiRes::time - $t;
377			print {$fh}
378			"\rcommand: $cmd\n",
379			"execution time: $t\n",
380			"result: ", $@ ? $@ : (join " ", @res) . "\n",
381			"> ";
382			};
383	root	1.22
384	root	1.1	} else {
385	root	1.18	my @res = eval $cmd;
386			print $@ ? $@ : (join " ", @res) . "\n";
387	root	1.1	}
388			}
389
390			=item session $fh
391
392			Run an interactive debugger session on the given filehandle. Each line entered
393	root	1.18	is simply passed to C<command>.
394	root	1.1
395			=cut
396
397			sub session($) {
398			my ($fh) = @_;
399
400			$fh = Coro::Handle::unblock $fh;
401	root	1.36	my $old_fh = select $fh;
402			my $guard = Coro::guard { select $old_fh };
403	root	1.1
404	root	1.23	my $loglevel = $SESLOGLEVEL;
405	root	1.19	local $log{$Coro::current} = sub {
406			return unless $_[0] <= $loglevel;
407	root	1.23	print $fh "\015", (format_msg $_[0], $_[1]), "> ";
408	root	1.19	};
409
410	root	1.1	print "coro debug session. use help for more info\n\n";
411
412			while ((print "> "), defined (my $cmd = $fh->readline ("\012"))) {
413	root	1.18	if ($cmd =~ /^exit\s*$/) {
414	root	1.1	print "bye.\n";
415			last;
416	root	1.22
417	root	1.26	} elsif ($cmd =~ /^(?:ll\|loglevel)\s(\d+)?\s/) {
418	root	1.22	$loglevel = defined $1 ? $1 : -1;
419
420	root	1.19	} elsif ($cmd =~ /^help\s*/) {
421			command $cmd;
422			print <<EOF;
423			loglevel <int> enable logging for messages of level <int> and lower
424	root	1.21	exit end this session
425	root	1.19	EOF
426			} else {
427			command $cmd;
428	root	1.1	}
429	root	1.69
430			Coro::cede;
431	root	1.1	}
432			}
433
434			=item $server = new_unix_server Coro::Debug $path
435
436			Creates a new unix domain socket that listens for connection requests and
437			runs C<session> on any connection. Normal unix permission checks and umask
438			applies, so you can protect your socket by puttint it into a protected
439			directory.
440
441	root	1.61	The C<socat> utility is an excellent way to connect to this socket:
442
443			socat readline /path/to/socket
444	root	1.1
445	root	1.61	Socat also offers history support:
446	root	1.1
447	root	1.61	socat readline:history=/tmp/hist.corodebug /path/to/socket
448
449			The server accepts connections until it is destroyed, so you must keep
450	root	1.1	the return value around as long as you want the server to stay available.
451
452			=cut
453
454			sub new_unix_server {
455			my ($class, $path) = @_;
456
457			unlink $path;
458	root	1.66	my $unlink_guard = AnyEvent::Util::guard { unlink $path };
459
460	root	1.61	AnyEvent::Socket::tcp_server "unix/", $path, sub {
461			my ($fh) = @_;
462	root	1.66	$unlink_guard; # mention it
463	root	1.61	Coro::async_pool {
464			$Coro::current->desc ("[Coro::Debug session]");
465			session $fh;
466			};
467			} or Carp::croak "Coro::Debug::new_unix_server($path): $!";
468			}
469
470			=item $server = new_tcp_server Coro::Debug $port
471
472			Similar to C<new_unix_server>, but binds on a TCP port. I<Note that this is
473			usually results in a gaping security hole>.
474	root	1.1
475	root	1.61	Currently, only a TCPv4 socket is created, in the future, a TCPv6 socket
476			might also be created.
477
478			=cut
479
480			sub new_tcp_server {
481			my ($class, $port) = @_;
482	root	1.1
483	root	1.61	AnyEvent::Socket::tcp_server undef, $port, sub {
484			my ($fh) = @_;
485			Coro::async_pool {
486			$Coro::current->desc ("[Coro::Debug session]");
487			session $fh;
488			};
489			} or Carp::croak "Coro::Debug::new_tcp_server($port): $!";
490	root	1.1	}
491
492			sub DESTROY {
493			my ($self) = @_;
494
495	root	1.62	unlink $self->{path} if exists $self->{path};
496	root	1.1	%$self = ();
497			}
498
499			1;
500
501			=back
502
503			=head1 AUTHOR
504
505			Marc Lehmann <schmorp@schmorp.de>
506			http://home.schmorp.de/
507
508			=cut
509
510