lib/AnyEvent/Debug.pm

=head1 NAME

AnyEvent::Debug - debugging utilities for AnyEvent

=head1 SYNOPSIS

   use AnyEvent::Debug;

   # create an interactive shell into the program
   my $shell = AnyEvent::Debug::shell "unix/", "/home/schmorp/myshell";
   # then on the shell: "socat readline /home/schmorp/myshell"

=head1 DESCRIPTION

This module provides functionality hopefully useful for debugging.

At the moment, "only" an interactive shell is implemented. This shell
allows you to interactively "telnet into" your program and execute Perl
code, e.g. to look at global variables.

=head1 FUNCTIONS

=over 4

=cut

package AnyEvent::Debug;

use B ();
use Carp ();
use Errno ();

use AnyEvent (); BEGIN { AnyEvent::common_sense }
use AnyEvent::Util ();
use AnyEvent::Socket ();
use AnyEvent::Log ();

our $TRACE = 1; # trace status

our ($TRACE_LOGGER, $TRACE_ENABLED);

# cache often-used strings, purely to save memory, at the expense of speed
our %STRCACHE;

=item $shell = AnyEvent::Debug::shell $host, $service

This function binds on the given host and service port and returns a
shell object, which determines the lifetime of the shell. Any number
of connections are accepted on the port, and they will give you a very
primitive shell that simply executes every line you enter.

All commands will be executed "blockingly" with the socket C<select>ed for
output. For a less "blocking" interface see L<Coro::Debug>.

The commands will be executed in the C<AnyEvent::Debug::shell> package,
which currently has "help" and a few other commands, and can be freely
modified by all shells. Code is evaluated under C<use strict 'subs'>.

Every shell has a logging context (C<$LOGGER>) that is attached to
C<$AnyEvent::Log::COLLECT>), which is especially useful to gether debug
and trace messages.

As a general programming guide, consider the beneficial aspects of
using more global (C<our>) variables than local ones (C<my>) in package
scope: Earlier all my modules tended to hide internal variables inside
C<my> variables, so users couldn't accidentally access them. Having
interactive access to your programs changed that: having internal
variables still in the global scope means you can debug them easier.

As no authentication is done, in most cases it is best not to use a TCP
port, but a unix domain socket, whcih can be put wherever you can access
it, but not others:

   our $SHELL = AnyEvent::Debug::shell "unix/", "/home/schmorp/shell";

Then you can use a tool to connect to the shell, such as the ever
versatile C<socat>, which in addition can give you readline support:

   socat readline /home/schmorp/shell
   # or:
   cd /home/schmorp; socat readline unix:shell

Socat can even give you a persistent history:

   socat readline,history=.anyevent-history unix:shell

Binding on C<127.0.0.1> (or C<::1>) might be a less secure but sitll not
totally insecure (on single-user machines) alternative to let you use
other tools, such as telnet:

   our $SHELL = AnyEvent::Debug::shell "127.1", "1357";

And then:

   telnet localhost 1357

=cut

sub shell($$) {
   local $TRACE = 0;

   AnyEvent::Socket::tcp_server $_[0], $_[1], sub {
      my ($fh, $host, $port) = @_;

      syswrite $fh, "Welcome, $host:$port, use 'help' for more info!\015\012> ";
      my $rbuf;

      my $logger = new AnyEvent::Log::Ctx
         log_cb => sub {
            syswrite $fh, shift;
            0
         };

      my $logger_guard = AnyEvent::Util::guard {
         $AnyEvent::Log::COLLECT->detach ($logger);
      };
      $AnyEvent::Log::COLLECT->attach ($logger);

      local $TRACE = 0;
      my $rw; $rw = AE::io $fh, 0, sub {
         my $len = sysread $fh, $rbuf, 1024, length $rbuf;

         $logger_guard if 0; # reference it

         if (defined $len ? $len == 0 : ($! != Errno::EAGAIN && $! != Errno::EWOULDBLOCK)) {
            undef $rw;
         } else {
            while ($rbuf =~ s/^(.*)\015?\012//) {
               my $line = $1;

               AnyEvent::fh_block $fh;

               if ($line =~ /^\s*exit\b/) {
                  syswrite $fh, "sorry, no... if you want to execute exit, try CORE::exit.\015\012";
               } elsif ($line =~ /^\s*coro\b\s*(.*)/) {
                  my $arg = $1;
                  if (eval { require Coro; require Coro::Debug }) {
                     if ($arg =~ /\S/) {
                        Coro::async (sub {
                           select $fh;
                           Coro::Debug::command ($arg);
                           local $| = 1; # older Coro versions do not flush
                           syswrite $fh, "> ";
                        });
                        return;
                     } else {
                        undef $rw;
                        syswrite $fh, "switching to Coro::Debug...\015\012";
                        Coro::async (sub { Coro::Debug::session ($fh) });
                        return;
                     }
                  } else {
                     syswrite $fh, "Coro not available.\015\012";
                  }

               } else {
                  package AnyEvent::Debug::shell;

                  no strict 'vars';
                  local $LOGGER = $logger;
                  my $old_stdout = select $fh;
                  local $| = 1;

                  my @res = eval $line;

                  select $old_stdout;
                  syswrite $fh, "$@" if $@;
                  syswrite $fh, "\015\012";

                  if (@res > 1) {
                     syswrite $fh, "$_: $res[$_]\015\012" for 0 .. $#res;
                  } elsif (@res == 1) {
                     syswrite $fh, "$res[0]\015\012";
                  }
               }

               syswrite $fh, "> ";
               AnyEvent::fh_unblock $fh;
            }
         }
      };
   }
}

