AnyEvent-GDB/GDB.pm

=head1 NAME

AnyEvent::GDB - asynchronous GDB machine interface interface

=head1 SYNOPSIS

   use AnyEvent::GDB;

=head1 DESCRIPTION

This module is an L<AnyEvent> user, you need to make sure that you use and
run a supported event loop.

=head2 PROTOCOL QUIRKS

=head3 Minus vs. underscores

The MI protocol uses C<-> to separate name components, while in Perl, you
use C<_> for this purpose.

This module usually accepts either form as input, and always converts
names with C<-> to names with C<_>, so the C<library-loaded> notify might
become C<notify_library_loaded>, and the C<host-name> result in that event
is stored in the C<host_name> hash element in Perl.

=head3 Output redirection

=cut

package AnyEvent::GDB;

use common::sense;

use Carp ();
use Fcntl ();
use Scalar::Util ();

use AnyEvent ();
use AnyEvent::Util ();

our $VERSION = '0.0';

=head2 METHODS

=over 4

=item $gdb = new AnyEvent::GDB key => value...

Create a new GDB object using the given named parameters.

For initial experiments, it is highly recommended to run with tracing or
at least C<verbose> enabled. And don't forget to provide an C<on_eof>
callback.

   my $gdb = new AnyEvent::GDB
      on_eof => sub {
         print Qe are done.\n";
      },
      trace => 1; # or verbose => 1, for less output

=over 4

=item exec => $path (default: "gdb")

The path of the GDB executable.

=item args => [$string...] (default: ["-n"])

An optional array of parameters to pass to GDB. This should not be
used to load a program executable, use the C<file_exec_and_symbols>,
C<target_attach> or similar MI commands instead.

=item trace => $boolean (default: 0)

If true, then all commands sent to GDB are printed to STDOUT prefixed with
"> ", and all replies received from GDB are printed to STDOUT prefixed
with "< ".

=item verbose => $boolean (default: true if trace is enabled, false otherwise)

If true, then log output and possibly other information is printed to
STDOUT.

=item on_xxxx => $callback->(...)

This specifies a callback for a specific event - see the L<EVENTS> section
later in this document.

=back


=cut

sub new {
   my ($class, %arg) = @_;

   my $self = bless {
      %arg,
   }, $class;

   my $exe = delete $self->{exec} // "gdb";
   my $arg = delete $self->{args} // [qw(-n)];

   $self->{verbose} = 1
      if $self->{trace} && !exists $self->{verbose};

   ($self->{fh}, my $fh2) = AnyEvent::Util::portable_socketpair;

   $self->{pid} = fork;

   open my $stdin , "<&STDIN" ;
   open my $stdout, ">&STDOUT";

   unless ($self->{pid}) {
      if (defined $self->{pid}) {
         open STDIN , "<&", $fh2;
         open STDOUT, ">&", $fh2;
         fcntl $stdin , Fcntl::F_SETFD, 0;
         fcntl $stdout, Fcntl::F_SETFD, 0;
         exec $exe, qw(--interpreter=mi2 -q), @$arg;
         kill 9, 0; # don't want to load the POSIX module just for this
      } else {
         Carp::croak "cannot fork: $!";
      }
   }

   AnyEvent::Util::fh_nonblocking $self->{fh}, 1;

   {
      Scalar::Util::weaken (my $self = $self);
      $self->{rw} = AE::io $self->{fh}, 0, sub {
         my $len = sysread $self->{fh}, $self->{rbuf}, 256, length $self->{rbuf};

         defined $len || $self->eof;

         $self->feed ("$1")
            while $self->{rbuf} =~ s/^([^\r\n]*)\r?\n//;
      };

      $self->{wcb} = sub {
         my $len = syswrite $self->{fh}, $self->{wbuf};
         substr $self->{wbuf}, 0, $len, "";
         delete $self->{ww} unless length $self->{wbuf};
      };
   }

   $self->cmd_raw ((sprintf "run <&%d >&%d", fileno $stdin, fileno $stdout), sub { });

   $self
}

#sub DESTROY {
#)}

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

   $self->event ("eof");

   %$self = ();
}

sub send {
   my ($self, $data) = @_;

   print "> $data"
      if $self->{trace};

   $self->{wbuf} .= $data;
   $self->{ww} ||= AE::io $self->{fh}, 1, $self->{wcb};
}

our %C_ESCAPE = (
   "\\" => "\\",
   '"' => '"',
   "'" => "'",
   "?" => "?",

   a => "\x07",
   b => "\x08",
   t => "\x09",
   n => "\x0a",
   v => "\x0b",
   f => "\x0c",
   r => "\x0d",
);

