Coro/Coro/Debug.pm

=head1 NAME

Coro::Debug - various functions that help debugging Coro programs

=head1 SYNOPSIS

 use Coro::Debug;

 our $server = new_server Coro::Debug path => "/tmp/socketpath";

 $ socat readline: unix:/tmp/socketpath

=head1 DESCRIPTION

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

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

=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 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 $_ == $1, 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]
}

=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_pool {
      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]}
               ) . ")" : "";
         };
      } 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::State::trace $coro, 0;
   delete $coro->{_tracr_sub_cb};
   delete $coro->{_trace_line_cb};
}

=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 %-24.24s %s\n", "pid", "S", "S", "RSS", "description", "where";
      for my $coro (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 %4d %-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" : "-",
                $coro->rss / 1000,
                $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 { $bt = 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 =~ /^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
<anything else>         evaluate as perl and print results
<anything else> &       same as above, but evaluate asynchronously
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;
   select $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 {
      Coro::async_pool {
         $Coro::current->desc ("[Coro::Debug session]");
         my $fh = $fh->accept;
         session $fh;
         close $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.29
Committed:	Thu Sep 27 20:35:08 2007 UTC (16 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.28:	+11 -2 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			our $server = new_server Coro::Debug path => "/tmp/socketpath";
10
11	root	1.8	$ socat readline: unix:/tmp/socketpath
12	root	1.1
13			=head1 DESCRIPTION
14
15			This module provides some debugging facilities. Most will, if not handled
16			carefully, severely compromise the security of your program, so use it
17			only for debugging (or take other precautions).
18
19	root	1.29	It mainly implements a very primitive debugger that is evry easy to
20			integrate in your program:
21
22			our $server = new_unix_server Coro::Debug "/tmp/somepath";
23			# see new_unix_server, below, for more info
24
25			It lets you list running coroutines:
26	root	1.1
27	root	1.18	state
28			\|cctx allocated
29			\|\| resident set size (kb)
30			> ps \|\| \|
31	root	1.16	pid SS RSS description where
32			43383424 -- 10 [async_pool idle] [/opt/perl/lib/perl5/Coro.pm:256]
33			46127008 -- 5 worldmap updater [/opt/cf/ext/item-worldmap.ext:116]
34			18334288 -- 4 music scheduler [/opt/cf/ext/player-env.ext:77]
35			24559856 -- 14 [async_pool idle] [/opt/perl/lib/perl5/Coro.pm:256]
36			20170640 -- 6 map scheduler [/opt/cf/ext/map-scheduler.ext:62]
37			18492336 -- 5 player scheduler [/opt/cf/ext/login.ext:501]
38			15607952 -- 2 timeslot manager [/opt/cf/cf.pm:382]
39			11015408 -- 2 [unblock_sub schedul [/opt/perl/lib/perl5/Coro.pm:548]
40			11015088 -- 2 [coro manager] [/opt/perl/lib/perl5/Coro.pm:170]
41			11014896 US 835 [main::] [/opt/cf/ext/dm-support.ext:45]
42	root	1.1
43			Lets you do backtraces on about any coroutine:
44
45	root	1.12	> bt 18334288
46			coroutine is at /opt/cf/ext/player-env.ext line 77
47			eval {...} called at /opt/cf/ext/player-env.ext line 77
48			ext::player_env::__ANON__ called at -e line 0
49			Coro::_run_coro called at -e line 0
50	root	1.1
51			Or lets you eval perl code:
52
53	root	1.18	> 5+7
54	root	1.1	12
55
56			Or lets you eval perl code within other coroutines:
57
58	root	1.18	> eval 18334288 caller(1); $DB::args[0]->method
59	root	1.1	1
60
61	root	1.26	It can also trace subroutine entry/exits for most coroutines (those not
62	root	1.28	recursing into a C function), resulting in output similar to:
63
64			> loglevel 5
65			> trace 94652688
66			2007-09-27Z20:30:25.1368 (5) [94652688] enter Socket::sockaddr_in with (8481,\x{7f}\x{00}\x{00}\x{01})
67			2007-09-27Z20:30:25.1369 (5) [94652688] leave Socket::sockaddr_in returning (\x{02}\x{00}...)
68			2007-09-27Z20:30:25.1370 (5) [94652688] enter Net::FCP::Util::touc with (client_get)
69			2007-09-27Z20:30:25.1371 (5) [94652688] leave Net::FCP::Util::touc returning (ClientGet)
70			2007-09-27Z20:30:25.1372 (5) [94652688] enter AnyEvent::Impl::Event::io with (AnyEvent,fh,GLOB(0x9256250),poll,w,cb,CODE(0x8c963a0))
71			2007-09-27Z20:30:25.1373 (5) [94652688] enter Event::Watcher::__ANON__ with (Event,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
72			2007-09-27Z20:30:25.1374 (5) [94652688] enter Event::io::new with (Event::io,poll,w,fd,GLOB(0x9256250),cb,CODE(0x8c963a0))
73			2007-09-27Z20:30:25.1375 (5) [94652688] enter Event::Watcher::init with (Event::io=HASH(0x8bfb120),HASH(0x9b7940))
74	root	1.26
75	root	1.19	If your program uses the Coro::Debug::log facility:
76
77			Coro::Debug::log 0, "important message";
78			Coro::Debug::log 9, "unimportant message";
79
80			Then you can even receive log messages in any debugging session:
81
82			> loglevel 5
83			2007-09-26Z02:22:46 (9) unimportant message
84
85	root	1.29	=head1 FUNCTIONS
86
87			None of the functions are being exported.
88
89	root	1.1	=over 4
90
91			=cut
92
93			package Coro::Debug;
94
95			use strict;
96
97			use Carp ();
98			use IO::Socket::UNIX;
99			use AnyEvent;
100	root	1.20	use Time::HiRes;
101	root	1.23	use overload ();
102	root	1.1
103	root	1.3	use Coro ();
104			use Coro::Handle ();
105			use Coro::State ();
106	root	1.1
107	root	1.19	our %log;
108	root	1.23	our $SESLOGLEVEL = exists $ENV{PERL_CORO_DEFAULT_LOGLEVEL} ? $ENV{PERL_CORO_DEFAULT_LOGLEVEL} : -1;
109			our $ERRLOGLEVEL = exists $ENV{PERL_CORO_STDERR_LOGLEVEL} ? $ENV{PERL_CORO_STDERR_LOGLEVEL} : -1;
110	root	1.19
111	root	1.1	sub find_coro {
112			my ($pid) = @_;
113			if (my ($coro) = grep $_ == $1, Coro::State::list) {
114			$coro
115			} else {
116			print "$pid: no such coroutine\n";
117			undef
118			}
119			}
120
121	root	1.23	sub format_msg($$) {
122			my ($time, $micro) = Time::HiRes::gettimeofday;
123			my ($sec, $min, $hour, $day, $mon, $year) = gmtime $time;
124			my $date = sprintf "%04d-%02d-%02dZ%02d:%02d:%02d.%04d",
125			$year + 1900, $mon + 1, $day, $hour, $min, $sec, $micro / 100;
126			sprintf "%s (%d) %s", $date, $_[0], $_[1]
127			}
128
129	root	1.19	=item log $level, $msg
130
131			Log a debug message of the given severity level (0 is highest, higher is
132			less important) to all interested parties.
133
134	root	1.23	=item stderr_loglevel $level
135
136			Set the loglevel for logging to stderr (defaults to the value of the
137			environment variable PERL_CORO_STDERR_LOGLEVEL, or -1 if missing).
138
139			=item session_loglevel $level
140	root	1.22
141			Set the default loglevel for new coro debug sessions (defaults to the
142			value of the environment variable PERL_CORO_DEFAULT_LOGLEVEL, or -1 if
143			missing).
144
145	root	1.19	=cut
146
147			sub log($$) {
148			my ($level, $msg) = @_;
149			$msg =~ s/\s*$/\n/;
150			$_->($level, $msg) for values %log;
151	root	1.23	printf STDERR format_msg $level, $msg if $level <= $ERRLOGLEVEL;
152	root	1.19	}
153
154	root	1.23	sub session_loglevel($) {
155			$SESLOGLEVEL = shift;
156			}
157
158			sub stderr_loglevel($) {
159			$ERRLOGLEVEL = shift;
160	root	1.22	}
161
162			=item trace $coro, $loglevel
163
164			Enables tracing the given coroutine at the given loglevel. If loglevel is
165			omitted, use 5. If coro is omitted, trace the current coroutine. Tracing
166			incurs a very high runtime overhead.
167
168			It is not uncommon to enable tracing on oneself by simply calling
169			C<Coro::Debug::trace>.
170
171			A message will be logged at the given loglevel if it is not possible to
172			enable tracing.
173
174			=item untrace $coro
175
176			Disables tracing on the given coroutine.
177
178			=cut
179
180			sub trace {
181			my ($coro, $loglevel) = @_;
182
183			$coro \|\|= $Coro::current;
184			$loglevel = 5 unless defined $loglevel;
185
186			(Coro::async_pool {
187	root	1.25	if (eval { Coro::State::trace $coro, Coro::State::CC_TRACE \| Coro::State::CC_TRACE_SUB; 1 }) {
188	root	1.24	Coro::Debug::log $loglevel, sprintf "[%d] tracing enabled", $coro + 0;
189	root	1.23	$coro->{_trace_line_cb} = sub {
190	root	1.24	Coro::Debug::log $loglevel, sprintf "[%d] at %s:%d\n", $Coro::current+0, @_;
191	root	1.23	};
192			$coro->{_trace_sub_cb} = sub {
193			Coro::Debug::log $loglevel, sprintf "[%d] %s %s %s\n",
194			$Coro::current+0,
195			$_[0] ? "enter" : "leave",
196			$_[1],
197			$_[2] ? ($_[0] ? "with (" : "returning (") . (
198			join ",",
199			map {
200			my $x = ref $_ ? overload::StrVal $_ : $_;
201			(substr $x, 40) = "..." if 40 + 3 < length $x;
202			$x =~ s/([^\x20-\x5b\x5d-\x7e])/sprintf "\\x{%02x}", ord $1/ge;
203			$x
204			} @{$_[2]}
205			) . ")" : "";
206	root	1.22	};
207			} else {
208			Coro::Debug::log $loglevel, sprintf "[%d] unable to enable tracing: %s", $Coro::current + 0, $@;
209			}
210			})->prio (Coro::PRIO_MAX);
211
212			Coro::cede;
213			}
214
215			sub untrace {
216			my ($coro) = @_;
217
218	root	1.25	Coro::State::trace $coro, 0;
219	root	1.23	delete $coro->{_tracr_sub_cb};
220			delete $coro->{_trace_line_cb};
221	root	1.22	}
222
223	root	1.1	=item command $string
224
225			Execute a debugger command, sending any output to STDOUT. Used by
226			C<session>, below.
227
228			=cut
229
230			sub command($) {
231			my ($cmd) = @_;
232
233	root	1.18	$cmd =~ s/\s+$//;
234	root	1.1
235	root	1.18	if ($cmd =~ /^ps$/) {
236	root	1.15	printf "%20s %s%s %4s %-24.24s %s\n", "pid", "S", "S", "RSS", "description", "where";
237	root	1.3	for my $coro (Coro::State::list) {
238	root	1.7	Coro::cede;
239	root	1.1	my @bt;
240	root	1.17	Coro::State::call ($coro, sub {
241	root	1.7	# we try to find the definite frame that gives msot useful info
242			# by skipping Coro frames and pseudo-frames.
243			for my $frame (1..10) {
244			my @frame = caller $frame;
245			@bt = @frame if $frame[2];
246			last unless $bt[0] =~ /^Coro/;
247			}
248			});
249	root	1.15	printf "%20s %s%s %4d %-24.24s %s\n",
250	root	1.1	$coro+0,
251	root	1.14	$coro->is_new ? "N" : $coro->is_running ? "U" : $coro->is_ready ? "R" : "-",
252	root	1.23	$coro->is_traced ? "T" : $coro->has_stack ? "S" : "-",
253	root	1.18	$coro->rss / 1000,
254	root	1.1	$coro->debug_desc,
255	root	1.7	(@bt ? sprintf "[%s:%d]", $bt[1], $bt[2] : "-");
256	root	1.1	}
257
258	root	1.18	} elsif ($cmd =~ /^bt\s+(\d+)$/) {
259	root	1.1	if (my $coro = find_coro $1) {
260			my $bt;
261	root	1.17	Coro::State::call ($coro, sub { $bt = Carp::longmess "coroutine is" });
262	root	1.1	if ($bt) {
263			print $bt;
264			} else {
265			print "$1: unable to get backtrace\n";
266			}
267			}
268
269	root	1.26	} elsif ($cmd =~ /^(?:e\|eval)\s+(\d+)\s+(.*)$/) {
270	root	1.1	if (my $coro = find_coro $1) {
271	root	1.26	my $cmd = eval "sub { $2 }";
272	root	1.1	my @res;
273	root	1.26	Coro::State::call ($coro, sub { @res = eval { &$cmd } });
274	root	1.1	print $@ ? $@ : (join " ", @res, "\n");
275			}
276
277	root	1.26	} elsif ($cmd =~ /^(?:tr\|trace)\s+(\d+)$/) {
278	root	1.22	if (my $coro = find_coro $1) {
279			trace $coro;
280			}
281
282	root	1.26	} elsif ($cmd =~ /^(?:ut\|untrace)\s+(\d+)$/) {
283	root	1.22	if (my $coro = find_coro $1) {
284			untrace $coro;
285			}
286
287	root	1.18	} elsif ($cmd =~ /^help$/) {
288	root	1.1	print <<EOF;
289	root	1.20	ps show the list of all coroutines
290			bt <pid> show a full backtrace of coroutine <pid>
291			eval <pid> <perl> evaluate <perl> expression in context of <pid>
292	root	1.22	trace <pid> enable tracing for this coroutine
293			untrace <pid> disable tracing for this coroutine
294	root	1.18	<anything else> evaluate as perl and print results
295	root	1.20	<anything else> & same as above, but evaluate asynchronously
296	root	1.1	EOF
297
298	root	1.20	} elsif ($cmd =~ /^(.*)&$/) {
299	root	1.27	my $cmd = $1;
300			my $sub = eval "sub { $cmd }";
301	root	1.20	my $fh = select;
302			Coro::async_pool {
303	root	1.26	$Coro::current->{desc} = $cmd;
304	root	1.20	my $t = Time::HiRes::time;
305	root	1.27	my @res = eval { &$sub };
306	root	1.20	$t = Time::HiRes::time - $t;
307			print {$fh}
308			"\rcommand: $cmd\n",
309			"execution time: $t\n",
310			"result: ", $@ ? $@ : (join " ", @res) . "\n",
311			"> ";
312			};
313	root	1.22
314	root	1.1	} else {
315	root	1.18	my @res = eval $cmd;
316			print $@ ? $@ : (join " ", @res) . "\n";
317	root	1.1	}
318			}
319
320			=item session $fh
321
322			Run an interactive debugger session on the given filehandle. Each line entered
323	root	1.18	is simply passed to C<command>.
324	root	1.1
325			=cut
326
327			sub session($) {
328			my ($fh) = @_;
329
330			$fh = Coro::Handle::unblock $fh;
331			select $fh;
332
333	root	1.23	my $loglevel = $SESLOGLEVEL;
334	root	1.19	local $log{$Coro::current} = sub {
335			return unless $_[0] <= $loglevel;
336	root	1.23	print $fh "\015", (format_msg $_[0], $_[1]), "> ";
337	root	1.19	};
338
339	root	1.1	print "coro debug session. use help for more info\n\n";
340
341			while ((print "> "), defined (my $cmd = $fh->readline ("\012"))) {
342	root	1.18	if ($cmd =~ /^exit\s*$/) {
343	root	1.1	print "bye.\n";
344			last;
345	root	1.22
346	root	1.26	} elsif ($cmd =~ /^(?:ll\|loglevel)\s(\d+)?\s/) {
347	root	1.22	$loglevel = defined $1 ? $1 : -1;
348
349	root	1.19	} elsif ($cmd =~ /^help\s*/) {
350			command $cmd;
351			print <<EOF;
352			loglevel <int> enable logging for messages of level <int> and lower
353	root	1.21	exit end this session
354	root	1.19	EOF
355			} else {
356			command $cmd;
357	root	1.1	}
358			}
359			}
360
361			=item $server = new_unix_server Coro::Debug $path
362
363			Creates a new unix domain socket that listens for connection requests and
364			runs C<session> on any connection. Normal unix permission checks and umask
365			applies, so you can protect your socket by puttint it into a protected
366			directory.
367
368			The C<socat> utility is an excellent way to connect to this socket,
369			offering readline and history support:
370
371			socat readline:history=/tmp/hist.corodebug unix:/path/to/socket
372
373			The server accepts connections until it is destroyed, so you should keep
374			the return value around as long as you want the server to stay available.
375
376			=cut
377
378			sub new_unix_server {
379			my ($class, $path) = @_;
380
381			unlink $path;
382			my $fh = new IO::Socket::UNIX Listen => 1, Local => $path
383			or Carp::croak "Coro::Debug::Server($path): $!";
384
385			my $self = bless {
386			fh => $fh,
387			path => $path,
388			}, $class;
389
390	root	1.3	$self->{cw} = AnyEvent->io (fh => $fh, poll => 'r', cb => sub {
391			Coro::async_pool {
392	root	1.13	$Coro::current->desc ("[Coro::Debug session]");
393	root	1.3	my $fh = $fh->accept;
394			session $fh;
395			close $fh;
396			};
397	root	1.1	});
398
399			$self
400			}
401
402			sub DESTROY {
403			my ($self) = @_;
404
405			unlink $self->{path};
406			close $self->{fh};
407			%$self = ();
408			}
409
410			1;
411
412			=back
413
414			=head1 AUTHOR
415
416			Marc Lehmann <schmorp@schmorp.de>
417			http://home.schmorp.de/
418
419			=cut
420
421