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_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($$) {
   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 $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 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
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 v {
      #TODO
      $AnyEvent::VERBOSE = @_ ? shift : $AnyEvent::VERBOSE ? 0 : 9;

      "verbosity level now $AnyEvent::VEBROSE"
   }
}

=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> 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. 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 1 => "AnyEvent::Debug::Wrap", 1;
         AnyEvent::Debug::Wrap::_reset ();
      } elsif (!$WRAP_LEVEL && $PREV_LEVEL) {
         AnyEvent::_isa_hook 1 => 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 ($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::.*))$/;

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

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

            local $TRACE_CUR  = $w;

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

         $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,
         }, "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;

         $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, as of now, can be stringified, and you can call the
C<< ->verbose >> method to get a multiline string describing the watcher
in great detail, but otherwise has no other public methods.

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

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

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"
           . "cb:      $self->{cb} (" . (AnyEvent::Debug::cb2str $self->{cb}) . ")\n"
           . "invoked: $self->{called} times\n";

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

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

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

   $res
}

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

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

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