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.

=cut

package AnyEvent::GDB;

use common::sense;

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

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

our $VERSION = '0.0';

=head2 METHODS

=over 4

=item $gdb = new AnyEvent::GDB

=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 on_error => $callback->($dbh, $filename, $line, $fatal)#d#

=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->{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 {
         $self->fatal ("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->fatal ("unexpected EOF from GDB");

         $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 send {
   my ($self, $data) = @_;

   print "s<$data>\n";#d#

   $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;

      $r{$k} = &_parse_value;

      /\G,/gc
         or last;
   }

   \%r
}

my %type_map = qw(
   * exec_async
   + status_async
   = notify_async
);

sub feed {
   my ($self, $line) = @_;
   use Data::Dump; #d#

   warn "parse<$line>\n";#d#

   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_stream});
               }

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

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

               $self->event ($type => $results);

            } elsif (/\G~"/gc) {
               push @{ $self->{console_stream} }, &_parse_c_string;
            } elsif (/\G&"/gc) {
               $self->event (log_stream        => &_parse_c_string);
            } elsif (/\G\@"/gc) {
               $self->event (target_stream     => &_parse_c_string);
            }
         };

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

         if ($@) {
            chop $@;
            die "parse error: $@, at ...$1\n";
         }
      }
   }
}

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, with C<-> replaced by C<_> and without
the intiial C<->, i.e. the GDB MI command C<-file-exec-and-symbols>
becomes C<file_exec_and_symbols>.

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 = "-$cmd ";
   $cmd =~ s/_/-/g;

   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) = @_;

   use Data::Dump;
   ddx [$event, @args];

}

