cvsroot/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 "> $data"
      if $self->{verbose};

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

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

   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 => $class, $results);
               $self->event ($class => $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. 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
}

our %DEFAULT_ACTION = (
   on_log_stream => sub {
      print "$_[0]\n";
   },
);

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 = $self->{"on_$event"} || $DEFAULT_ACTION{$event}
      or return;

   $cb->(@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.2
Committed:	Sun Dec 23 10:47:17 2012 UTC (13 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.1:	+44 -12 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			=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	root	1.2	print "> $data"
114			if $self->{verbose};
115	root	1.1
116			$self->{wbuf} .= $data;
117			$self->{ww} \|\|= AE::io $self->{fh}, 1, $self->{wcb};
118			}
119
120			our %C_ESCAPE = (
121			"\\" => "\\",
122			'"' => '"',
123			"'" => "'",
124			"?" => "?",
125
126			a => "\x07",
127			b => "\x08",
128			t => "\x09",
129			n => "\x0a",
130			v => "\x0b",
131			f => "\x0c",
132			r => "\x0d",
133			);
134
135			sub _parse_c_string {
136			my $r = "";
137
138			# syntax is not documented, so we do full C99, except unicode
139
140			while () {
141			if (/\G([^"\\\n]+)/gc) {
142			$r .= $1;
143			} elsif (/\G\\([abtnvfr\\"'?])/gc) {
144			$r .= $C_ESCAPE{$1};
145			} elsif (/\G\\([0-8]{1,3})/gc) {
146			$r .= chr oct $1;
147			} elsif (/\G\\x([0-9a-fA-F]+)/gc) {
148			$r .= chr hex $1;
149			} elsif (/\G"/gc) {
150			last;
151			} else {
152			die "invalid string syntax\n";
153			}
154			}
155
156			$r
157			}
158
159			sub _parse_value {
160			if (/\G"/gc) { # c-string
161			&_parse_c_string
162
163			} elsif (/\G\{/gc) { # tuple
164			my $r = &_parse_results;
165
166			/\G\}/gc
167			or die "tuple does not end with '}'\n";
168
169			$r
170
171			} elsif (/\G\[/gc) { # list
172			my @r;
173
174			until (/\G\]/gc) {
175			# if GDB outputs "result" in lists, let me know and uncomment the following lines
176			# # list might also contain key value pairs, but apparently
177			# # those are supposed to be ordered, so we use an array in perl.
178			# push @r, $1
179			# if /\G([^=,\[\]\{\}]+)=/gc;
180
181			push @r, &_parse_value;
182
183			/\G,/gc
184			or last;
185			}
186
187			/\G\]/gc
188			or die "list does not end with ']'\n";
189
190			\@r
191
192			} else {
193			die "value expected\n";
194			}
195			}
196
197			sub _parse_results {
198			my %r;
199
200			# syntax for string is undocumented
201			while (/\G([^=,\[\]\{\}]+)=/gc) {
202			my $k = $1;
203
204			$r{$k} = &_parse_value;
205
206			/\G,/gc
207			or last;
208			}
209
210			\%r
211			}
212
213			my %type_map = qw(
214			* exec_async
215			+ status_async
216			= notify_async
217			);
218
219			sub feed {
220			my ($self, $line) = @_;
221
222	root	1.2	print "< $line\n"
223			if $self->{verbose};
224	root	1.1
225			for ($line) {
226			if (/^\(gdb\)\s*$/gc) { # docs say "(gdb)", but reality says "(gdb) "
227			# nop
228			} else {
229			/^([0-9]*)/gc; # [token], actually ([0-9]+)?
230			my $token = $1;
231
232			eval {
233			if (/\G\^(done\|running\|connected\|error\|exit)/gc) { # result
234			my $class = $1 eq "running" ? "done" : $1;
235			# documented for error is an incompatible format, but in reality it is sane
236
237			my $results = /\G,/gc ? &_parse_results : {};
238
239			if (my $cb = delete $self->{cb}{$token}) {
240			# unfortunately, gdb sometimes outputs multiple result records for one command
241			$cb->($class, $results, delete $self->{console_stream});
242			}
243
244			} elsif (/\G([+=])([^,]+)/gc) { # exec-async, +status-async, =notify-async
245			my ($type, $class) = ($type_map{$1}, $2);
246
247			my $results = /\G,/gc ? &_parse_results : {};
248
249	root	1.2	$self->event ($type => $class, $results);
250			$self->event ($class => $results);
251	root	1.1
252			} elsif (/\G~"/gc) {
253			push @{ $self->{console_stream} }, &_parse_c_string;
254			} elsif (/\G&"/gc) {
255			$self->event (log_stream => &_parse_c_string);
256			} elsif (/\G\@"/gc) {
257			$self->event (target_stream => &_parse_c_string);
258			}
259			};
260
261			/\G(.{0,16})/gcs;
262			$@ = "extra data\n" if !$@ and length $1;
263
264			if ($@) {
265			chop $@;
266			die "parse error: $@, at ...$1\n";
267			}
268			}
269			}
270			}
271
272			sub _q($) {
273			return $_[0]
274			if $_[0] =~ /^[A-Za-z0-9_]+$/; # we are a lot more strict than the spec
275
276			local $_ = shift;
277			utf8::encode $_; # just in case
278			s/([^\x20-\x21\x23-\x5b\x5d-\x7e])/sprintf "\\x%02x", ord $1/ge;
279			"\"$_\""
280			}
281
282			=item $gdb->cmd_raw ($command, $cb->($class, $results, $console))
283
284			Execute a raw command: C<$command> is sent unchanged to GDB. See C<cmd_>
285			for a description of the callback arguments.
286
287			Example: execute a CLI command and print its output.
288
289			$gdb->cmd_raw ("info sh", sub {
290			print "$_[3]\n";
291			});
292
293			=cut
294
295			sub cmd_raw {
296			my ($self, $cmd, $cb) = @_;
297
298			my $token = ++$self->{token};
299			$self->send ("$token$cmd\n");
300			$self->{cb}{$token} = $cb;
301			}
302
303			=item $gdb->cmd ($command => [$option...], $parameter..., $cb->($class, $results, $console))
304
305			Execute a MI command and invoke the callback with the results.
306
307	root	1.2	C<$command> is a MI command name. The leading minus sign can be omitted,
308			and instead of minus signs, you can use underscores, i.e. all the
309			following command names are equivalent:
310
311			"-break-insert" # as documented in the GDB manual
312			-break_insert # using underscores and _ to avoid having to quote
313			break_insert # ditto, when e.g. used to the left of a =>
314			"break-insert" # no leading minus
315	root	1.1
316			The second argument is an optional array reference with options (i.e. it
317			can simply be missing). Each C<$option> is either an option name (similar
318			rules as with command names, i.e. no initial C<-->) or an array reference
319			with the first element being the option name, and the remaining elements
320			being parameters: [$option, $parameter...].
321
322			The remaining arguments, excluding the last one, are simply the parameters
323			passed to GDB.
324
325			All options and parameters will be properly quoted.
326
327			When the command is done, the callback C<$cb> will be invoked with
328			C<$class> being one of C<done>, C<connected>, C<error> or C<exit>
329			(note: not C<running>), C<$results> being a has reference with all the
330			C<variable=value> pairs from the result list.
331
332			C<$console> is an array reference with all the GDB console messages
333			written while command executes (for MI commands, this should always be
334			C<undef> and can be ignored).
335
336			Example: #todo#
337
338			=cut
339
340			sub cmd {
341			my $cb = pop;
342			my ($self, $cmd, @arg) = @_;
343
344	root	1.2	$cmd =~ s/^[\-_]?/_/;
345			$cmd =~ y/_/-/;
346
347			$cmd .= " ";
348	root	1.1
349			my $opt = ref $arg[0] ? shift @arg : [];
350
351			for (@$opt) {
352			$cmd .= "-";
353			$cmd .= (_q $_) . " "
354			for (ref) ? @$_ : $_;
355			}
356
357			# the mi syntax is inconsistent, providing "--" in case
358			# parameters start with "-", but not allowing "-" as first
359			# char of a parameter. in fact, "--" is flagged as unknown
360			# option.
361			if (@arg) {
362			# $cmd .= "-- ";
363
364			$cmd .= (_q $_) . " "
365			for @arg;
366			}
367
368			# remove trailing " "
369			substr $cmd, -1, 1, "";
370
371			$self->cmd_raw ($cmd, $cb);
372			}
373
374			=item ($class, $results, $console) = $gdb->cmd_sync ($command => [$option...], $parameter...])
375
376			Like C<cmd>, but blocks execution until the command has been executed, and returns the results.
377
378			This is purely a convenience method for small scripts: since it blocks
379			execution using a condvar, it is not suitable to be used inside callbacks
380			or modules, unless L<Coro> is used.
381
382			=cut
383
384			sub cmd_sync {
385			push @_, my $cv = AE::cv;
386			&cmd;
387			$cv->recv
388			}
389
390	root	1.2	our %DEFAULT_ACTION = (
391			on_log_stream => sub {
392			print "$_[0]\n";
393			},
394			);
395
396	root	1.1	sub event {
397			my ($self, $event, @args) = @_;
398
399	root	1.2	# if ($self->{verbose}) {
400			# use Data::Dumper;
401			# print Data::Dumper
402			# ->new ([[$event, @args]])
403			# ->Pair ("=>")
404			# ->Useqq (1)
405			# ->Indent (0)
406			# ->Terse (1)
407			# ->Quotekeys (0)
408			# ->Sortkeys (1)
409			# ->Dump,
410			# "\n";
411			# }
412
413			my $cb = $self->{"on_$event"} \|\| $DEFAULT_ACTION{$event}
414			or return;
415
416			$cb->(@args);
417			# use Data::Dump;
418			# ddx [$event, @args];
419	root	1.1	}
420
421			=back
422
423			=head1 SEE ALSO
424
425			L<AnyEvent>, L<http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI>.
426
427			=head1 AUTHOR
428
429			Marc Lehmann <schmorp@schmorp.de>
430			http://home.schmorp.de/
431
432			=cut
433
434			1