{
   package AnyEvent::Debug::shell;

   our $LOGGER;

   sub help() {
      <<EOF
help         this command
wr [level]   sets wrap level to level (or toggles if missing)
v [level]    sets verbosity (or toggles between 0 and 9 if missing)
wl 'regex'   print wrapped watchers matching the regex (or all if missing)
i id,...     prints the watcher with the given ids in more detail
t            enable tracing for newly created watchers (enabled by default)
ut           disable tracing for newly created watchers
t  id,...    enable tracing for the given watcher (enabled by default)
ut id,...    disable tracing for the given watcher
w id,...     converts the watcher ids to watcher objects (for scripting)
coro xxx     run xxx as Coro::Debug shell command, if available
coro         switch to Coro::Debug shell, if available
EOF
   }

   sub wl(;$) {
      my $re = @_ ? qr<$_[0]>i : qr<.>;

      my %res;

      while (my ($k, $v) = each %AnyEvent::Debug::Wrapped) {
         my $s = "$v";
         $res{$s} = $k . (exists $v->{error} ? "*" : " ")
            if $s =~ $re;
      }

      join "", map "$res{$_} $_\n", sort keys %res
   }

   sub w {
      map {
         $AnyEvent::Debug::Wrapped{$_} || do {
            print "$_: no such wrapped watcher.\n";
            ()
         }
      } @_
   }

   sub i {
      join "",
         map $_->id . " $_\n" . $_->verbose . "\n",
            &w
   }

   sub wr {
      AnyEvent::Debug::wrap (@_);

      "wrap level now $AnyEvent::Debug::WRAP_LEVEL"
   }

   sub t {
      if (@_) {
         @_ = &w;
         $_->trace (1)
            for @_;
         "tracing enabled for @_."
      } else {
         $AnyEvent::Debug::TRACE = 1;
         "tracing for newly created watchers is now enabled."
      }
   }

   sub u {
      if (@_) {
         @_ = &w;
         $_->trace (0)
            for @_;
         "tracing disabled for @_."
      } else {
         $AnyEvent::Debug::TRACE = 0;
         "tracing for newly created watchers is now disabled."
      }
   }

   sub v {
      $LOGGER->level (@_ ? $_[0] : $LOGGER->[1] ? 0 : 9);

      "verbose logging is now " . ($LOGGER->[1] ? "enabled" : "disabled") . "."
   }
}

=item AnyEvent::Debug::wrap [$level]

Sets the instrumenting/wrapping level of all watchers that are being
created after this call. If no C<$level> has been specified, then it
toggles between C<0> and C<1>.

The default wrap level is C<0>, or whatever
C<$ENV{PERL_ANYEVENT_DEBUG_WRAP}> specifies.

A level of C<0> disables wrapping, i.e. AnyEvent works normally, and in
its most efficient mode.

A level of C<1> or higher enables wrapping, which replaces all watchers
by AnyEvent::Debug::Wrapped objects, stores the location where a
watcher was created and wraps the callback to log all invocations at
"trace" loglevel if tracing is enabled fore the watcher. The initial
state of tracing when creating a watcher is taken from the global
variable C<$AnyEvent:Debug::TRACE>. The default value of that variable
is C<1>, but it can make sense to set it to C<0> and then do C<< local
$AnyEvent::Debug::TRACE = 1 >> in a block where you create "interesting"
watchers. Tracing can also be enabled and disabled later by calling the
watcher's C<trace> method.

The wrapper will also count how many times the callback was invoked and
will record up to ten runtime errors with corresponding backtraces. It
will also log runtime errors at "error" loglevel.

To see the trace messages, you can invoke your program with
C<PERL_ANYEVENT_VERBOSE=9>, or you can use AnyEvent::Log to divert
the trace messages in any way you like (the EXAMPLES section in
L<AnyEvent::Log> has some examples).

A level of C<2> does everything that level C<1> does, but also stores a
full backtrace of the location the watcher was created, which slows down
watcher creation considerably.

Every wrapped watcher will be linked into C<%AnyEvent::Debug::Wrapped>,
with its address as key. The C<wl> command in the debug shell can be used
to list watchers.

Instrumenting can increase the size of each watcher multiple times, and,
especially when backtraces are involved, also slows down watcher creation
a lot.

Also, enabling and disabling instrumentation will not recover the full
performance that you had before wrapping (the AE::xxx functions will stay
slower, for example).

If you are developing your program, also consider using AnyEvent::Strict
to check for common mistakes.

=cut

our $WRAP_LEVEL;
our $TRACE_CUR;
our $POST_DETECT;

sub wrap(;$) {
   my $PREV_LEVEL = $WRAP_LEVEL;
   $WRAP_LEVEL = @_ ? 0+shift : $WRAP_LEVEL ? 0 : 1;

   if ($AnyEvent::MODEL) {
      if ($WRAP_LEVEL && !$PREV_LEVEL) {
         $TRACE_LOGGER = AnyEvent::Log::logger trace => \$TRACE_ENABLED;
         AnyEvent::_isa_hook 0 => "AnyEvent::Debug::Wrap", 1;
         AnyEvent::Debug::Wrap::_reset ();
      } elsif (!$WRAP_LEVEL && $PREV_LEVEL) {
         AnyEvent::_isa_hook 0 => undef;
      }
   } else {
      $POST_DETECT ||= AnyEvent::post_detect {
         undef $POST_DETECT;
         return unless $WRAP_LEVEL;

         (my $level, $WRAP_LEVEL) = ($WRAP_LEVEL, undef);

         require AnyEvent::Strict unless $AnyEvent::Strict::VERSION;

         AnyEvent::post_detect { # make sure we run after AnyEvent::Strict
            wrap ($level);
         };
      };
   }
}

=item AnyEvent::Debug::path2mod $path

Tries to replace a path (e.g. the file name returned by caller)
by a module name. Returns the path unchanged if it fails.

Example:

   print AnyEvent::Debug::path2mod "/usr/lib/perl5/AnyEvent/Debug.pm";
   # might print "AnyEvent::Debug"

=cut

