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 lets you list running
coroutines:

   > ps
        pid RUND  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 -U--  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:

   > p 5+7
   12

Or lets you eval perl code within other coroutines:

   > eval 18334288 $_
   1

=over 4

=cut

package Coro::Debug;

use strict;

use Carp ();
use IO::Socket::UNIX;
use AnyEvent;

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

sub find_coro {
   my ($pid) = @_;
   if (my ($coro) = grep $_ == $1, Coro::State::list) {
      $coro
   } else {
      print "$pid: no such coroutine\n";
      undef
   }
}

=item command $string

Execute a debugger command, sending any output to STDOUT. Used by
C<session>, below.

=cut

sub command($) {
   my ($cmd) = @_;

   $cmd =~ s/[\012\015]$//;

   if ($cmd =~ /^ps/) {
      printf "%20s %s%s%s%s %4s %-20.20s %s\n", "pid", "R", "U", "N", "D", "RSS", "description", "where";
      for my $coro (Coro::State::list) {
         Coro::cede;
         my @bt;
         $coro->_eval (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%s%s %4d %-20.20s %s\n",
                $coro+0,
                $coro->is_ready     ? "R" : "-",
                $coro->is_running   ? "U" : "-",
                $coro->is_new       ? "N" : "-",
                $coro->is_destroyed ? "D" : "-",
                $coro->rss / 1024,
                $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->_eval (sub { $bt = Carp::longmess "coroutine is" });
         if ($bt) {
            print $bt;
         } else {
            print "$1: unable to get backtrace\n";
         }
      }

   } elsif ($cmd =~ /p\s+(.*)$/) {
      my @res = eval $1;
      print $@ ? $@ : (join " ", @res) . "\n";

   } elsif ($cmd =~ /eval\s+(\d+)\s+(.*)$/) {
      if (my $coro = find_coro $1) {
         my $cmd = $2;
         my @res;
         $coro->_eval (sub { my @res = eval $cmd });
         print $@ ? $@ : (join " ", @res, "\n");
      }

   } elsif ($cmd =~ /^help/) {
      print <<EOF;
ps                      show the list of all coroutines
bt <pid>                show a full backtrace of coroutine <pid>
p <perl>                evaluate <perl> expression and print results
eval <pid> <perl>       evaluate <perl> expression in context of <pid> (dangerous!)
exit                    end this session

EOF

   } else {
      print "$cmd: unknown command\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;

   print "coro debug session. use help for more info\n\n";

   while ((print "> "), defined (my $cmd = $fh->readline ("\012"))) {
      if ($cmd =~ /^exit/) {
         print "bye.\n";
         last;
      }

      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.13
Committed:	Sat Sep 22 18:38:46 2007 UTC (16 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.12:	+1 -1 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			It mainly implements a very primitive debugger that lets you list running
20			coroutines:
21
22			> ps
23	root	1.12	pid RUND RSS description where
24			43383424 ---- 10 [async_pool idle] [/opt/perl/lib/perl5/Coro.pm:256]
25			46127008 ---- 5 worldmap updater [/opt/cf/ext/item-worldmap.ext:116]
26			18334288 ---- 4 music scheduler [/opt/cf/ext/player-env.ext:77]
27			24559856 ---- 14 [async_pool idle] [/opt/perl/lib/perl5/Coro.pm:256]
28			20170640 ---- 6 map scheduler [/opt/cf/ext/map-scheduler.ext:62]
29			18492336 ---- 5 player scheduler [/opt/cf/ext/login.ext:501]
30			15607952 ---- 2 timeslot manager [/opt/cf/cf.pm:382]
31			11015408 ---- 2 [unblock_sub schedul [/opt/perl/lib/perl5/Coro.pm:548]
32			11015088 ---- 2 [coro manager] [/opt/perl/lib/perl5/Coro.pm:170]
33			11014896 -U-- 835 [main::] [/opt/cf/ext/dm-support.ext:45]
34	root	1.1
35			Lets you do backtraces on about any coroutine:
36
37	root	1.12	> bt 18334288
38			coroutine is at /opt/cf/ext/player-env.ext line 77
39			eval {...} called at /opt/cf/ext/player-env.ext line 77
40			ext::player_env::__ANON__ called at -e line 0
41			Coro::_run_coro called at -e line 0
42	root	1.1
43			Or lets you eval perl code:
44
45			> p 5+7
46			12
47
48			Or lets you eval perl code within other coroutines:
49
50	root	1.12	> eval 18334288 $_
51	root	1.1	1
52
53			=over 4
54
55			=cut
56
57			package Coro::Debug;
58
59			use strict;
60
61			use Carp ();
62			use IO::Socket::UNIX;
63			use AnyEvent;
64
65	root	1.3	use Coro ();
66			use Coro::Handle ();
67			use Coro::State ();
68	root	1.1
69			sub find_coro {
70			my ($pid) = @_;
71			if (my ($coro) = grep $_ == $1, Coro::State::list) {
72			$coro
73			} else {
74			print "$pid: no such coroutine\n";
75			undef
76			}
77			}
78
79			=item command $string
80
81			Execute a debugger command, sending any output to STDOUT. Used by
82			C<session>, below.
83
84			=cut
85
86			sub command($) {
87			my ($cmd) = @_;
88
89			$cmd =~ s/[\012\015]$//;
90
91			if ($cmd =~ /^ps/) {
92	root	1.4	printf "%20s %s%s%s%s %4s %-20.20s %s\n", "pid", "R", "U", "N", "D", "RSS", "description", "where";
93	root	1.3	for my $coro (Coro::State::list) {
94	root	1.7	Coro::cede;
95	root	1.1	my @bt;
96	root	1.7	$coro->_eval (sub {
97			# we try to find the definite frame that gives msot useful info
98			# by skipping Coro frames and pseudo-frames.
99			for my $frame (1..10) {
100			my @frame = caller $frame;
101			@bt = @frame if $frame[2];
102			last unless $bt[0] =~ /^Coro/;
103			}
104			});
105	root	1.4	printf "%20s %s%s%s%s %4d %-20.20s %s\n",
106	root	1.1	$coro+0,
107			$coro->is_ready ? "R" : "-",
108			$coro->is_running ? "U" : "-",
109			$coro->is_new ? "N" : "-",
110			$coro->is_destroyed ? "D" : "-",
111	root	1.10	$coro->rss / 1024,
112	root	1.1	$coro->debug_desc,
113	root	1.7	(@bt ? sprintf "[%s:%d]", $bt[1], $bt[2] : "-");
114	root	1.1	}
115
116			} elsif ($cmd =~ /bt\s+(\d+)/) {
117			if (my $coro = find_coro $1) {
118			my $bt;
119	root	1.6	$coro->_eval (sub { $bt = Carp::longmess "coroutine is" });
120	root	1.1	if ($bt) {
121			print $bt;
122			} else {
123			print "$1: unable to get backtrace\n";
124			}
125			}
126
127			} elsif ($cmd =~ /p\s+(.*)$/) {
128	root	1.11	my @res = eval $1;
129			print $@ ? $@ : (join " ", @res) . "\n";
130	root	1.1
131			} elsif ($cmd =~ /eval\s+(\d+)\s+(.*)$/) {
132			if (my $coro = find_coro $1) {
133			my $cmd = $2;
134			my @res;
135			$coro->_eval (sub { my @res = eval $cmd });
136			print $@ ? $@ : (join " ", @res, "\n");
137			}
138
139			} elsif ($cmd =~ /^help/) {
140			print <<EOF;
141			ps show the list of all coroutines
142			bt <pid> show a full backtrace of coroutine <pid>
143			p <perl> evaluate <perl> expression and print results
144			eval <pid> <perl> evaluate <perl> expression in context of <pid> (dangerous!)
145			exit end this session
146
147			EOF
148
149			} else {
150			print "$cmd: unknown command\n";
151			}
152			}
153
154			=item session $fh
155
156			Run an interactive debugger session on the given filehandle. Each line entered
157			is simply passed to C<command>
158
159			=cut
160
161			sub session($) {
162			my ($fh) = @_;
163
164			$fh = Coro::Handle::unblock $fh;
165			select $fh;
166
167			print "coro debug session. use help for more info\n\n";
168
169			while ((print "> "), defined (my $cmd = $fh->readline ("\012"))) {
170			if ($cmd =~ /^exit/) {
171			print "bye.\n";
172			last;
173			}
174
175			command $cmd;
176			}
177			}
178
179			=item $server = new_unix_server Coro::Debug $path
180
181			Creates a new unix domain socket that listens for connection requests and
182			runs C<session> on any connection. Normal unix permission checks and umask
183			applies, so you can protect your socket by puttint it into a protected
184			directory.
185
186			The C<socat> utility is an excellent way to connect to this socket,
187			offering readline and history support:
188
189			socat readline:history=/tmp/hist.corodebug unix:/path/to/socket
190
191			The server accepts connections until it is destroyed, so you should keep
192			the return value around as long as you want the server to stay available.
193
194			=cut
195
196			sub new_unix_server {
197			my ($class, $path) = @_;
198
199			unlink $path;
200			my $fh = new IO::Socket::UNIX Listen => 1, Local => $path
201			or Carp::croak "Coro::Debug::Server($path): $!";
202
203			my $self = bless {
204			fh => $fh,
205			path => $path,
206			}, $class;
207
208	root	1.3	$self->{cw} = AnyEvent->io (fh => $fh, poll => 'r', cb => sub {
209			Coro::async_pool {
210	root	1.13	$Coro::current->desc ("[Coro::Debug session]");
211	root	1.3	my $fh = $fh->accept;
212			session $fh;
213			close $fh;
214			};
215	root	1.1	});
216
217			$self
218			}
219
220			sub DESTROY {
221			my ($self) = @_;
222
223			unlink $self->{path};
224			close $self->{fh};
225			%$self = ();
226			}
227
228			1;
229
230			=back
231
232			=head1 AUTHOR
233
234			Marc Lehmann <schmorp@schmorp.de>
235			http://home.schmorp.de/
236
237			=cut
238
239