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 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 conenctions 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", "wl" and "wlv" commands, and can be freely
modified by all shells. Code is evaluated under C<use strict 'subs'>.

Consider the beneficial aspects of using more global (our) variables than
local ones (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;
      local $TRACE = 0;
      my $rw; $rw = AE::io $fh, 0, sub {
         my $len = sysread $fh, $rbuf, 1024, length $rbuf;

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

               AnyEvent::Util::fh_nonblocking $fh, 0;

               if ($line =~ /^\s*exit\b/) {
                  syswrite $fh, "sorry, no... if you want to execute exit, try CORE::exit.\015\012";
               } else {
                  package AnyEvent::Debug::shell;

                  no strict 'vars';
                  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::Util::fh_nonblocking $fh, 1;
            }
         }
      };
   }
}

{
   package AnyEvent::Debug::shell;

   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)
w 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 weatcher
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(@) {
      my $res;

      for my $id (@_) {
         if (my $w = $AnyEvent::Debug::Wrapped{$id}) {
            $res .= "$id $w\n" . $w->verbose;
         } else {
            $res .= "$id: no such wrapped watcher.\n";
         }
      }

      $res
   }

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

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

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

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

   sub v {
      require AnyEvent::Log;

      $AnyEvent::Log::FILTER->level (@_ ? $_[0] : $AnyEvent::Log::FILTER->[1] ? 0 : 9);

      "verbosity level " . (@_ ? "set to $_[0]" : "toggled")
   }
}

=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 cna 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;

         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;

   require B;

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

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

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

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

   return $gv->STASH->NAME . "::" . $gv->NAME;
}

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 (euch 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 ($@) {
               push @{ $w->{error} }, [AE::now, "$@"]
                  if @{ $w->{error} } < 10;
               AE::log die => "($w) $@"
                  or warn "($w) $@";
            }
            $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->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::ft $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::ft $_->[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;

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

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

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

1;

=head1 AUTHOR

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

=cut

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