sub path2mod($) {
   keys %INC; # reset iterator

   while (my ($k, $v) = each %INC) {
      if ($_[0] eq $v) {
         $k =~ s%/%::%g if $k =~ s/\.pm$//;
         return $k;
      }
   }

   my $path = shift;

   $path =~ s%^\./%%;

   $path
}

=item AnyEvent::Debug::cb2str $cb

Using various gambits, tries to convert a callback (e.g. a code reference)
into a more useful string.

Very useful if you debug a program and have some callback, but you want to
know where in the program the callback is actually defined.

=cut

sub cb2str($) {
   my $cb = shift;

   "CODE" eq ref $cb
      or return "$cb";

   eval {
      my $cv = B::svref_2object ($cb);

      my $gv = $cv->GV
         or return "$cb";

      my $name = $gv->NAME;

      return (AnyEvent::Debug::path2mod $gv->FILE) . ":" . $gv->LINE
         if $name eq "__ANON__";

      $gv->STASH->NAME . "::" . $name;
   } || "$cb"
}

sub sv2str($) {
   if (ref $_[0]) {
      if (ref $_[0] eq "CODE") {
         return "$_[0]=" . cb2str $_[0];
      } else {
         return "$_[0]";
      }
   } else {
      for ("\'$_[0]\'") { # make copy
         substr $_, $Carp::MaxArgLen, length, "'..."
            if length > $Carp::MaxArgLen;
         return $_;
      }
   }
}

=item AnyEvent::Debug::backtrace [$skip]

Creates a backtrace (actually an AnyEvent::Debug::Backtrace object
that you can stringify), not unlike the Carp module would. Unlike the
Carp module it resolves some references (such as callbacks) to more
user-friendly strings, has a more succinct output format and most
importantly: doesn't leak memory like hell.

The reason it creates an object is to save time, as formatting can be
done at a later time. Still, creating a backtrace is a relatively slow
operation.

=cut

sub backtrace(;$) {
   my $w = shift;

   my (@bt, @c);
   my ($modlen, $sub);

   for (;;) {
      #         0          1      2            3         4           5          6            7       8         9         10
      # ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash)
      package DB;
      @c = caller $w++
         or last;
      package AnyEvent::Debug; # no block for speed reasons

      if ($c[7]) {
         $sub = "require $c[6]";
      } elsif (defined $c[6]) {
         $sub = "eval \"\"";
      } else {
         $sub = ($c[4] ? "" : "&") . $c[3];

         $sub .= "("
                 . (join ",",
                       map sv2str $DB::args[$_],
                          0 .. (@DB::args < $Carp::MaxArgNums ? @DB::args : $Carp::MaxArgNums) - 1)
                 . ")"
            if $c[4];
      }

      push @bt, [\($STRCACHE{$c[1]} ||= $c[1]), $c[2], $sub];
   }

   @DB::args = ();

   bless \@bt, "AnyEvent::Debug::Backtrace"
}

=back

=cut

package AnyEvent::Debug::Wrap;

use AnyEvent (); BEGIN { AnyEvent::common_sense }
use Scalar::Util ();
use Carp ();

sub _reset {
   for my $name (qw(io timer signal child idle)) {
      my $super = "SUPER::$name";

      *$name = sub {
         my ($self, %arg) = @_;

         my $w;

         my $t = $TRACE;

         my ($pkg, $file, $line, $sub);
         
         $w = 0;
         do {
            ($pkg, $file, $line) = caller $w++;
         } while $pkg =~ /^(?:AE|AnyEvent::(?:Socket|Handle|Util|Debug|Strict|Base|CondVar|CondVar::Base|Impl::.*)|Coro::AnyEvent::CondVar)$/;

         $sub = (caller $w)[3];

         my $cb = $arg{cb};
         $arg{cb} = sub {
            ++$w->{called};

            local $TRACE_CUR = $w;

            $TRACE_LOGGER->("enter $w") if $TRACE_ENABLED && $t;
            eval {
               local $SIG{__DIE__} = sub {
                  die $_[0] . AnyEvent::Debug::backtrace
                     if defined $^S;
               };
               &$cb;
            };
            if ($@) {
               my $err = "$@";
               push @{ $w->{error} }, [AE::now, $err]
                  if @{ $w->{error} } < 10;
               AE::log die => "($w) $err"
                  or warn "($w) $err";
            }
            $TRACE_LOGGER->("leave $w") if $TRACE_ENABLED && $t;
         };

         $self = bless {
            type   => $name,
            w      => $self->$super (%arg),
            rfile  => \($STRCACHE{$file} ||= $file),
            line   => $line,
            sub    => $sub,
            cur    => "$TRACE_CUR",
            now    => AE::now,
            arg    => \%arg,
            cb     => $cb,
            called => 0,
            rt     => \$t,
         }, "AnyEvent::Debug::Wrapped";

         delete $arg{cb};

         $self->{bt} = AnyEvent::Debug::backtrace 1
            if $WRAP_LEVEL >= 2;

         Scalar::Util::weaken ($w = $self);
         Scalar::Util::weaken ($AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $self} = $self);

         $TRACE_LOGGER->("creat $w") if $TRACE_ENABLED && $t;

         $self
      };
   }
}

package AnyEvent::Debug::Wrapped;

=head1 THE AnyEvent::Debug::Wrapped CLASS

All watchers created while the wrap level is non-zero will be wrapped
inside an AnyEvent::Debug::Wrapped object. The address of the
wrapped watcher will become its ID - every watcher will be stored in
C<$AnyEvent::Debug::Wrapped{$id}>.

These wrapper objects can be stringified and have some methods defined on
them.

For debugging, of course, it can be helpful to look into these objects,
which is why this is documented here, but this might change at any time in
future versions.

