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
(see L<AnyEvent::Log>).

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_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 ($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};

            return &$cb
               unless $TRACE_LEVEL;

            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 error => "$TRACE_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.20
Committed:	Wed Aug 17 02:50:35 2011 UTC (12 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.19:	+8 -8 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			AnyEvent::Debug::Wrapped objects, stores the location where a watcher was
208	root	1.19	created and wraps the callback to log all invocations at "trace" loglevel
209			(see L<AnyEvent::Log>).
210	root	1.4
211			A level of C<2> does everything that level C<1> does, but also stores a
212	root	1.19	full backtrace of the location the watcher was created, which slows down
213			watcher creation considerably.
214	root	1.4
215	root	1.6	Every wrapped watcher will be linked into C<%AnyEvent::Debug::Wrapped>,
216			with its address as key. The C<wl> command in the debug shell cna be used
217			to list watchers.
218
219	root	1.4	Instrumenting can increase the size of each watcher multiple times, and,
220			especially when backtraces are involved, also slows down watcher creation
221			a lot.
222
223			Also, enabling and disabling instrumentation will not recover the full
224			performance that you had before wrapping (the AE::xxx functions will stay
225			slower, for example).
226
227	root	1.15	If you are developing your program, also consider using AnyEvent::Strict
228			to check for common mistakes.
229	root	1.4
230			=cut
231
232			our $WRAP_LEVEL;
233	root	1.11	our $TRACE_LEVEL;
234	root	1.4	our $TRACE_CUR;
235			our $POST_DETECT;
236
237			sub wrap(;$) {
238			my $PREV_LEVEL = $WRAP_LEVEL;
239			$WRAP_LEVEL = @_ ? 0+shift : $WRAP_LEVEL ? 0 : 1;
240
241	root	1.16	if ($AnyEvent::MODEL) {
242	root	1.4	if ($WRAP_LEVEL && !$PREV_LEVEL) {
243	root	1.20	$TRACE_LOGGER = AnyEvent::Log::logger trace => \$TRACE_ENABLED;
244	root	1.17	AnyEvent::_isa_hook 0 => "AnyEvent::Debug::Wrap", 1;
245	root	1.4	AnyEvent::Debug::Wrap::_reset ();
246			} elsif (!$WRAP_LEVEL && $PREV_LEVEL) {
247	root	1.12	AnyEvent::_isa_hook 0 => undef;
248	root	1.4	}
249			} else {
250			$POST_DETECT \|\|= AnyEvent::post_detect {
251			undef $POST_DETECT;
252			return unless $WRAP_LEVEL;
253
254			(my $level, $WRAP_LEVEL) = ($WRAP_LEVEL, undef);
255
256			require AnyEvent::Strict;
257
258			AnyEvent::post_detect { # make sure we run after AnyEvent::Strict
259			wrap ($level);
260			};
261			};
262			}
263			}
264
265			=item AnyEvent::Debug::path2mod $path
266
267			Tries to replace a path (e.g. the file name returned by caller)
268			by a module name. Returns the path unchanged if it fails.
269
270			Example:
271
272			print AnyEvent::Debug::path2mod "/usr/lib/perl5/AnyEvent/Debug.pm";
273			# might print "AnyEvent::Debug"
274
275			=cut
276
277			sub path2mod($) {
278			keys %INC; # reset iterator
279
280			while (my ($k, $v) = each %INC) {
281			if ($_[0] eq $v) {
282			$k =~ s%/%::%g if $k =~ s/\.pm$//;
283			return $k;
284			}
285			}
286
287			my $path = shift;
288
289			$path =~ s%^\./%%;
290
291			$path
292			}
293
294			=item AnyEvent::Debug::cb2str $cb
295
296			Using various gambits, tries to convert a callback (e.g. a code reference)
297			into a more useful string.
298
299			Very useful if you debug a program and have some callback, but you want to
300	root	1.16	know where in the program the callback is actually defined.
301	root	1.4
302			=cut
303
304			sub cb2str($) {
305			my $cb = shift;
306
307			require B;
308
309			"CODE" eq ref $cb
310			or return "$cb";
311
312			my $cv = B::svref_2object ($cb);
313
314			my $gv = $cv->GV
315			or return "$cb";
316
317			return (AnyEvent::Debug::path2mod $gv->FILE) . ":" . $gv->LINE
318			if $gv->NAME eq "__ANON__";
319
320			return $gv->STASH->NAME . "::" . $gv->NAME;
321			}
322
323	root	1.16	sub sv2str($) {
324			if (ref $_[0]) {
325			if (ref $_[0] eq "CODE") {
326			return "$_[0]=" . cb2str $_[0];
327			} else {
328			return "$_[0]";
329			}
330			} else {
331			for ("\'$_[0]\'") { # make copy
332			substr $_, $Carp::MaxArgLen, length, "'..."
333			if length > $Carp::MaxArgLen;
334			return $_;
335			}
336			}
337			}
338
339	root	1.17	=item AnyEvent::Debug::backtrace [$skip]
340	root	1.16
341			Creates a backtrace (actually an AnyEvent::Debug::Backtrace object
342			that you can stringify), not unlike the Carp module would. Unlike the
343			Carp module it resolves some references (euch as callbacks) to more
344			user-friendly strings, has a more succinct output format and most
345			importantly: doesn't leak memory like hell.
346
347			The reason it creates an object is to save time, as formatting can be
348			done at a later time. Still, creating a backtrace is a relatively slow
349			operation.
350
351			=cut
352
353	root	1.17	sub backtrace(;$) {
354			my $w = shift;
355
356			my (@bt, @c);
357	root	1.16	my ($modlen, $sub);
358
359			for (;;) {
360			# 0 1 2 3 4 5 6 7 8 9 10
361			# ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash)
362			package DB;
363			@c = caller $w++
364			or last;
365			package AnyEvent::Debug; # no block for speed reasons
366
367			if ($c[7]) {
368			$sub = "require $c[6]";
369			} elsif (defined $c[6]) {
370			$sub = "eval \"\"";
371			} else {
372			$sub = ($c[4] ? "" : "&") . $c[3];
373
374			$sub .= "("
375			. (join ",",
376			map sv2str $DB::args[$_],
377			0 .. (@DB::args < $Carp::MaxArgNums ? @DB::args : $Carp::MaxArgNums) - 1)
378			. ")"
379			if $c[4];
380			}
381
382	root	1.19	push @bt, [\($STRCACHE{$c[1]} \|\|= $c[1]), $c[2], $sub];
383	root	1.16	}
384
385			@DB::args = ();
386
387			bless \@bt, "AnyEvent::Debug::Backtrace"
388			}
389
390	root	1.19	=back
391
392			=cut
393
394	root	1.4	package AnyEvent::Debug::Wrap;
395
396			use AnyEvent (); BEGIN { AnyEvent::common_sense }
397			use Scalar::Util ();
398			use Carp ();
399
400			sub _reset {
401			for my $name (qw(io timer signal child idle)) {
402			my $super = "SUPER::$name";
403
404			*$name = sub {
405			my ($self, %arg) = @_;
406
407			my $w;
408
409			my ($pkg, $file, $line, $sub);
410
411			$w = 0;
412			do {
413			($pkg, $file, $line) = caller $w++;
414	root	1.14	} while $pkg =~ /^(?:AE\|AnyEvent::(?:Socket\|Handle\|Util\|Debug\|Strict\|Base\|CondVar\|CondVar::Base\|Impl::.*))$/;
415	root	1.4
416	root	1.16	$sub = (caller $w)[3];
417	root	1.4
418			my $cb = $arg{cb};
419			$arg{cb} = sub {
420	root	1.6	++$w->{called};
421
422	root	1.4	return &$cb
423			unless $TRACE_LEVEL;
424
425	root	1.19	local $TRACE_CUR = $w;
426	root	1.20	$TRACE_LOGGER->("enter $TRACE_CUR") if $TRACE_ENABLED;
427	root	1.4	eval {
428	root	1.16	local $SIG{__DIE__} = sub { die $_[0] . AnyEvent::Debug::backtrace };
429	root	1.4	&$cb;
430			};
431			if ($@) {
432	root	1.6	push @{ $w->{error} }, [AE::now, $@]
433			if @{ $w->{error} } < 10;
434	root	1.18	AE::log error => "$TRACE_CUR $@";
435	root	1.4	}
436	root	1.20	$TRACE_LOGGER->("leave $TRACE_CUR") if $TRACE_ENABLED;
437	root	1.4	};
438
439			$self = bless {
440			type => $name,
441			w => $self->$super (%arg),
442	root	1.19	rfile => \($STRCACHE{$file} \|\|= $file),
443	root	1.4	line => $line,
444			sub => $sub,
445			cur => $TRACE_CUR,
446	root	1.6	now => AE::now,
447	root	1.11	arg => \%arg,
448	root	1.4	cb => $cb,
449	root	1.6	called => 0,
450	root	1.4	}, "AnyEvent::Debug::Wrapped";
451
452	root	1.11	delete $arg{cb};
453
454	root	1.17	$self->{bt} = AnyEvent::Debug::backtrace 1
455	root	1.4	if $WRAP_LEVEL >= 2;
456
457			Scalar::Util::weaken ($w = $self);
458			Scalar::Util::weaken ($AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $self} = $self);
459
460	root	1.20	$TRACE_LOGGER->("creat $w") if $TRACE_ENABLED;
461	root	1.4
462			$self
463			};
464			}
465			}
466
467			package AnyEvent::Debug::Wrapped;
468
469	root	1.19	=head1 THE AnyEvent::Debug::Wrapped CLASS
470
471			All watchers created while the wrap level is non-zero will be wrapped
472			inside an AnyEvent::Debug::Wrapped object. The address of the
473			wrapped watcher will become its ID - every watcher will be stored in
474			C<$AnyEvent::Debug::Wrapped{$id}>.
475
476			These wrapper objects, as of now, can be stringified, and you can call the
477			C<< ->verbose >> method to get a multiline string describing the watcher
478			in great detail, but otherwise has no other public methods.
479
480			For debugging, of course, it can be helpful to look into these objects,
481			which is why this is documented here, but this might change at any time in
482			future versions.
483
484			Each object is a relatively standard hash with the following members:
485
486			type => name of the method used ot create the watcher (e.g. C<io>, C<timer>).
487			w => the actual watcher
488			rfile => reference to the filename of the file the watcher was created in
489			line => line number where it was created
490			sub => function name (or a special string) which created the watcher
491			cur => if created inside another watcher callback, this is the string rep of the other watcher
492			now => the timestamp (AE::now) when the watcher was created
493			arg => the arguments used to create the watcher (sans C<cb>)
494			cb => the original callback used to create the watcher
495			called => the number of times the callback was called
496
497			=cut
498
499	root	1.4	use AnyEvent (); BEGIN { AnyEvent::common_sense }
500
501	root	1.16	use overload
502			'""' => sub {
503			$_[0]{str} \|\|= do {
504			my ($pkg, $line) = @{ $_[0]{caller} };
505
506	root	1.19	my $mod = AnyEvent::Debug::path2mod ${ $_[0]{rfile} };
507	root	1.16	my $sub = $_[0]{sub};
508
509			if (defined $sub) {
510			$sub =~ s/^\Q$mod\E:://;
511			$sub = "($sub)";
512			}
513	root	1.6
514	root	1.16	"$mod:$_[0]{line}$sub>$_[0]{type}>"
515			. (AnyEvent::Debug::cb2str $_[0]{cb})
516			};
517			},
518			fallback => 1,
519			;
520	root	1.4
521	root	1.6	sub verbose {
522			my ($self) = @_;
523
524	root	1.9	my $res = "type: $self->{type} watcher\n"
525	root	1.11	. "args: " . (join " ", %{ $self->{arg} }) . "\n" # TODO: decode fh?
526	root	1.18	. "created: " . (AnyEvent::Log::ft $self->{now}) . " ($self->{now})\n"
527	root	1.19	. "file: ${ $self->{rfile} }\n"
528	root	1.6	. "line: $self->{line}\n"
529			. "subname: $self->{sub}\n"
530			. "context: $self->{cur}\n"
531			. "cb: $self->{cb} (" . (AnyEvent::Debug::cb2str $self->{cb}) . ")\n"
532			. "invoked: $self->{called} times\n";
533
534	root	1.7	if (exists $self->{bt}) {
535			$res .= "created$self->{bt}";
536			}
537
538			if (exists $self->{error}) {
539	root	1.6	$res .= "errors: " . @{$self->{error}} . "\n";
540
541	root	1.18	$res .= "error: " . (AnyEvent::Log::ft $_->[0]) . " ($_->[0]) $_->[1]\n"
542	root	1.6	for @{$self->{error}};
543			}
544
545			$res
546			}
547
548	root	1.4	sub DESTROY {
549	root	1.20	$TRACE_LOGGER->("dstry $_[0]") if $TRACE_ENABLED;
550	root	1.4
551			delete $AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $_[0]};
552			}
553
554	root	1.16	package AnyEvent::Debug::Backtrace;
555
556			use AnyEvent (); BEGIN { AnyEvent::common_sense }
557
558			sub as_string {
559			my ($self) = @_;
560
561			my @bt;
562			my $modlen;
563
564			for (@$self) {
565			my ($rpath, $line, $sub) = @$_;
566
567			$rpath = (AnyEvent::Debug::path2mod $$rpath) . " line $line";
568			$modlen = length $rpath if $modlen < length $rpath;
569
570			push @bt, [$rpath, $sub];
571			}
572
573			join "",
574			map { sprintf "%*s %s\n", -$modlen, $_->[0], $_->[1] }
575			@bt
576			}
577
578			use overload
579			'""' => \&as_string,
580			fallback => 1,
581			;
582
583	root	1.1	1;
584
585			=head1 AUTHOR
586
587			Marc Lehmann <schmorp@schmorp.de>
588			http://home.schmorp.de/
589
590			=cut
591