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 Errno ();
use POSIX ();

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

=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)
t [level]    sets trace level (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 t {
      $AnyEvent::Debug::TRACE_LEVEL = @_ ? shift : $AnyEvent::Debug::TRACE_LEVEL ? 0 : 9;

      "trace level now $AnyEvent::Debug::TRACE_LEVEL"
   }
}

=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 so invocations of it can be traced.

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.

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).

Currently, enabling wrapping will also load AnyEvent::Strict, but this is
not be relied upon.

=cut

our $WRAP_LEVEL;
our $TRACE_LEVEL = 2;
our $TRACE_CUR;
our $POST_DETECT;

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

   if (defined $AnyEvent::MODEL) {
      unless (defined $PREV_LEVEL) {
         AnyEvent::Debug::Wrapped::_init ();
      }

      if ($WRAP_LEVEL && !$PREV_LEVEL) {
         require AnyEvent::Strict;
         @AnyEvent::Debug::Wrap::ISA = @AnyEvent::ISA;
         @AnyEvent::ISA = "AnyEvent::Debug::Wrap";
         AE::_reset;
         AnyEvent::Debug::Wrap::_reset ();
      } elsif (!$WRAP_LEVEL && $PREV_LEVEL) {
         @AnyEvent::ISA = @AnyEvent::Debug::Wrap::ISA;
      }
   } 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 callbakc 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;
}

# Format Time, not public - yet?
sub ft($) {
   my $t = shift;
   my $i = int $t;
   my $f = sprintf "%06d", 1e6 * ($t - $i);

   POSIX::strftime "%Y-%m-%d %H:%M:%S.$f %z", localtime $i
}

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|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";
            print AnyEvent::Debug::ft AE::now, " enter $TRACE_CUR\n" if $TRACE_LEVEL;
            eval {
               local $SIG{__DIE__} = sub { die Carp::longmess "$_[0]Backtrace starting" };
               &$cb;
            };
            if ($@) {
               push @{ $w->{error} }, [AE::now, $@]
                  if @{ $w->{error} } < 10;
               print AnyEvent::Debug::ft AE::now, " ERROR $TRACE_CUR $@";
            }
            print AnyEvent::Debug::ft AE::now, " leave $TRACE_CUR\n" if $TRACE_LEVEL;
         };

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

         $w->{bt} = Carp::longmess ""
            if $WRAP_LEVEL >= 2;

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

         print AnyEvent::Debug::ft AE::now, " creat $w\n" if $TRACE_LEVEL;

         $self
      };
   }
}

package AnyEvent::Debug::Wrapped;

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

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

            my $mod = AnyEvent::Debug::path2mod $_[0]{file};
            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 = "created: " . (AnyEvent::Debug::ft $self->{now}) . " ($self->{now}\n"
           . "type:    $self->{type} watcher\n"
           . "file:    $self->{file}\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::Debug::ft $_->[0]) . " ($_->[0]) $_->[1]\n"
         for @{$self->{error}};
   }

   $res
}