Each object is a relatively standard hash with the following members:

   type   => name of the method used ot create the watcher (e.g. C<io>, C<timer>).
   w      => the actual watcher
   rfile  => reference to the filename of the file the watcher was created in
   line   => line number where it was created
   sub    => function name (or a special string) which created the watcher
   cur    => if created inside another watcher callback, this is the string rep of the other watcher
   now    => the timestamp (AE::now) when the watcher was created
   arg    => the arguments used to create the watcher (sans C<cb>)
   cb     => the original callback used to create the watcher
   called => the number of times the callback was called

Each object supports the following mehtods (warning: these are only
available on wrapped watchers, so are best for interactive use via the
debug shell).

=over 4

=cut

use AnyEvent (); BEGIN { AnyEvent::common_sense }

use overload
   '""'     => sub {
      $_[0]{str} ||= do {
         my ($pkg, $line) = @{ $_[0]{caller} };

         my $mod = AnyEvent::Debug::path2mod ${ $_[0]{rfile} };
         my $sub = $_[0]{sub};

         if (defined $sub) {
            $sub =~ s/^\Q$mod\E:://;
            $sub = "($sub)";
         }

         "$mod:$_[0]{line}$sub>$_[0]{type}>"
         . (AnyEvent::Debug::cb2str $_[0]{cb})
      };
   },
   fallback => 1,
;

=item $w->id

Returns the numerical id of the watcher, as used in the debug shell.

=cut

sub id {
   Scalar::Util::refaddr shift
}

=item $w->verbose

Returns a multiline textual description of the watcher, including the
first ten exceptions caught while executing the callback.

=cut

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

   my $res = "type:    $self->{type} watcher\n"
           . "args:    " . (join " ", %{ $self->{arg} }) . "\n" # TODO: decode fh?
           . "created: " . (AnyEvent::Log::format_time $self->{now}) . " ($self->{now})\n"
           . "file:    ${ $self->{rfile} }\n"
           . "line:    $self->{line}\n"
           . "subname: $self->{sub}\n"
           . "context: $self->{cur}\n"
           . "tracing: " . (${ $self->{rt} } ? "enabled" : "disabled") . "\n"
           . "cb:      $self->{cb} (" . (AnyEvent::Debug::cb2str $self->{cb}) . ")\n"
           . "invoked: $self->{called} times\n";

   if (exists $self->{bt}) {
      $res .= "created\n$self->{bt}";
   }

   if (exists $self->{error}) {
      $res .= "errors:   " . @{$self->{error}} . "\n";

      $res .= "error: " . (AnyEvent::Log::format_time $_->[0]) . " ($_->[0]) $_->[1]\n"
         for @{$self->{error}};
   }

   $res
}

=item $w->trace ($on)

Enables (C<$on> is true) or disables (C<$on> is false) tracing on this
watcher.

To get tracing messages, both the global logging settings must have trace
messages enabled for the context C<AnyEvent::Debug> and tracing must be
enabled for the wrapped watcher.

To enable trace messages globally, the simplest way is to start the
program with C<PERL_ANYEVENT_VERBOSE=9> in the environment.

Tracing for each individual watcher is enabled by default (unless
C<$AnyEvent::Debug::TRACE> has been set to false).

=cut

sub trace {
   ${ $_[0]{rt} } = $_[1];
}

sub DESTROY {
   $TRACE_LOGGER->("dstry $_[0]") if $TRACE_ENABLED && ${ $_[0]{rt} };

   delete $AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $_[0]};
}

=back

=cut

package AnyEvent::Debug::Backtrace;

use AnyEvent (); BEGIN { AnyEvent::common_sense }

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

   my @bt;
   my $modlen;

   for (@$self) {
      my ($rpath, $line, $sub) = @$_;

      $rpath = (AnyEvent::Debug::path2mod $$rpath) . " line $line";
      $modlen = length $rpath if $modlen < length $rpath;

      $sub =~ s/\r/\\r/g;
      $sub =~ s/\n/\\n/g;
      $sub =~ s/([\x00-\x1f\x7e-\xff])/sprintf "\\x%02x", ord $1/ge;
      $sub =~ s/([^\x20-\x7e])/sprintf "\\x{%x}", ord $1/ge;

      push @bt, [$rpath, $sub];
   }

   join "",
      map { sprintf "%*s %s\n", -$modlen, $_->[0], $_->[1] }
         @bt
}

use overload
   '""'     => \&as_string,
   fallback => 1,
;

=head1 AUTHOR

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

=cut

1