sub _parse_c_string {
   my $r = "";

   # syntax is not documented, so we do full C99, except unicode

   while () {
      if (/\G([^"\\\n]+)/gc) {
         $r .= $1;
      } elsif (/\G\\([abtnvfr\\"'?])/gc) {
         $r .= $C_ESCAPE{$1};
      } elsif (/\G\\([0-8]{1,3})/gc) {
         $r .= chr oct $1;
      } elsif (/\G\\x([0-9a-fA-F]+)/gc) {
         $r .= chr hex $1;
      } elsif (/\G"/gc) {
         last;
      } else {
         die "invalid string syntax\n";
      }
   }

   $r
}

sub _parse_value {
   if (/\G"/gc) { # c-string
      &_parse_c_string

   } elsif (/\G\{/gc) { # tuple
      my $r = &_parse_results;

      /\G\}/gc
         or die "tuple does not end with '}'\n";

      $r
      
   } elsif (/\G\[/gc) { # list
      my @r;

      until (/\G\]/gc) {
         # if GDB outputs "result" in lists, let me know and uncomment the following lines
#         # list might also contain key value pairs, but apparently
#         # those are supposed to be ordered, so we use an array in perl.
#         push @r, $1
#            if /\G([^=,\[\]\{\}]+)=/gc;

         push @r, &_parse_value;

         /\G,/gc
            or last;
      }

      /\G\]/gc
         or die "list does not end with ']'\n";

      \@r

   } else {
      die "value expected\n";
   }
}

sub _parse_results {
   my %r;

   # syntax for string is undocumented
   while (/\G([^=,\[\]\{\}]+)=/gc) {
      my $k = $1;

      $k =~ y/-/_/;

      $r{$k} = &_parse_value;

      /\G,/gc
         or last;
   }

   \%r
}

my %type_map = qw(
   * exec
   + status
   = notify
);

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

   print "< $line\n"
      if $self->{trace};

   for ($line) {
      if (/^\(gdb\)\s*$/gc) { # docs say "(gdb)", but reality says "(gdb) "
         # nop
      } else {
         /^([0-9]*)/gc; # [token], actually ([0-9]+)?
         my $token = $1;

         eval {
            if (/\G\^(done|running|connected|error|exit)/gc) { # result
               my $class = $1 eq "running" ? "done" : $1;
               # documented for error is an incompatible format, but in reality it is sane

               my $results = /\G,/gc ? &_parse_results : {};

               if (my $cb = delete $self->{cb}{$token}) {
                  # unfortunately, gdb sometimes outputs multiple result records for one command
                  $cb->($class, $results, delete $self->{console});
               }

            } elsif (/\G([*+=])([^,]+)/gc) { # *exec-async, +status-async, =notify-async
               my ($type, $class) = ($type_map{$1}, $2);

               my $results = /\G,/gc ? &_parse_results : {};

               $class =~ y/-/_/;

               $self->event ($type => $class, $results);
               $self->event ("$type\_$class" => $results);

            } elsif (/\G~"/gc) {
               push @{ $self->{console} }, &_parse_c_string;
            } elsif (/\G&"/gc) {
               my $log = &_parse_c_string;
               print "$log\n" if $self->{verbose};
               $self->event (log => $log);
            } elsif (/\G\@"/gc) {
               $self->event (target => &_parse_c_string);
            }
         };

         /\G(.{0,16})/gcs;
         $@ = "extra data\n" if !$@ and length $1;

         if ($@) {
            chop $@;
            warn "AnyEvent::GDB: parse error: $@, at ...$1\n";
            $self->eof;
         }
      }
   }
}

sub _q($) {
   return $_[0]
      if $_[0] =~ /^[A-Za-z0-9_]+$/; # we are a lot more strict than the spec

   local $_ = shift;
   utf8::encode $_; # just in case
   s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\x%02x", ord $1/ge;
   "\"$_\""
}

=item $gdb->cmd_raw ($command, $cb->($class, $results, $console))

Execute a raw command: C<$command> is sent unchanged to GDB. See C<cmd_>
for a description of the callback arguments.

Example: execute a CLI command and print its output.

   $gdb->cmd_raw ("info sh", sub {
      print "$_[3]\n";
   });

=cut

sub cmd_raw {
   my ($self, $cmd, $cb) = @_;

   my $token = ++$self->{token};
   $self->send ("$token$cmd\n");
   $self->{cb}{$token} = $cb;
}

=item $gdb->cmd ($command => [$option...], $parameter..., $cb->($class, $results, $console))

Execute a MI command and invoke the callback with the results.

C<$command> is a MI command name. The leading minus sign can be omitted,
and instead of minus signs, you can use underscores, i.e. all the
following command names are equivalent:

   "-break-insert"   # as documented in the GDB manual
   -break_insert     # using underscores and _ to avoid having to quote
   break_insert      # ditto, when e.g. used to the left of a =>
   "break-insert"    # no leading minus

The second argument is an optional array reference with options (i.e. it
can simply be missing). Each C<$option> is either an option name (similar
rules as with command names, i.e. no initial C<-->) or an array reference
with the first element being the option name, and the remaining elements
being parameters: [$option, $parameter...].

The remaining arguments, excluding the last one, are simply the parameters
passed to GDB.

All options and parameters will be properly quoted.

When the command is done, the callback C<$cb> will be invoked with
C<$class> being one of C<done>, C<connected>, C<error> or C<exit>
(note: not C<running>), C<$results> being a has reference with all the
C<variable=value> pairs from the result list.

C<$console> is an array reference with all the GDB console messages
written while command executes (for MI commands, this should always be
C<undef> and can be ignored).

Example: #todo#

=cut

sub cmd {
   my $cb = pop;
   my ($self, $cmd, @arg) = @_;

   $cmd =~ s/^[\-_]?/_/;
   $cmd =~ y/_/-/;

   $cmd .= " ";

   my $opt = ref $arg[0] ? shift @arg : [];

   for (@$opt) {
      $cmd .= "-";
      $cmd .= (_q $_) . " "
         for (ref) ? @$_ : $_;
   }

   # the mi syntax is inconsistent, providing "--" in case
   # parameters start with "-", but not allowing "-" as first
   # char of a parameter. in fact, "--" is flagged as unknown
   # option.
   if (@arg) {
#      $cmd .= "-- ";

      $cmd .= (_q $_) . " "
         for @arg;
   }

   # remove trailing " "
   substr $cmd, -1, 1, "";

   $self->cmd_raw ($cmd, $cb);
}

=item ($class, $results, $console) = $gdb->cmd_sync ($command => [$option...], $parameter...])

Like C<cmd>, but blocks execution until the command has been executed, and returns the results.

This is purely a convenience method for small scripts: since it blocks
execution using a condvar, it is not suitable to be used inside callbacks
or modules, unless L<Coro> is used.

=cut

sub cmd_sync {
   push @_, my $cv = AE::cv;
   &cmd;
   $cv->recv
}

sub event {
   my ($self, $event, @args) = @_;

#   if ($self->{verbose}) {
#      use Data::Dumper;
#      print Data::Dumper
#            ->new ([[$event, @args]])
#            ->Pair ("=>")
#            ->Useqq (1)
#            ->Indent (0)
#            ->Terse (1)
#            ->Quotekeys (0)
#            ->Sortkeys (1)
#            ->Dump,
#            "\n";
#   }

   my $cb;

   $cb = $self->    {"on_$event"} and $cb->($self, $event, @args);
   $cb = $self->can ("on_$event") and $cb->($self, $event, @args);
   $cb = $self->    {on_event}    and $cb->($self, $event, @args);
   $cb = $self->can ("on_event")  and $cb->($self, $event, @args);
}

# predefined events

sub on_notify_thread_group_added {
   my ($self, undef, $r) = @_;

   $self->{thread_group}{$r->{id}} = $r;
}

sub on_notify_thread_group_removed {
   my ($self, undef, $r) = @_;

   delete $self->{thread_group}{$r->{id}};
}

sub on_notify_thread_group_started {
   my ($self, undef, $r) = @_;

   delete $self->{thread_group}{exit_code};
   $self->{thread_group}{$r->{id}}{pid} = $r->{pid};
}

sub on_notify_thread_group_exited {
   my ($self, undef, $r) = @_;

   delete $self->{thread_group}{pid};
   $self->{thread_group}{$r->{id}}{exit_code} = $r->{exit_code};
}

sub on_notify_record_started {
   my ($self, undef, $r) = @_;

   $self->{thread_group}{$r->{id}}{recording} = 1;
}

sub on_notify_record_stopped {
   my ($self, undef, $r) = @_;

   $self->{thread_group}{$r->{id}}{recording} = 0;
}

sub on_notify_thread_created {
   my ($self, undef, $r) = @_;

   $self->{thread}{$r->{id}} = $r;
}

sub on_notify_thread_exited {
   my ($self, undef, $r) = @_;

   delete $self->{thread}{$r->{id}};
}

sub _threads {
   my ($self, $r) = @_;

   $r->{thread_id} eq "all"
      ? values %{ $self->{thread} }
      : $self->{thread}{$r->{thread_id}}
}

sub on_exec_running {
   my ($self, undef, $r) = @_;

   for ($self->_threads ($r)) {
      delete $_->{stopped};
      $_->{running} = 1;
   }
}

sub on_exec_stopped {
   my ($self, undef, $r) = @_;

   for ($self->_threads ($r)) {
      delete $_->{running};
      $_->{stopped} = $r;
   }

#   $self->event ("thread_$r->{reason}" => $r, [map $_->{id}, $self->_threads ($r)]);
}

sub _thread_groups {
   my ($self, $r) = @_;

   exists $r->{thread_group}
      ? $self->{thread_group}{$r->{thread_group}}
      : values %{ $self->{thread_group} }
}

sub on_notify_library_loaded {
   my ($self, undef, $r) = @_;

   $_->{library}{$r->{id}} = $r
      for $self->_thread_groups ($r);
}

sub on_notify_library_unloaded {
   my ($self, undef, $r) = @_;

   delete $_->{library}{$r->{id}}
      for $self->_thread_groups ($r);
}

=back

=head2 EVENTS

AnyEvent::GDB is asynchronous in nature, as the goal of the MI interface
is to be fully asynchronous. Due to this, a user of this interface must
be prepared to handle various events.

When an event is produced, the GDB object will look for the following
four handlers and, if found, will call it with the GDB object and event
name (without C<on_>) as the first two arguments, followed by any
event-specific arguments:

=over 4

=item on_EVENTNAME constructor parameter

Any callback specified as C<on_EVENTNAME> parameter to the constructor.

=item on_EVENTNAME method on the GDB object

Useful when subclassing.

=item on_event constructor parameter

The callback specified as C<on_event> parameter to the constructor.

=item on_event method on the GDB object

Again, mainly useful when subclassing.

=back

Here's the list of events with a description of their arguments.

=over 4

=item on_eof => $cb->($gdb, "eof")

Called whenever GDB closes the connection. After this event, the object is
partially destroyed and must not be accessed again.

=item on_target => $cb->($gdb, "target", $string)

Output received from the target. Normally, this is sent directly to STDOUT
by GDB, but remote targets use this hook.

=item on_log => $cb->($gdb, "log", $string)

Log output from GDB. Best printed to STDOUT in interactive sessions.

=item on_TYPE => $cb->($gdb, "TYPE", $class, $results)

Called for GDB C<exec>, C<status> and C<notify> event (TYPE is one of
these three strings). C<$class> is the class of the event, with C<->
replaced by C<_> everywhere.

For each of these, the GDB object will create I<two> events: one for TYPE,
and one for TYPE_CLASS. Usuaully you should provide the more specific
event (TYPE_CLASS).

=item on_TYPE_CLASS => $cb->($gdb, "TYPE_CLASS", $results)

Called for GDB C<exec>, C<status> and C<notify> event: TYPE is one
of these three strings, the class of the event (with C<-> replaced b
C<_>s) is appended to it to form the TYPE_CLASS (e.g. C<exec_stopped> or
C<notify_library_loaded>).

=back

=head1 SEE ALSO

L<AnyEvent>, L<http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI>.

=head1 AUTHOR

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

=cut

1
Revision:	1.3
Committed:	Fri Dec 28 09:28:59 2012 UTC (11 years, 5 months ago) by root
Branch:	MAIN
Changes since 1.2:	+250 -26 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::GDB - asynchronous GDB machine interface interface
4
5			=head1 SYNOPSIS
6
7			use AnyEvent::GDB;
8
9			=head1 DESCRIPTION
10
11			This module is an L<AnyEvent> user, you need to make sure that you use and
12			run a supported event loop.
13
14	root	1.3	=head2 PROTOCOL QUIRKS
15
16			=head3 Minus vs. underscores
17
18			The MI protocol uses C<-> to separate name components, while in Perl, you
19			use C<_> for this purpose.
20
21			This module usually accepts either form as input, and always converts
22			names with C<-> to names with C<_>, so the C<library-loaded> notify might
23			become C<notify_library_loaded>, and the C<host-name> result in that event
24			is stored in the C<host_name> hash element in Perl.
25
26			=head3 Output redirection
27
28	root	1.1	=cut
29
30			package AnyEvent::GDB;
31
32			use common::sense;
33
34	root	1.3	use Carp ();
35	root	1.1	use Fcntl ();
36			use Scalar::Util ();
37
38			use AnyEvent ();
39			use AnyEvent::Util ();
40
41			our $VERSION = '0.0';
42
43			=head2 METHODS
44
45			=over 4
46
47	root	1.3	=item $gdb = new AnyEvent::GDB key => value...
48
49			Create a new GDB object using the given named parameters.
50
51			For initial experiments, it is highly recommended to run with tracing or
52			at least C<verbose> enabled. And don't forget to provide an C<on_eof>
53			callback.
54
55			my $gdb = new AnyEvent::GDB
56			on_eof => sub {
57			print Qe are done.\n";
58			},
59			trace => 1; # or verbose => 1, for less output
60	root	1.1
61			=over 4
62
63			=item exec => $path (default: "gdb")
64
65			The path of the GDB executable.
66
67			=item args => [$string...] (default: ["-n"])
68
69			An optional array of parameters to pass to GDB. This should not be
70			used to load a program executable, use the C<file_exec_and_symbols>,
71			C<target_attach> or similar MI commands instead.
72
73	root	1.3	=item trace => $boolean (default: 0)
74
75			If true, then all commands sent to GDB are printed to STDOUT prefixed with
76			"> ", and all replies received from GDB are printed to STDOUT prefixed
77			with "< ".
78
79			=item verbose => $boolean (default: true if trace is enabled, false otherwise)
80
81			If true, then log output and possibly other information is printed to
82			STDOUT.
83
84			=item on_xxxx => $callback->(...)
85
86			This specifies a callback for a specific event - see the L<EVENTS> section
87			later in this document.
88	root	1.1
89			=back
90
91	root	1.3
92	root	1.1	=cut
93
94			sub new {
95			my ($class, %arg) = @_;
96
97			my $self = bless {
98			%arg,
99			}, $class;
100
101			my $exe = delete $self->{exec} // "gdb";
102			my $arg = delete $self->{args} // [qw(-n)];
103
104	root	1.3	$self->{verbose} = 1
105			if $self->{trace} && !exists $self->{verbose};
106
107	root	1.1	($self->{fh}, my $fh2) = AnyEvent::Util::portable_socketpair;
108
109			$self->{pid} = fork;
110
111			open my $stdin , "<&STDIN" ;
112			open my $stdout, ">&STDOUT";
113
114			unless ($self->{pid}) {
115			if (defined $self->{pid}) {
116			open STDIN , "<&", $fh2;
117			open STDOUT, ">&", $fh2;
118			fcntl $stdin , Fcntl::F_SETFD, 0;
119			fcntl $stdout, Fcntl::F_SETFD, 0;
120			exec $exe, qw(--interpreter=mi2 -q), @$arg;
121			kill 9, 0; # don't want to load the POSIX module just for this
122			} else {
123	root	1.3	Carp::croak "cannot fork: $!";
124	root	1.1	}
125			}
126
127			AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
128
129			{
130			Scalar::Util::weaken (my $self = $self);
131			$self->{rw} = AE::io $self->{fh}, 0, sub {
132			my $len = sysread $self->{fh}, $self->{rbuf}, 256, length $self->{rbuf};
133
134	root	1.3	defined $len \|\| $self->eof;
135	root	1.1
136			$self->feed ("$1")
137			while $self->{rbuf} =~ s/^([^\r\n]*)\r?\n//;
138			};
139
140			$self->{wcb} = sub {
141			my $len = syswrite $self->{fh}, $self->{wbuf};
142			substr $self->{wbuf}, 0, $len, "";
143			delete $self->{ww} unless length $self->{wbuf};
144			};
145			}
146
147			$self->cmd_raw ((sprintf "run <&%d >&%d", fileno $stdin, fileno $stdout), sub { });
148
149			$self
150			}
151
152			#sub DESTROY {
153			#)}
154
155	root	1.3	sub eof {
156			my ($self) = @_;
157
158			$self->event ("eof");
159
160			%$self = ();
161			}
162
163	root	1.1	sub send {
164			my ($self, $data) = @_;
165
166	root	1.2	print "> $data"
167	root	1.3	if $self->{trace};
168	root	1.1
169			$self->{wbuf} .= $data;
170			$self->{ww} \|\|= AE::io $self->{fh}, 1, $self->{wcb};
171			}
172
173			our %C_ESCAPE = (
174			"\\" => "\\",
175			'"' => '"',
176			"'" => "'",
177			"?" => "?",
178
179			a => "\x07",
180			b => "\x08",
181			t => "\x09",
182			n => "\x0a",
183			v => "\x0b",
184			f => "\x0c",
185			r => "\x0d",
186			);
187
188			sub _parse_c_string {
189			my $r = "";
190
191			# syntax is not documented, so we do full C99, except unicode
192
193			while () {
194			if (/\G([^"\\\n]+)/gc) {
195			$r .= $1;
196			} elsif (/\G\\([abtnvfr\\"'?])/gc) {
197			$r .= $C_ESCAPE{$1};
198			} elsif (/\G\\([0-8]{1,3})/gc) {
199			$r .= chr oct $1;
200			} elsif (/\G\\x([0-9a-fA-F]+)/gc) {
201			$r .= chr hex $1;
202			} elsif (/\G"/gc) {
203			last;
204			} else {
205			die "invalid string syntax\n";
206			}
207			}
208
209			$r
210			}
211
212			sub _parse_value {
213			if (/\G"/gc) { # c-string
214			&_parse_c_string
215
216			} elsif (/\G\{/gc) { # tuple
217			my $r = &_parse_results;
218
219			/\G\}/gc
220			or die "tuple does not end with '}'\n";
221
222			$r
223
224			} elsif (/\G\[/gc) { # list
225			my @r;
226
227			until (/\G\]/gc) {
228			# if GDB outputs "result" in lists, let me know and uncomment the following lines
229			# # list might also contain key value pairs, but apparently
230			# # those are supposed to be ordered, so we use an array in perl.
231			# push @r, $1
232			# if /\G([^=,\[\]\{\}]+)=/gc;
233
234			push @r, &_parse_value;
235
236			/\G,/gc
237			or last;
238			}
239
240			/\G\]/gc
241			or die "list does not end with ']'\n";
242
243			\@r
244
245			} else {
246			die "value expected\n";
247			}
248			}
249
250			sub _parse_results {
251			my %r;
252
253			# syntax for string is undocumented
254			while (/\G([^=,\[\]\{\}]+)=/gc) {
255			my $k = $1;
256
257	root	1.3	$k =~ y/-/_/;
258
259	root	1.1	$r{$k} = &_parse_value;
260
261			/\G,/gc
262			or last;
263			}
264
265			\%r
266			}
267
268			my %type_map = qw(
269	root	1.3	* exec
270			+ status
271			= notify
272	root	1.1	);
273
274			sub feed {
275			my ($self, $line) = @_;
276
277	root	1.2	print "< $line\n"
278	root	1.3	if $self->{trace};
279	root	1.1
280			for ($line) {
281			if (/^\(gdb\)\s*$/gc) { # docs say "(gdb)", but reality says "(gdb) "
282			# nop
283			} else {
284			/^([0-9]*)/gc; # [token], actually ([0-9]+)?
285			my $token = $1;
286
287			eval {
288			if (/\G\^(done\|running\|connected\|error\|exit)/gc) { # result
289			my $class = $1 eq "running" ? "done" : $1;
290			# documented for error is an incompatible format, but in reality it is sane
291
292			my $results = /\G,/gc ? &_parse_results : {};
293
294			if (my $cb = delete $self->{cb}{$token}) {
295			# unfortunately, gdb sometimes outputs multiple result records for one command
296	root	1.3	$cb->($class, $results, delete $self->{console});
297	root	1.1	}
298
299			} elsif (/\G([+=])([^,]+)/gc) { # exec-async, +status-async, =notify-async
300			my ($type, $class) = ($type_map{$1}, $2);
301
302			my $results = /\G,/gc ? &_parse_results : {};
303
304	root	1.3	$class =~ y/-/_/;
305
306	root	1.2	$self->event ($type => $class, $results);
307	root	1.3	$self->event ("$type\_$class" => $results);
308	root	1.1
309			} elsif (/\G~"/gc) {
310	root	1.3	push @{ $self->{console} }, &_parse_c_string;
311	root	1.1	} elsif (/\G&"/gc) {
312	root	1.3	my $log = &_parse_c_string;
313			print "$log\n" if $self->{verbose};
314			$self->event (log => $log);
315	root	1.1	} elsif (/\G\@"/gc) {
316	root	1.3	$self->event (target => &_parse_c_string);
317	root	1.1	}
318			};
319
320			/\G(.{0,16})/gcs;
321			$@ = "extra data\n" if !$@ and length $1;
322
323			if ($@) {
324			chop $@;
325	root	1.3	warn "AnyEvent::GDB: parse error: $@, at ...$1\n";
326			$self->eof;
327	root	1.1	}
328			}
329			}
330			}
331
332			sub _q($) {
333			return $_[0]
334			if $_[0] =~ /^[A-Za-z0-9_]+$/; # we are a lot more strict than the spec
335
336			local $_ = shift;
337			utf8::encode $_; # just in case
338			s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\x%02x", ord $1/ge;
339			"\"$_\""
340			}
341
342			=item $gdb->cmd_raw ($command, $cb->($class, $results, $console))
343
344			Execute a raw command: C<$command> is sent unchanged to GDB. See C<cmd_>
345			for a description of the callback arguments.
346
347			Example: execute a CLI command and print its output.
348
349			$gdb->cmd_raw ("info sh", sub {
350			print "$_[3]\n";
351			});
352
353			=cut
354
355			sub cmd_raw {
356			my ($self, $cmd, $cb) = @_;
357
358			my $token = ++$self->{token};
359			$self->send ("$token$cmd\n");
360			$self->{cb}{$token} = $cb;
361			}
362
363			=item $gdb->cmd ($command => [$option...], $parameter..., $cb->($class, $results, $console))
364
365			Execute a MI command and invoke the callback with the results.
366
367	root	1.2	C<$command> is a MI command name. The leading minus sign can be omitted,
368			and instead of minus signs, you can use underscores, i.e. all the
369			following command names are equivalent:
370
371			"-break-insert" # as documented in the GDB manual
372			-break_insert # using underscores and _ to avoid having to quote
373			break_insert # ditto, when e.g. used to the left of a =>
374			"break-insert" # no leading minus
375	root	1.1
376			The second argument is an optional array reference with options (i.e. it
377			can simply be missing). Each C<$option> is either an option name (similar
378			rules as with command names, i.e. no initial C<-->) or an array reference
379			with the first element being the option name, and the remaining elements
380			being parameters: [$option, $parameter...].
381
382			The remaining arguments, excluding the last one, are simply the parameters
383			passed to GDB.
384
385			All options and parameters will be properly quoted.
386
387			When the command is done, the callback C<$cb> will be invoked with
388			C<$class> being one of C<done>, C<connected>, C<error> or C<exit>
389			(note: not C<running>), C<$results> being a has reference with all the
390			C<variable=value> pairs from the result list.
391
392			C<$console> is an array reference with all the GDB console messages
393			written while command executes (for MI commands, this should always be
394			C<undef> and can be ignored).
395
396			Example: #todo#
397
398			=cut
399
400			sub cmd {
401			my $cb = pop;
402			my ($self, $cmd, @arg) = @_;
403
404	root	1.2	$cmd =~ s/^[\-_]?/_/;
405			$cmd =~ y/_/-/;
406
407			$cmd .= " ";
408	root	1.1
409			my $opt = ref $arg[0] ? shift @arg : [];
410
411			for (@$opt) {
412			$cmd .= "-";
413			$cmd .= (_q $_) . " "
414			for (ref) ? @$_ : $_;
415			}
416
417			# the mi syntax is inconsistent, providing "--" in case
418			# parameters start with "-", but not allowing "-" as first
419			# char of a parameter. in fact, "--" is flagged as unknown
420			# option.
421			if (@arg) {
422			# $cmd .= "-- ";
423
424			$cmd .= (_q $_) . " "
425			for @arg;
426			}
427
428			# remove trailing " "
429			substr $cmd, -1, 1, "";
430
431			$self->cmd_raw ($cmd, $cb);
432			}
433
434			=item ($class, $results, $console) = $gdb->cmd_sync ($command => [$option...], $parameter...])
435
436			Like C<cmd>, but blocks execution until the command has been executed, and returns the results.
437
438			This is purely a convenience method for small scripts: since it blocks
439			execution using a condvar, it is not suitable to be used inside callbacks
440			or modules, unless L<Coro> is used.
441
442			=cut
443
444			sub cmd_sync {
445			push @_, my $cv = AE::cv;
446			&cmd;
447			$cv->recv
448			}
449
450			sub event {
451			my ($self, $event, @args) = @_;
452
453	root	1.2	# if ($self->{verbose}) {
454			# use Data::Dumper;
455			# print Data::Dumper
456			# ->new ([[$event, @args]])
457			# ->Pair ("=>")
458			# ->Useqq (1)
459			# ->Indent (0)
460			# ->Terse (1)
461			# ->Quotekeys (0)
462			# ->Sortkeys (1)
463			# ->Dump,
464			# "\n";
465			# }
466
467	root	1.3	my $cb;
468
469			$cb = $self-> {"on_$event"} and $cb->($self, $event, @args);
470			$cb = $self->can ("on_$event") and $cb->($self, $event, @args);
471			$cb = $self-> {on_event} and $cb->($self, $event, @args);
472			$cb = $self->can ("on_event") and $cb->($self, $event, @args);
473			}
474
475			# predefined events
476
477			sub on_notify_thread_group_added {
478			my ($self, undef, $r) = @_;
479
480			$self->{thread_group}{$r->{id}} = $r;
481			}
482
483			sub on_notify_thread_group_removed {
484			my ($self, undef, $r) = @_;
485
486			delete $self->{thread_group}{$r->{id}};
487			}
488
489			sub on_notify_thread_group_started {
490			my ($self, undef, $r) = @_;
491
492			delete $self->{thread_group}{exit_code};
493			$self->{thread_group}{$r->{id}}{pid} = $r->{pid};
494			}
495
496			sub on_notify_thread_group_exited {
497			my ($self, undef, $r) = @_;
498
499			delete $self->{thread_group}{pid};
500			$self->{thread_group}{$r->{id}}{exit_code} = $r->{exit_code};
501			}
502
503			sub on_notify_record_started {
504			my ($self, undef, $r) = @_;
505
506			$self->{thread_group}{$r->{id}}{recording} = 1;
507			}
508
509			sub on_notify_record_stopped {
510			my ($self, undef, $r) = @_;
511
512			$self->{thread_group}{$r->{id}}{recording} = 0;
513			}
514
515			sub on_notify_thread_created {
516			my ($self, undef, $r) = @_;
517
518			$self->{thread}{$r->{id}} = $r;
519			}
520
521			sub on_notify_thread_exited {
522			my ($self, undef, $r) = @_;
523
524			delete $self->{thread}{$r->{id}};
525			}
526
527			sub _threads {
528			my ($self, $r) = @_;
529
530			$r->{thread_id} eq "all"
531			? values %{ $self->{thread} }
532			: $self->{thread}{$r->{thread_id}}
533			}
534
535			sub on_exec_running {
536			my ($self, undef, $r) = @_;
537
538			for ($self->_threads ($r)) {
539			delete $_->{stopped};
540			$_->{running} = 1;
541			}
542			}
543
544			sub on_exec_stopped {
545			my ($self, undef, $r) = @_;
546
547			for ($self->_threads ($r)) {
548			delete $_->{running};
549			$_->{stopped} = $r;
550			}
551
552			# $self->event ("thread_$r->{reason}" => $r, [map $_->{id}, $self->_threads ($r)]);
553			}
554
555			sub _thread_groups {
556			my ($self, $r) = @_;
557	root	1.2
558	root	1.3	exists $r->{thread_group}
559			? $self->{thread_group}{$r->{thread_group}}
560			: values %{ $self->{thread_group} }
561	root	1.1	}
562
563	root	1.3	sub on_notify_library_loaded {
564			my ($self, undef, $r) = @_;
565
566			$_->{library}{$r->{id}} = $r
567			for $self->_thread_groups ($r);
568			}
569
570			sub on_notify_library_unloaded {
571			my ($self, undef, $r) = @_;
572
573			delete $_->{library}{$r->{id}}
574			for $self->_thread_groups ($r);
575			}
576
577			=back
578
579			=head2 EVENTS
580
581			AnyEvent::GDB is asynchronous in nature, as the goal of the MI interface
582			is to be fully asynchronous. Due to this, a user of this interface must
583			be prepared to handle various events.
584
585			When an event is produced, the GDB object will look for the following
586			four handlers and, if found, will call it with the GDB object and event
587			name (without C<on_>) as the first two arguments, followed by any
588			event-specific arguments:
589
590			=over 4
591
592			=item on_EVENTNAME constructor parameter
593
594			Any callback specified as C<on_EVENTNAME> parameter to the constructor.
595
596			=item on_EVENTNAME method on the GDB object
597
598			Useful when subclassing.
599
600			=item on_event constructor parameter
601
602			The callback specified as C<on_event> parameter to the constructor.
603
604			=item on_event method on the GDB object
605
606			Again, mainly useful when subclassing.
607
608			=back
609
610			Here's the list of events with a description of their arguments.
611
612			=over 4
613
614			=item on_eof => $cb->($gdb, "eof")
615
616			Called whenever GDB closes the connection. After this event, the object is
617			partially destroyed and must not be accessed again.
618
619			=item on_target => $cb->($gdb, "target", $string)
620
621			Output received from the target. Normally, this is sent directly to STDOUT
622			by GDB, but remote targets use this hook.
623
624			=item on_log => $cb->($gdb, "log", $string)
625
626			Log output from GDB. Best printed to STDOUT in interactive sessions.
627
628			=item on_TYPE => $cb->($gdb, "TYPE", $class, $results)
629
630			Called for GDB C<exec>, C<status> and C<notify> event (TYPE is one of
631			these three strings). C<$class> is the class of the event, with C<->
632			replaced by C<_> everywhere.
633
634			For each of these, the GDB object will create I<two> events: one for TYPE,
635			and one for TYPE_CLASS. Usuaully you should provide the more specific
636			event (TYPE_CLASS).
637
638			=item on_TYPE_CLASS => $cb->($gdb, "TYPE_CLASS", $results)
639
640			Called for GDB C<exec>, C<status> and C<notify> event: TYPE is one
641			of these three strings, the class of the event (with C<-> replaced b
642			C<_>s) is appended to it to form the TYPE_CLASS (e.g. C<exec_stopped> or
643			C<notify_library_loaded>).
644
645	root	1.1	=back
646
647			=head1 SEE ALSO
648
649			L<AnyEvent>, L<http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI>.
650
651			=head1 AUTHOR
652
653			Marc Lehmann <schmorp@schmorp.de>
654			http://home.schmorp.de/
655
656			=cut
657
658			1