sub DESTROY {
   print AnyEvent::Debug::ft AE::now, " dstry $_[0]\n" if $TRACE_LEVEL;

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

1;

=back

=head1 AUTHOR

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

=cut

Revision:	1.7
Committed:	Sat Aug 13 16:43:43 2011 UTC (12 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.6:	+5 -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			use Errno ();
30	root	1.6	use POSIX ();
31	root	1.1
32			use AnyEvent (); BEGIN { AnyEvent::common_sense }
33			use AnyEvent::Util ();
34			use AnyEvent::Socket ();
35
36			=item $shell = AnyEvent;::Debug::shell $host, $service
37
38			This function binds on the given host and service port and returns a
39	root	1.4	shell object, which determines the lifetime of the shell. Any number
40	root	1.1	of conenctions are accepted on the port, and they will give you a very
41			primitive shell that simply executes every line you enter.
42
43			All commands will be executed "blockingly" with the socket C<select>ed for
44			output. For a less "blocking" interface see L<Coro::Debug>.
45
46			The commands will be executed in the C<AnyEvent::Debug::shell> package,
47	root	1.6	which currently has "help", "wl" and "wlv" commands, and can be freely
48			modified by all shells. Code is evaluated under C<use strict 'subs'>.
49	root	1.1
50			Consider the beneficial aspects of using more global (our) variables than
51			local ones (my) in package scope: Earlier all my modules tended to hide
52			internal variables inside C<my> variables, so users couldn't accidentally
53			access them. Having interactive access to your programs changed that:
54			having internal variables still in the global scope means you can debug
55			them easier.
56
57	root	1.4	As no authentication is done, in most cases it is best not to use a TCP
58			port, but a unix domain socket, whcih can be put wherever you can access
59	root	1.1	it, but not others:
60
61			our $SHELL = AnyEvent::Debug::shell "unix/", "/home/schmorp/shell";
62
63			Then you can use a tool to connect to the shell, such as the ever
64			versatile C<socat>, which in addition can give you readline support:
65
66			socat readline /home/schmorp/shell
67			# or:
68			cd /home/schmorp; socat readline unix:shell
69
70			Socat can even give you a persistent history:
71
72			socat readline,history=.anyevent-history unix:shell
73
74			Binding on C<127.0.0.1> (or C<::1>) might be a less secure but sitll not
75			totally insecure (on single-user machines) alternative to let you use
76			other tools, such as telnet:
77
78			our $SHELL = AnyEvent::Debug::shell "127.1", "1357";
79
80			And then:
81
82			telnet localhost 1357
83
84			=cut
85
86			sub shell($$) {
87			AnyEvent::Socket::tcp_server $_[0], $_[1], sub {
88			my ($fh, $host, $port) = @_;
89
90	root	1.6	syswrite $fh, "Welcome, $host:$port, use 'help' for more info!\015\012> ";
91	root	1.1	my $rbuf;
92	root	1.3	my $rw; $rw = AE::io $fh, 0, sub {
93	root	1.1	my $len = sysread $fh, $rbuf, 1024, length $rbuf;
94
95			if (defined $len ? $len == 0 : $! != Errno::EAGAIN) {
96			undef $rw;
97			} else {
98			while ($rbuf =~ s/^(.*)\015?\012//) {
99			my $line = $1;
100
101			AnyEvent::Util::fh_nonblocking $fh, 0;
102
103			if ($line =~ /^\s*exit\b/) {
104			syswrite $fh, "sorry, no... if you want to execute exit, try CORE::exit.\015\012";
105			} else {
106			package AnyEvent::Debug::shell;
107
108			no strict 'vars';
109			my $old_stdout = select $fh;
110			local $\| = 1;
111
112			my @res = eval $line;
113
114			select $old_stdout;
115			syswrite $fh, "$@" if $@;
116			syswrite $fh, "\015\012";
117
118			if (@res > 1) {
119			syswrite $fh, "$_: $res[$_]\015\012" for 0 .. $#res;
120			} elsif (@res == 1) {
121			syswrite $fh, "$res[0]\015\012";
122			}
123			}
124
125			syswrite $fh, "> ";
126			AnyEvent::Util::fh_nonblocking $fh, 1;
127			}
128			}
129	root	1.3	};
130	root	1.1	}
131			}
132
133	root	1.6	{
134			package AnyEvent::Debug::shell;
135
136			sub help() {
137			<<EOF
138			help this command
139			wr [level] sets wrap level to level (or toggles if missing)
140			t [level] sets trace level (or toggles if missing)
141			wl 'regex' print wrapped watchers matching the regex (or all if missing)
142			w id,... prints the watcher with the given ids in more detail
143			EOF
144			}
145
146			sub wl(;$) {
147			my $re = @_ ? qr<$_[0]>i : qr<.>;
148
149			my %res;
150
151			while (my ($k, $v) = each %AnyEvent::Debug::Wrapped) {
152			my $s = "$v";
153			$res{$s} = $k . (exists $v->{error} ? "*" : " ")
154			if $s =~ $re;
155			}
156
157			join "", map "$res{$_} $_\n", sort keys %res
158			}
159
160			sub w(@) {
161			my $res;
162
163			for my $id (@_) {
164			if (my $w = $AnyEvent::Debug::Wrapped{$id}) {
165			$res .= "$id $w\n" . $w->verbose;
166			} else {
167			$res .= "$id: no such wrapped watcher.\n";
168			}
169			}
170
171			$res
172			}
173
174			sub wr {
175			AnyEvent::Debug::wrap (@_);
176
177			"wrap level now $AnyEvent::Debug::WRAP_LEVEL"
178			}
179
180			sub t {
181			$AnyEvent::Debug::TRACE_LEVEL = @_ ? shift : $AnyEvent::Debug::TRACE_LEVEL ? 0 : 9;
182
183			"trace level now $AnyEvent::Debug::TRACE_LEVEL"
184			}
185			}
186
187	root	1.4	=item AnyEvent::Debug::wrap [$level]
188
189			Sets the instrumenting/wrapping level of all watchers that are being
190			created after this call. If no C<$level> has been specified, then it
191			toggles between C<0> and C<1>.
192
193	root	1.5	The default wrap level is C<0>, or whatever
194			C<$ENV{PERL_ANYEVENT_DEBUG_WRAP}> specifies.
195
196	root	1.4	A level of C<0> disables wrapping, i.e. AnyEvent works normally, and in
197			its most efficient mode.
198
199			A level of C<1> enables wrapping, which replaces all watchers by
200			AnyEvent::Debug::Wrapped objects, stores the location where a watcher was
201			created and wraps the callback so invocations of it can be traced.
202
203			A level of C<2> does everything that level C<1> does, but also stores a
204			full backtrace of the location the watcher was created.
205
206	root	1.6	Every wrapped watcher will be linked into C<%AnyEvent::Debug::Wrapped>,
207			with its address as key. The C<wl> command in the debug shell cna be used
208			to list watchers.
209
210	root	1.4	Instrumenting can increase the size of each watcher multiple times, and,
211			especially when backtraces are involved, also slows down watcher creation
212			a lot.
213
214			Also, enabling and disabling instrumentation will not recover the full
215			performance that you had before wrapping (the AE::xxx functions will stay
216			slower, for example).
217
218			Currently, enabling wrapping will also load AnyEvent::Strict, but this is
219			not be relied upon.
220
221			=cut
222
223			our $WRAP_LEVEL;
224			our $TRACE_LEVEL = 2;
225			our $TRACE_CUR;
226			our $POST_DETECT;
227
228			sub wrap(;$) {
229			my $PREV_LEVEL = $WRAP_LEVEL;
230			$WRAP_LEVEL = @_ ? 0+shift : $WRAP_LEVEL ? 0 : 1;
231
232			if (defined $AnyEvent::MODEL) {
233			unless (defined $PREV_LEVEL) {
234			AnyEvent::Debug::Wrapped::_init ();
235			}
236
237			if ($WRAP_LEVEL && !$PREV_LEVEL) {
238			require AnyEvent::Strict;
239			@AnyEvent::Debug::Wrap::ISA = @AnyEvent::ISA;
240			@AnyEvent::ISA = "AnyEvent::Debug::Wrap";
241			AE::_reset;
242			AnyEvent::Debug::Wrap::_reset ();
243			} elsif (!$WRAP_LEVEL && $PREV_LEVEL) {
244			@AnyEvent::ISA = @AnyEvent::Debug::Wrap::ISA;
245			}
246			} else {
247			$POST_DETECT \|\|= AnyEvent::post_detect {
248			undef $POST_DETECT;
249			return unless $WRAP_LEVEL;
250
251			(my $level, $WRAP_LEVEL) = ($WRAP_LEVEL, undef);
252
253			require AnyEvent::Strict;
254
255			AnyEvent::post_detect { # make sure we run after AnyEvent::Strict
256			wrap ($level);
257			};
258			};
259			}
260			}
261
262			=item AnyEvent::Debug::path2mod $path
263
264			Tries to replace a path (e.g. the file name returned by caller)
265			by a module name. Returns the path unchanged if it fails.
266
267			Example:
268
269			print AnyEvent::Debug::path2mod "/usr/lib/perl5/AnyEvent/Debug.pm";
270			# might print "AnyEvent::Debug"
271
272			=cut
273
274			sub path2mod($) {
275			keys %INC; # reset iterator
276
277			while (my ($k, $v) = each %INC) {
278			if ($_[0] eq $v) {
279			$k =~ s%/%::%g if $k =~ s/\.pm$//;
280			return $k;
281			}
282			}
283
284			my $path = shift;
285
286			$path =~ s%^\./%%;
287
288			$path
289			}
290
291			=item AnyEvent::Debug::cb2str $cb
292
293			Using various gambits, tries to convert a callback (e.g. a code reference)
294			into a more useful string.
295
296			Very useful if you debug a program and have some callback, but you want to
297			know where in the program the callbakc is actually defined.
298
299			=cut
300
301			sub cb2str($) {
302			my $cb = shift;
303
304			require B;
305
306			"CODE" eq ref $cb
307			or return "$cb";
308
309			my $cv = B::svref_2object ($cb);
310
311			my $gv = $cv->GV
312			or return "$cb";
313
314			return (AnyEvent::Debug::path2mod $gv->FILE) . ":" . $gv->LINE
315			if $gv->NAME eq "__ANON__";
316
317			return $gv->STASH->NAME . "::" . $gv->NAME;
318			}
319
320	root	1.6	# Format Time, not public - yet?
321			sub ft($) {
322			my $t = shift;
323			my $i = int $t;
324			my $f = sprintf "%06d", 1e6 * ($t - $i);
325
326			POSIX::strftime "%Y-%m-%d %H:%M:%S.$f %z", localtime $i
327			}
328
329	root	1.4	package AnyEvent::Debug::Wrap;
330
331			use AnyEvent (); BEGIN { AnyEvent::common_sense }
332			use Scalar::Util ();
333			use Carp ();
334
335			sub _reset {
336			for my $name (qw(io timer signal child idle)) {
337			my $super = "SUPER::$name";
338
339			*$name = sub {
340			my ($self, %arg) = @_;
341
342			my $w;
343
344			my ($pkg, $file, $line, $sub);
345
346			$w = 0;
347			do {
348			($pkg, $file, $line) = caller $w++;
349	root	1.6	} while $pkg =~ /^(?:AE\|AnyEvent::(?:Socket\|Util\|Debug\|Strict\|Base\|CondVar\|CondVar::Base\|Impl::.*))$/;
350	root	1.4
351			$sub = (caller $w++)[3];
352
353			my $cb = $arg{cb};
354			$arg{cb} = sub {
355	root	1.6	++$w->{called};
356
357	root	1.4	return &$cb
358			unless $TRACE_LEVEL;
359
360			local $TRACE_CUR = "$w";
361	root	1.6	print AnyEvent::Debug::ft AE::now, " enter $TRACE_CUR\n" if $TRACE_LEVEL;
362	root	1.4	eval {
363	root	1.6	local $SIG{__DIE__} = sub { die Carp::longmess "$_[0]Backtrace starting" };
364	root	1.4	&$cb;
365			};
366			if ($@) {
367	root	1.6	push @{ $w->{error} }, [AE::now, $@]
368			if @{ $w->{error} } < 10;
369			print AnyEvent::Debug::ft AE::now, " ERROR $TRACE_CUR $@";
370	root	1.4	}
371	root	1.6	print AnyEvent::Debug::ft AE::now, " leave $TRACE_CUR\n" if $TRACE_LEVEL;
372	root	1.4	};
373
374			$self = bless {
375			type => $name,
376			w => $self->$super (%arg),
377			file => $file,
378			line => $line,
379			sub => $sub,
380			cur => $TRACE_CUR,
381	root	1.6	now => AE::now,
382	root	1.4	cb => $cb,
383	root	1.6	called => 0,
384	root	1.4	}, "AnyEvent::Debug::Wrapped";
385
386			$w->{bt} = Carp::longmess ""
387			if $WRAP_LEVEL >= 2;
388
389			Scalar::Util::weaken ($w = $self);
390			Scalar::Util::weaken ($AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $self} = $self);
391
392	root	1.6	print AnyEvent::Debug::ft AE::now, " creat $w\n" if $TRACE_LEVEL;
393	root	1.4
394			$self
395			};
396			}
397			}
398
399			package AnyEvent::Debug::Wrapped;
400
401			use AnyEvent (); BEGIN { AnyEvent::common_sense }
402
403			sub _init {
404			require overload;
405			import overload
406			'""' => sub {
407			$_[0]{str} \|\|= do {
408			my ($pkg, $line) = @{ $_[0]{caller} };
409
410	root	1.6	my $mod = AnyEvent::Debug::path2mod $_[0]{file};
411			my $sub = $_[0]{sub};
412
413			if (defined $sub) {
414			$sub =~ s/^\Q$mod\E:://;
415			$sub = "($sub)";
416			}
417
418			"$mod:$_[0]{line}$sub>$_[0]{type}>"
419	root	1.4	. (AnyEvent::Debug::cb2str $_[0]{cb})
420			};
421			},
422			fallback => 1;
423			}
424
425	root	1.6	sub verbose {
426			my ($self) = @_;
427
428			my $res = "created: " . (AnyEvent::Debug::ft $self->{now}) . " ($self->{now}\n"
429			. "type: $self->{type} watcher\n"
430			. "file: $self->{file}\n"
431			. "line: $self->{line}\n"
432			. "subname: $self->{sub}\n"
433			. "context: $self->{cur}\n"
434			. "cb: $self->{cb} (" . (AnyEvent::Debug::cb2str $self->{cb}) . ")\n"
435			. "invoked: $self->{called} times\n";
436
437	root	1.7	if (exists $self->{bt}) {
438			$res .= "created$self->{bt}";
439			}
440
441			if (exists $self->{error}) {
442	root	1.6	$res .= "errors: " . @{$self->{error}} . "\n";
443
444			$res .= "error: " . (AnyEvent::Debug::ft $_->[0]) . " ($_->[0]) $_->[1]\n"
445			for @{$self->{error}};
446			}
447
448			$res
449			}
450
451	root	1.4	sub DESTROY {
452	root	1.6	print AnyEvent::Debug::ft AE::now, " dstry $_[0]\n" if $TRACE_LEVEL;
453	root	1.4
454			delete $AnyEvent::Debug::Wrapped{Scalar::Util::refaddr $_[0]};
455			}
456
457	root	1.1	1;
458
459			=back
460
461			=head1 AUTHOR
462
463			Marc Lehmann <schmorp@schmorp.de>
464			http://home.schmorp.de/
465
466			=cut
467