Revision:	1.47
Committed:	Tue Jun 16 03:23:07 2015 UTC (9 years, 5 months ago) by root
Branch:	MAIN
CVS Tags:	rel-7_16, rel-7_15, rel-7_14, rel-7_13, rel-7_12, rel-7_11, HEAD
Changes since 1.46:	+1 -1 lines
Log Message:	* empty log message *
#	Content
1	=head1 NAME
2
3	AnyEvent::Debug - debugging utilities for AnyEvent
4
5	=head1 SYNOPSIS
6
7	use AnyEvent::Debug;
8
9	# create an interactive shell into the program
10	my $shell = AnyEvent::Debug::shell "unix/", "/home/schmorp/myshell";
11	# then on the shell: "socat readline /home/schmorp/myshell"
12
13	=head1 DESCRIPTION
14
15	This module provides functionality hopefully useful for debugging.
16
17	At the moment, "only" an interactive shell is implemented. This shell
18	allows you to interactively "telnet into" your program and execute Perl
19	code, e.g. to look at global variables.
20
21	=head1 FUNCTIONS
22
23	=over 4
24
25	=cut
26
27	package AnyEvent::Debug;
28
29	use B ();
30	use Carp ();
31	use Errno ();
32
33	use AnyEvent (); BEGIN { AnyEvent::common_sense }
34	use AnyEvent::Util ();
35	use AnyEvent::Socket ();
36	use AnyEvent::Log ();
37
38	our $TRACE = 1; # trace status
39
40	our ($TRACE_LOGGER, $TRACE_ENABLED);
41
42	# cache often-used strings, purely to save memory, at the expense of speed
43	our %STRCACHE;
44
45	=item $shell = AnyEvent::Debug::shell $host, $service
46
47	This function binds on the given host and service port and returns a
48	shell object, which determines the lifetime of the shell. Any number
49	of connections are accepted on the port, and they will give you a very
50	primitive shell that simply executes every line you enter.
51
52	All commands will be executed "blockingly" with the socket C<select>ed for
53	output. For a less "blocking" interface see L<Coro::Debug>.
54
55	The commands will be executed in the C<AnyEvent::Debug::shell> package,
56	which currently has "help" and a few other commands, and can be freely
57	modified by all shells. Code is evaluated under C<use strict 'subs'>.
58
59	Every shell has a logging context (C<$LOGGER>) that is attached to
60	C<$AnyEvent::Log::COLLECT>), which is especially useful to gether debug
61	and trace messages.
62
63	As a general programming guide, consider the beneficial aspects of
64	using more global (C<our>) variables than local ones (C<my>) in package
65	scope: Earlier all my modules tended to hide internal variables inside
66	C<my> variables, so users couldn't accidentally access them. Having
67	interactive access to your programs changed that: having internal
68	variables still in the global scope means you can debug them easier.
69
70	As no authentication is done, in most cases it is best not to use a TCP
71	port, but a unix domain socket, whcih can be put wherever you can access
72	it, but not others:
73
74	our $SHELL = AnyEvent::Debug::shell "unix/", "/home/schmorp/shell";
75
76	Then you can use a tool to connect to the shell, such as the ever
77	versatile C<socat>, which in addition can give you readline support:
78
79	socat readline /home/schmorp/shell
80	# or:
81	cd /home/schmorp; socat readline unix:shell
82
83	Socat can even give you a persistent history:
84
85	socat readline,history=.anyevent-history unix:shell
86
87	Binding on C<127.0.0.1> (or C<::1>) might be a less secure but sitll not
88	totally insecure (on single-user machines) alternative to let you use
89	other tools, such as telnet:
90
91	our $SHELL = AnyEvent::Debug::shell "127.1", "1357";
92
93	And then:
94
95	telnet localhost 1357
96
97	=cut
98
99	sub shell($$) {
100	local $TRACE = 0;
101
102	AnyEvent::Socket::tcp_server $_[0], $_[1], sub {
103	my ($fh, $host, $port) = @_;
104
105	syswrite $fh, "Welcome, $host:$port, use 'help' for more info!\015\012> ";
106	my $rbuf;
107
108	my $logger = new AnyEvent::Log::Ctx
109	log_cb => sub {
110	syswrite $fh, shift;
111	0
112	};
113
114	my $logger_guard = AnyEvent::Util::guard {
115	$AnyEvent::Log::COLLECT->detach ($logger);
116	};
117	$AnyEvent::Log::COLLECT->attach ($logger);
118
119	local $TRACE = 0;
120	my $rw; $rw = AE::io $fh, 0, sub {
121	my $len = sysread $fh, $rbuf, 1024, length $rbuf;
122
123	$logger_guard if 0; # reference it
124
125	if (defined $len ? $len == 0 : ($! != Errno::EAGAIN && $! != Errno::EWOULDBLOCK)) {
126	undef $rw;
127	} else {
128	while ($rbuf =~ s/^(.*)\015?\012//) {
129	my $line = $1;
130
131	AnyEvent::fh_block $fh;
132
133	if ($line =~ /^\s*exit\b/) {
134	syswrite $fh, "sorry, no... if you want to execute exit, try CORE::exit.\015\012";
135	} elsif ($line =~ /^\scoro\b\s(.*)/) {
136	my $arg = $1;
137	if (eval { require Coro; require Coro::Debug }) {
138	if ($arg =~ /\S/) {
139	Coro::async (sub {
140	select $fh;
141	Coro::Debug::command ($arg);
142	local $\| = 1; # older Coro versions do not flush
143	syswrite $fh, "> ";
144	});
145	return;
146	} else {
147	undef $rw;
148	syswrite $fh, "switching to Coro::Debug...\015\012";
149	Coro::async (sub { Coro::Debug::session ($fh) });
150	return;
151	}
152	} else {
153	syswrite $fh, "Coro not available.\015\012";
154	}
155
156	} else {
157	package AnyEvent::Debug::shell;
158
159	no strict 'vars';
160	local $LOGGER = $logger;
161	my $old_stdout = select $fh;
162	local $\| = 1;
163
164	my @res = eval $line;
165
166	select $old_stdout;
167	syswrite $fh, "$@" if $@;
168	syswrite $fh, "\015\012";
169
170	if (@res > 1) {
171	syswrite $fh, "$_: $res[$_]\015\012" for 0 .. $#res;
172	} elsif (@res == 1) {
173	syswrite $fh, "$res[0]\015\012";
174	}
175	}
176
177	syswrite $fh, "> ";
178	AnyEvent::fh_unblock $fh;
179	}
180	}
181	};
182	}
183	}
184
185	{
186	package AnyEvent::Debug::shell;
187
188	our $LOGGER;
189
190	sub help() {
191	<<EOF
192	help this command
193	wr [level] sets wrap level to level (or toggles if missing)
194	v [level] sets verbosity (or toggles between 0 and 9 if missing)
195	wl 'regex' print wrapped watchers matching the regex (or all if missing)
196	i id,... prints the watcher with the given ids in more detail
197	t enable tracing for newly created watchers (enabled by default)
198	ut disable tracing for newly created watchers
199	t id,... enable tracing for the given watcher (enabled by default)
200	ut id,... disable tracing for the given watcher
201	w id,... converts the watcher ids to watcher objects (for scripting)
202	coro xxx run xxx as Coro::Debug shell command, if available
203	coro switch to Coro::Debug shell, if available
204	EOF
205	}
206
207	sub wl(;$) {
208	my $re = @_ ? qr<$_[0]>i : qr<.>;
209
210	my %res;
211
212	while (my ($k, $v) = each %AnyEvent::Debug::Wrapped) {
213	my $s = "$v";
214	$res{$s} = $k . (exists $v->{error} ? "*" : " ")
215	if $s =~ $re;
216	}
217
218	join "", map "$res{$_} $_\n", sort keys %res
219	}
220
221	sub w {
222	map {
223	$AnyEvent::Debug::Wrapped{$_} \|\| do {
224	print "$_: no such wrapped watcher.\n";
225	()
226	}
227	} @_
228	}
229
230	sub i {
231	join "",
232	map $_->id . " $_\n" . $_->verbose . "\n",
233	&w
234	}
235
236	sub wr {
237	AnyEvent::Debug::wrap (@_);
238
239	"wrap level now $AnyEvent::Debug::WRAP_LEVEL"
240	}
241
242	sub t {
243	if (@_) {
244	@_ = &w;
245	$_->trace (1)
246	for @_;
247	"tracing enabled for @_."
248	} else {
249	$AnyEvent::Debug::TRACE = 1;
250	"tracing for newly created watchers is now enabled."
251	}
252	}
253
254	sub u {
255	if (@_) {
256	@_ = &w;
257	$_->trace (0)
258	for @_;
259	"tracing disabled for @_."
260	} else {
261	$AnyEvent::Debug::TRACE = 0;
262	"tracing for newly created watchers is now disabled."
263	}
264	}
265
266	sub v {
267	$LOGGER->level (@_ ? $_[0] : $LOGGER->[1] ? 0 : 9);
268
269	"verbose logging is now " . ($LOGGER->[1] ? "enabled" : "disabled") . "."
270	}
271	}
272
273	=item AnyEvent::Debug::wrap [$level]
274
275	Sets the instrumenting/wrapping level of all watchers that are being
276	created after this call. If no C<$level> has been specified, then it
277	toggles between C<0> and C<1>.
278
279	The default wrap level is C<0>, or whatever
280	C<$ENV{PERL_ANYEVENT_DEBUG_WRAP}> specifies.
281
282	A level of C<0> disables wrapping, i.e. AnyEvent works normally, and in
283	its most efficient mode.
284
285	A level of C<1> or higher enables wrapping, which replaces all watchers
286	by AnyEvent::Debug::Wrapped objects, stores the location where a
287	watcher was created and wraps the callback to log all invocations at
288	"trace" loglevel if tracing is enabled fore the watcher. The initial
289	state of tracing when creating a watcher is taken from the global
290	variable C<$AnyEvent:Debug::TRACE>. The default value of that variable
291	is C<1>, but it can make sense to set it to C<0> and then do C<< local
292	$AnyEvent::Debug::TRACE = 1 >> in a block where you create "interesting"
293	watchers. Tracing can also be enabled and disabled later by calling the
294	watcher's C<trace> method.
295
296	The wrapper will also count how many times the callback was invoked and
297	will record up to ten runtime errors with corresponding backtraces. It
298	will also log runtime errors at "error" loglevel.
299
300	To see the trace messages, you can invoke your program with
301	C<PERL_ANYEVENT_VERBOSE=9>, or you can use AnyEvent::Log to divert
302	the trace messages in any way you like (the EXAMPLES section in
303	L<AnyEvent::Log> has some examples).
304
305	A level of C<2> does everything that level C<1> does, but also stores a
306	full backtrace of the location the watcher was created, which slows down
307	watcher creation considerably.
308
309	Every wrapped watcher will be linked into C<%AnyEvent::Debug::Wrapped>,
310	with its address as key. The C<wl> command in the debug shell can be used
311	to list watchers.
312
313	Instrumenting can increase the size of each watcher multiple times, and,
314	especially when backtraces are involved, also slows down watcher creation
315	a lot.
316
317	Also, enabling and disabling instrumentation will not recover the full
318	performance that you had before wrapping (the AE::xxx functions will stay
319	slower, for example).
320
321	If you are developing your program, also consider using AnyEvent::Strict
322	to check for common mistakes.
323
324	=cut
325
326	our $WRAP_LEVEL;
327	our $TRACE_CUR;
328	our $POST_DETECT;
329
330	sub wrap(;$) {
331	my $PREV_LEVEL = $WRAP_LEVEL;
332	$WRAP_LEVEL = @_ ? 0+shift : $WRAP_LEVEL ? 0 : 1;
333
334	if ($AnyEvent::MODEL) {
335	if ($WRAP_LEVEL && !$PREV_LEVEL) {
336	$TRACE_LOGGER = AnyEvent::Log::logger trace => \$TRACE_ENABLED;
337	AnyEvent::_isa_hook 0 => "AnyEvent::Debug::Wrap", 1;
338	AnyEvent::Debug::Wrap::_reset ();
339	} elsif (!$WRAP_LEVEL && $PREV_LEVEL) {
340	AnyEvent::_isa_hook 0 => undef;
341	}
342	} else {
343	$POST_DETECT \|\|= AnyEvent::post_detect {
344	undef $POST_DETECT;
345	return unless $WRAP_LEVEL;
346
347	(my $level, $WRAP_LEVEL) = ($WRAP_LEVEL, undef);
348
349	require AnyEvent::Strict unless $AnyEvent::Strict::VERSION;
350
351	AnyEvent::post_detect { # make sure we run after AnyEvent::Strict
352	wrap ($level);
353	};
354	};
355	}
356	}
357
358	=item AnyEvent::Debug::path2mod $path
359
360	Tries to replace a path (e.g. the file name returned by caller)
361	by a module name. Returns the path unchanged if it fails.
362
363	Example:
364
365	print AnyEvent::Debug::path2mod "/usr/lib/perl5/AnyEvent/Debug.pm";
366	# might print "AnyEvent::Debug"
367
368	=cut
369
370	sub path2mod($) {
371	keys %INC; # reset iterator
372
373	while (my ($k, $v) = each %INC) {
374	if ($_[0] eq $v) {
375	$k =~ s%/%::%g if $k =~ s/\.pm$//;
376	return $k;
377	}
378	}
379
380	my $path = shift;
381
382	$path =~ s%^\./%%;
383
384	$path
385	}
386
387	=item AnyEvent::Debug::cb2str $cb
388
389	Using various gambits, tries to convert a callback (e.g. a code reference)
390	into a more useful string.
391
392	Very useful if you debug a program and have some callback, but you want to
393	know where in the program the callback is actually defined.
394
395	=cut
396
397	sub cb2str($) {
398	my $cb = shift;
399
400	"CODE" eq ref $cb
401	or return "$cb";
402
403	eval {
404	my $cv = B::svref_2object ($cb);
405
406	my $gv = $cv->GV
407	or return "$cb";
408
409	my $name = $gv->NAME;
410
411	return (AnyEvent::Debug::path2mod $gv->FILE) . ":" . $gv->LINE
412	if $name eq "__ANON__";
413
414	$gv->STASH->NAME . "::" . $name;
415	} \|\| "$cb"
416	}
417
418	sub sv2str($) {
419	if (ref $_[0]) {
420	if (ref $_[0] eq "CODE") {
421	return "$_[0]=" . cb2str $_[0];
422	} else {
423	return "$_[0]";
424	}
425	} else {
426	for ("\'$_[0]\'") { # make copy
427	substr $_, $Carp::MaxArgLen, length, "'..."
428	if length > $Carp::MaxArgLen;
429	return $_;
430	}
431	}
432	}
433
434	=item AnyEvent::Debug::backtrace [$skip]
435
436	Creates a backtrace (actually an AnyEvent::Debug::Backtrace object
437	that you can stringify), not unlike the Carp module would. Unlike the
438	Carp module it resolves some references (such as callbacks) to more
439	user-friendly strings, has a more succinct output format and most
440	importantly: doesn't leak memory like hell.
441
442	The reason it creates an object is to save time, as formatting can be
443	done at a later time. Still, creating a backtrace is a relatively slow
444	operation.
445
446	=cut
447
448	sub backtrace(;$) {
449	my $w = shift;
450
451	my (@bt, @c);
452	my ($modlen, $sub);
453
454	for (;;) {
455	# 0 1 2 3 4 5 6 7 8 9 10
456	# ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash)
457	package DB;
458	@c = caller $w++
459	or last;
460	package AnyEvent::Debug; # no block for speed reasons
461
462	if ($c[7]) {
463	$sub = "require $c[6]";
464	} elsif (defined $c[6]) {
465	$sub = "eval \"\"";
466	} else {
467	$sub = ($c[4] ? "" : "&") . $c[3];
468
469	$sub .= "("
470	. (join ",",
471	map sv2str $DB::args[$_],
472	0 .. (@DB::args < $Carp::MaxArgNums ? @DB::args : $Carp::MaxArgNums) - 1)
473	. ")"
474	if $c[4];
475	}
476
477	push @bt, [\($STRCACHE{$c[1]} \|\|= $c[1]), $c[2], $sub];
478	}
479
480	@DB::args = ();
481
482	bless \@bt, "AnyEvent::Debug::Backtrace"
483	}
484
485	=back
486
487	=cut
488
489	package AnyEvent::Debug::Wrap;
490
491	use AnyEvent (); BEGIN { AnyEvent::common_sense }
492	use Scalar::Util ();
493	use Carp ();
494
495	sub _reset {
496	for my $name (qw(io timer signal child idle)) {
497	my $super = "SUPER::$name";
498
499	*$name = sub {
500	my ($self, %arg) = @_;
501
502	my $w;
503
504	my $t = $TRACE;
505
506	my ($pkg, $file, $line, $sub);
507
508	$w = 0;
509	do {
510	($pkg, $file, $line) = caller $w++;
511	} while $pkg =~ /^(?:AE\|AnyEvent::(?:Socket\|Handle\|Util\|Debug\|Strict\|Base\|CondVar\|CondVar::Base\|Impl::.*)\|Coro::AnyEvent::CondVar)$/;
512
513	$sub = (caller $w)[3];
514
515	my $cb = $arg{cb};
516	$arg{cb} = sub {
517	++$w->{called};
518
519	local $TRACE_CUR = $w;
520
521	$TRACE_LOGGER->("enter $w") if $TRACE_ENABLED && $t;
522	eval {
523	local $SIG{__DIE__} = sub {
524	die $_[0] . AnyEvent::Debug::backtrace
525	if defined $^S;
526	};
527	&$cb;
528	};
529	if ($@) {
530	my $err = "$@";
531	push @{ $w->{error} }, [AE::now, $err]
532	if @{ $w->{error} } < 10;
533	AE::log die => "($w) $err"
534	or warn "($w) $err";
535	}
536	$TRACE_LOGGER->("leave $w") if $TRACE_ENABLED && $t;
537	};
538
539	$self = bless {
540	type => $name,
541	w => $self->$super (%arg),
542	rfile => \($STRCACHE{$file} \|\|= $file),
543	line => $line,
544	sub => $sub,
545	cur => "$TRACE_CUR",
546	now => AE::now,
547	arg => \%arg,
548	cb => $cb,
549	called => 0,
550	rt => \$t,
551	}, "AnyEvent::Debug::Wrapped";
552
553	delete $arg{cb};
554
555	$self->{bt} = AnyEvent::Debug::backtrace 1
556	if $WRAP_LEVEL >= 2;
557
558	Scalar::Util::weaken ($w = $self);
559	Scalar::Util::weaken ($AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $self} = $self);
560
561	$TRACE_LOGGER->("creat $w") if $TRACE_ENABLED && $t;
562
563	$self
564	};
565	}
566	}
567
568	package AnyEvent::Debug::Wrapped;
569
570	=head1 THE AnyEvent::Debug::Wrapped CLASS
571
572	All watchers created while the wrap level is non-zero will be wrapped
573	inside an AnyEvent::Debug::Wrapped object. The address of the
574	wrapped watcher will become its ID - every watcher will be stored in
575	C<$AnyEvent::Debug::Wrapped{$id}>.
576
577	These wrapper objects can be stringified and have some methods defined on
578	them.
579
580	For debugging, of course, it can be helpful to look into these objects,
581	which is why this is documented here, but this might change at any time in
582	future versions.
583
584	Each object is a relatively standard hash with the following members:
585
586	type => name of the method used ot create the watcher (e.g. C<io>, C<timer>).
587	w => the actual watcher
588	rfile => reference to the filename of the file the watcher was created in
589	line => line number where it was created
590	sub => function name (or a special string) which created the watcher
591	cur => if created inside another watcher callback, this is the string rep of the other watcher
592	now => the timestamp (AE::now) when the watcher was created
593	arg => the arguments used to create the watcher (sans C<cb>)
594	cb => the original callback used to create the watcher
595	called => the number of times the callback was called
596
597	Each object supports the following mehtods (warning: these are only
598	available on wrapped watchers, so are best for interactive use via the
599	debug shell).
600
601	=over 4
602
603	=cut
604
605	use AnyEvent (); BEGIN { AnyEvent::common_sense }
606
607	use overload
608	'""' => sub {
609	$_[0]{str} \|\|= do {
610	my ($pkg, $line) = @{ $_[0]{caller} };
611
612	my $mod = AnyEvent::Debug::path2mod ${ $_[0]{rfile} };
613	my $sub = $_[0]{sub};
614
615	if (defined $sub) {
616	$sub =~ s/^\Q$mod\E:://;
617	$sub = "($sub)";
618	}
619
620	"$mod:$_[0]{line}$sub>$_[0]{type}>"
621	. (AnyEvent::Debug::cb2str $_[0]{cb})
622	};
623	},
624	fallback => 1,
625	;
626
627	=item $w->id
628
629	Returns the numerical id of the watcher, as used in the debug shell.
630
631	=cut
632
633	sub id {
634	Scalar::Util::refaddr shift
635	}
636
637	=item $w->verbose
638
639	Returns a multiline textual description of the watcher, including the
640	first ten exceptions caught while executing the callback.
641
642	=cut
643
644	sub verbose {
645	my ($self) = @_;
646
647	my $res = "type: $self->{type} watcher\n"
648	. "args: " . (join " ", %{ $self->{arg} }) . "\n" # TODO: decode fh?
649	. "created: " . (AnyEvent::Log::format_time $self->{now}) . " ($self->{now})\n"
650	. "file: ${ $self->{rfile} }\n"
651	. "line: $self->{line}\n"
652	. "subname: $self->{sub}\n"
653	. "context: $self->{cur}\n"
654	. "tracing: " . (${ $self->{rt} } ? "enabled" : "disabled") . "\n"
655	. "cb: $self->{cb} (" . (AnyEvent::Debug::cb2str $self->{cb}) . ")\n"
656	. "invoked: $self->{called} times\n";
657
658	if (exists $self->{bt}) {
659	$res .= "created\n$self->{bt}";
660	}
661
662	if (exists $self->{error}) {
663	$res .= "errors: " . @{$self->{error}} . "\n";
664
665	$res .= "error: " . (AnyEvent::Log::format_time $_->[0]) . " ($_->[0]) $_->[1]\n"
666	for @{$self->{error}};
667	}
668
669	$res
670	}
671
672	=item $w->trace ($on)
673
674	Enables (C<$on> is true) or disables (C<$on> is false) tracing on this
675	watcher.
676
677	To get tracing messages, both the global logging settings must have trace
678	messages enabled for the context C<AnyEvent::Debug> and tracing must be
679	enabled for the wrapped watcher.
680
681	To enable trace messages globally, the simplest way is to start the
682	program with C<PERL_ANYEVENT_VERBOSE=9> in the environment.
683
684	Tracing for each individual watcher is enabled by default (unless
685	C<$AnyEvent::Debug::TRACE> has been set to false).
686
687	=cut
688
689	sub trace {
690	${ $_[0]{rt} } = $_[1];
691	}
692
693	sub DESTROY {
694	$TRACE_LOGGER->("dstry $_[0]") if $TRACE_ENABLED && ${ $_[0]{rt} };
695
696	delete $AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $_[0]};
697	}
698
699	=back
700
701	=cut
702
703	package AnyEvent::Debug::Backtrace;
704
705	use AnyEvent (); BEGIN { AnyEvent::common_sense }
706
707	sub as_string {
708	my ($self) = @_;
709
710	my @bt;
711	my $modlen;
712
713	for (@$self) {
714	my ($rpath, $line, $sub) = @$_;
715
716	$rpath = (AnyEvent::Debug::path2mod $$rpath) . " line $line";
717	$modlen = length $rpath if $modlen < length $rpath;
718
719	$sub =~ s/\r/\\r/g;
720	$sub =~ s/\n/\\n/g;
721	$sub =~ s/([\x00-\x1f\x7e-\xff])/sprintf "\\x%02x", ord $1/ge;
722	$sub =~ s/([^\x20-\x7e])/sprintf "\\x{%x}", ord $1/ge;
723
724	push @bt, [$rpath, $sub];
725	}
726
727	join "",
728	map { sprintf "%*s %s\n", -$modlen, $_->[0], $_->[1] }
729	@bt
730	}
731
732	use overload
733	'""' => \&as_string,
734	fallback => 1,
735	;
736
737	=head1 AUTHOR
738
739	Marc Lehmann <schmorp@schmorp.de>
740	http://anyevent.schmorp.de
741
742	=cut
743
744	1
745