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 SS  RSS Description          Where
   11014896 US  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;

use Carp ();
use IO::Socket::UNIX;
use AnyEvent;
use Time::HiRes;
use Scalar::Util ();
use overload ();

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

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$/) {
      printf "%20s %s%s %4s %4s %-24.24s %s\n", "PID", "S", "S", "RSS", "USES", "Description", "Where";
      for my $coro (reverse Coro::State::list) {
         Coro::cede;
         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/;
            }
         });
         printf "%20s %s%s %4s %4s %-24.24s %s\n",
                $coro+0,
                $coro->is_new ? "N" : $coro->is_running ? "U" : $coro->is_ready ? "R" : "-",
                $coro->is_traced ? "T" : $coro->has_stack ? "S" : "-",
                format_num4 $coro->rss,
                format_num4 $coro->usecount,
                $coro->debug_desc,
                (@bt ? sprintf "[%s:%d]", $bt[1], $bt[2] : "-");
      }

   } 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 ($2);
      }

   } elsif ($cmd =~ /^help$/) {
      print <<EOF;
ps                      show the list of all coroutines
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;
      }
   }
}

=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,
offering readline and history support:

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

The server accepts connections until it is destroyed, so you should 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 $fh = new IO::Socket::UNIX Listen => 1, Local => $path
      or Carp::croak "Coro::Debug::Server($path): $!";

   my $self = bless {
      fh   => $fh,
      path => $path,
   }, $class;

   $self->{cw} = AnyEvent->io (fh => $fh, poll => 'r', cb => sub {
      if (my $fh = $fh->accept) {
         Coro::async_pool {
            $Coro::current->desc ("[Coro::Debug session]");
            session $fh;
         };
      }
   });

   $self
}

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

   unlink $self->{path};
   close $self->{fh};
   %$self = ();
}

1;

=back

=head1 AUTHOR

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

=cut


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