=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.1
Committed:	Sun Dec 23 03:25:39 2012 UTC (11 years, 5 months ago) by root
Branch:	MAIN
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			=cut
15
16			package AnyEvent::GDB;
17
18			use common::sense;
19
20			use Fcntl ();
21			use Scalar::Util ();
22
23			use AnyEvent ();
24			use AnyEvent::Util ();
25
26			our $VERSION = '0.0';
27
28			=head2 METHODS
29
30			=over 4
31
32			=item $gdb = new AnyEvent::GDB
33
34			=over 4
35
36			=item exec => $path (default: "gdb")
37
38			The path of the GDB executable.
39
40			=item args => [$string...] (default: ["-n"])
41
42			An optional array of parameters to pass to GDB. This should not be
43			used to load a program executable, use the C<file_exec_and_symbols>,
44			C<target_attach> or similar MI commands instead.
45
46			=item on_error => $callback->($dbh, $filename, $line, $fatal)#d#
47
48			=back
49
50			=cut
51
52			sub new {
53			my ($class, %arg) = @_;
54
55			my $self = bless {
56			%arg,
57			}, $class;
58
59			my $exe = delete $self->{exec} // "gdb";
60			my $arg = delete $self->{args} // [qw(-n)];
61
62			($self->{fh}, my $fh2) = AnyEvent::Util::portable_socketpair;
63
64			$self->{pid} = fork;
65
66			open my $stdin , "<&STDIN" ;
67			open my $stdout, ">&STDOUT";
68
69			unless ($self->{pid}) {
70			if (defined $self->{pid}) {
71			open STDIN , "<&", $fh2;
72			open STDOUT, ">&", $fh2;
73			fcntl $stdin , Fcntl::F_SETFD, 0;
74			fcntl $stdout, Fcntl::F_SETFD, 0;
75			exec $exe, qw(--interpreter=mi2 -q), @$arg;
76			kill 9, 0; # don't want to load the POSIX module just for this
77			} else {
78			$self->fatal ("cannot fork: $!");
79			}
80			}
81
82			AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
83
84			{
85			Scalar::Util::weaken (my $self = $self);
86			$self->{rw} = AE::io $self->{fh}, 0, sub {
87			my $len = sysread $self->{fh}, $self->{rbuf}, 256, length $self->{rbuf};
88
89			defined $len \|\| $self->fatal ("unexpected EOF from GDB");
90
91			$self->feed ("$1")
92			while $self->{rbuf} =~ s/^([^\r\n]*)\r?\n//;
93			};
94
95			$self->{wcb} = sub {
96			my $len = syswrite $self->{fh}, $self->{wbuf};
97			substr $self->{wbuf}, 0, $len, "";
98			delete $self->{ww} unless length $self->{wbuf};
99			};
100			}
101
102			$self->cmd_raw ((sprintf "run <&%d >&%d", fileno $stdin, fileno $stdout), sub { });
103
104			$self
105			}
106
107			#sub DESTROY {
108			#)}
109
110			sub send {
111			my ($self, $data) = @_;
112
113			print "s<$data>\n";#d#
114
115			$self->{wbuf} .= $data;
116			$self->{ww} \|\|= AE::io $self->{fh}, 1, $self->{wcb};
117			}
118
119			our %C_ESCAPE = (
120			"\\" => "\\",
121			'"' => '"',
122			"'" => "'",
123			"?" => "?",
124
125			a => "\x07",
126			b => "\x08",
127			t => "\x09",
128			n => "\x0a",
129			v => "\x0b",
130			f => "\x0c",
131			r => "\x0d",
132			);
133
134			sub _parse_c_string {
135			my $r = "";
136
137			# syntax is not documented, so we do full C99, except unicode
138
139			while () {
140			if (/\G([^"\\\n]+)/gc) {
141			$r .= $1;
142			} elsif (/\G\\([abtnvfr\\"'?])/gc) {
143			$r .= $C_ESCAPE{$1};
144			} elsif (/\G\\([0-8]{1,3})/gc) {
145			$r .= chr oct $1;
146			} elsif (/\G\\x([0-9a-fA-F]+)/gc) {
147			$r .= chr hex $1;
148			} elsif (/\G"/gc) {
149			last;
150			} else {
151			die "invalid string syntax\n";
152			}
153			}
154
155			$r
156			}
157
158			sub _parse_value {
159			if (/\G"/gc) { # c-string
160			&_parse_c_string
161
162			} elsif (/\G\{/gc) { # tuple
163			my $r = &_parse_results;
164
165			/\G\}/gc
166			or die "tuple does not end with '}'\n";
167
168			$r
169
170			} elsif (/\G\[/gc) { # list
171			my @r;
172
173			until (/\G\]/gc) {
174			# if GDB outputs "result" in lists, let me know and uncomment the following lines
175			# # list might also contain key value pairs, but apparently
176			# # those are supposed to be ordered, so we use an array in perl.
177			# push @r, $1
178			# if /\G([^=,\[\]\{\}]+)=/gc;
179
180			push @r, &_parse_value;
181
182			/\G,/gc
183			or last;
184			}
185
186			/\G\]/gc
187			or die "list does not end with ']'\n";
188
189			\@r
190
191			} else {
192			die "value expected\n";
193			}
194			}
195
196			sub _parse_results {
197			my %r;
198
199			# syntax for string is undocumented
200			while (/\G([^=,\[\]\{\}]+)=/gc) {
201			my $k = $1;
202
203			$r{$k} = &_parse_value;
204
205			/\G,/gc
206			or last;
207			}
208
209			\%r
210			}
211
212			my %type_map = qw(
213			* exec_async
214			+ status_async
215			= notify_async
216			);
217
218			sub feed {
219			my ($self, $line) = @_;
220			use Data::Dump; #d#
221
222			warn "parse<$line>\n";#d#
223
224			for ($line) {
225			if (/^\(gdb\)\s*$/gc) { # docs say "(gdb)", but reality says "(gdb) "
226			# nop
227			} else {
228			/^([0-9]*)/gc; # [token], actually ([0-9]+)?
229			my $token = $1;
230
231			eval {
232			if (/\G\^(done\|running\|connected\|error\|exit)/gc) { # result
233			my $class = $1 eq "running" ? "done" : $1;
234			# documented for error is an incompatible format, but in reality it is sane
235
236			my $results = /\G,/gc ? &_parse_results : {};
237
238			if (my $cb = delete $self->{cb}{$token}) {
239			# unfortunately, gdb sometimes outputs multiple result records for one command
240			$cb->($class, $results, delete $self->{console_stream});
241			}
242
243			} elsif (/\G([+=])([^,]+)/gc) { # exec-async, +status-async, =notify-async
244			my ($type, $class) = ($type_map{$1}, $2);
245
246			my $results = /\G,/gc ? &_parse_results : {};
247
248			$self->event ($type => $results);
249
250			} elsif (/\G~"/gc) {
251			push @{ $self->{console_stream} }, &_parse_c_string;
252			} elsif (/\G&"/gc) {
253			$self->event (log_stream => &_parse_c_string);
254			} elsif (/\G\@"/gc) {
255			$self->event (target_stream => &_parse_c_string);
256			}
257			};
258
259			/\G(.{0,16})/gcs;
260			$@ = "extra data\n" if !$@ and length $1;
261
262			if ($@) {
263			chop $@;
264			die "parse error: $@, at ...$1\n";
265			}
266			}
267			}
268			}
269
270			sub _q($) {
271			return $_[0]
272			if $_[0] =~ /^[A-Za-z0-9_]+$/; # we are a lot more strict than the spec
273
274			local $_ = shift;
275			utf8::encode $_; # just in case
276			s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\x%02x", ord $1/ge;
277			"\"$_\""
278			}
279
280			=item $gdb->cmd_raw ($command, $cb->($class, $results, $console))
281
282			Execute a raw command: C<$command> is sent unchanged to GDB. See C<cmd_>
283			for a description of the callback arguments.
284
285			Example: execute a CLI command and print its output.
286
287			$gdb->cmd_raw ("info sh", sub {
288			print "$_[3]\n";
289			});
290
291			=cut
292
293			sub cmd_raw {
294			my ($self, $cmd, $cb) = @_;
295
296			my $token = ++$self->{token};
297			$self->send ("$token$cmd\n");
298			$self->{cb}{$token} = $cb;
299			}
300
301			=item $gdb->cmd ($command => [$option...], $parameter..., $cb->($class, $results, $console))
302
303			Execute a MI command and invoke the callback with the results.
304
305			C<$command> is a MI command name, with C<-> replaced by C<_> and without
306			the intiial C<->, i.e. the GDB MI command C<-file-exec-and-symbols>
307			becomes C<file_exec_and_symbols>.
308
309			The second argument is an optional array reference with options (i.e. it
310			can simply be missing). Each C<$option> is either an option name (similar
311			rules as with command names, i.e. no initial C<-->) or an array reference
312			with the first element being the option name, and the remaining elements
313			being parameters: [$option, $parameter...].
314
315			The remaining arguments, excluding the last one, are simply the parameters
316			passed to GDB.
317
318			All options and parameters will be properly quoted.
319
320			When the command is done, the callback C<$cb> will be invoked with
321			C<$class> being one of C<done>, C<connected>, C<error> or C<exit>
322			(note: not C<running>), C<$results> being a has reference with all the
323			C<variable=value> pairs from the result list.
324
325			C<$console> is an array reference with all the GDB console messages
326			written while command executes (for MI commands, this should always be
327			C<undef> and can be ignored).
328
329			Example: #todo#
330
331			=cut
332
333			sub cmd {
334			my $cb = pop;
335			my ($self, $cmd, @arg) = @_;
336
337			$cmd = "-$cmd ";
338			$cmd =~ s/_/-/g;
339
340			my $opt = ref $arg[0] ? shift @arg : [];
341
342			for (@$opt) {
343			$cmd .= "-";
344			$cmd .= (_q $_) . " "
345			for (ref) ? @$_ : $_;
346			}
347
348			# the mi syntax is inconsistent, providing "--" in case
349			# parameters start with "-", but not allowing "-" as first
350			# char of a parameter. in fact, "--" is flagged as unknown
351			# option.
352			if (@arg) {
353			# $cmd .= "-- ";
354
355			$cmd .= (_q $_) . " "
356			for @arg;
357			}
358
359			# remove trailing " "
360			substr $cmd, -1, 1, "";
361
362			$self->cmd_raw ($cmd, $cb);
363			}
364
365			=item ($class, $results, $console) = $gdb->cmd_sync ($command => [$option...], $parameter...])
366
367			Like C<cmd>, but blocks execution until the command has been executed, and returns the results.
368
369			This is purely a convenience method for small scripts: since it blocks
370			execution using a condvar, it is not suitable to be used inside callbacks
371			or modules, unless L<Coro> is used.
372
373			=cut
374
375			sub cmd_sync {
376			push @_, my $cv = AE::cv;
377			&cmd;
378			$cv->recv
379			}
380
381			sub event {
382			my ($self, $event, @args) = @_;
383
384			use Data::Dump;
385			ddx [$event, @args];
386
387			}
388
389			=back
390
391			=head1 SEE ALSO
392
393			L<AnyEvent>, L<http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI>.
394
395			=head1 AUTHOR
396
397			Marc Lehmann <schmorp@schmorp.de>
398			http://home.schmorp.de/
399
400			=cut
401
402			1