ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-GDB/GDB.pm
Revision: 1.5
Committed: Fri Dec 28 10:10:00 2012 UTC (11 years, 5 months ago) by root
Branch: MAIN
Changes since 1.4: +7 -7 lines
Log Message:
*** empty log message ***

File Contents

# Content
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 =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 =cut
29
30 package AnyEvent::GDB;
31
32 use common::sense;
33
34 use Carp ();
35 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 =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
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 =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
89 =back
90
91
92 =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 $self->{verbose} = 1
105 if $self->{trace} && !exists $self->{verbose};
106
107 ($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 Carp::croak "cannot fork: $!";
124 }
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 defined $len || $self->eof;
135
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 sub eof {
156 my ($self) = @_;
157
158 $self->event ("eof");
159
160 %$self = ();
161 }
162
163 sub send {
164 my ($self, $data) = @_;
165
166 print "> $data"
167 if $self->{trace};
168
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 $k =~ y/-/_/;
258
259 $r{$k} = &_parse_value;
260
261 /\G,/gc
262 or last;
263 }
264
265 \%r
266 }
267
268 my %type_map = qw(
269 * exec
270 + status
271 = notify
272 );
273
274 sub feed {
275 my ($self, $line) = @_;
276
277 print "< $line\n"
278 if $self->{trace};
279
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 $cb->($class, $results, delete $self->{console});
297 }
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 $class =~ y/-/_/;
305
306 $self->event ($type => $class, $results);
307 $self->event ("$type\_$class" => $results);
308
309 } elsif (/\G~"/gc) {
310 push @{ $self->{console} }, &_parse_c_string;
311 } elsif (/\G&"/gc) {
312 my $log = &_parse_c_string;
313 print "$log\n" if $self->{verbose};
314 $self->event (log => $log);
315 } elsif (/\G\@"/gc) {
316 $self->event (target => &_parse_c_string);
317 }
318 };
319
320 /\G(.{0,16})/gcs;
321 $@ = "extra data\n" if !$@ and length $1;
322
323 if ($@) {
324 chop $@;
325 warn "AnyEvent::GDB: parse error: $@, at ...$1\n";
326 $self->eof;
327 }
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 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
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 $cmd =~ s/^[\-_]?/_/;
405 $cmd =~ y/_/-/;
406
407 $cmd .= " ";
408
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 # 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 my $cb;
468
469 $cb = $self->can ("on_event") and $cb->($self, $event, @args);
470 $cb = $self-> {on_event} and $cb->($self, $event, @args);
471 $cb = $self->can ("on_$event") and $cb->($self, $event, @args);
472 $cb = $self-> {"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, $id) = @_;
529
530 ref $id
531 ? @{ $self->{thread} }{@$id}
532 : $id eq "all"
533 ? values %{ $self->{thread} }
534 : $self->{thread}{$id}
535 }
536
537 sub on_exec_running {
538 my ($self, undef, $r) = @_;
539
540 for ($self->_threads ($r->{thread_id})) {
541 delete $_->{stopped};
542 $_->{running} = 1;
543 }
544 }
545
546 sub on_exec_stopped {
547 my ($self, undef, $r) = @_;
548
549 for ($self->_threads ($r->{stopped_threads})) {
550 delete $_->{running};
551 $_->{stopped} = $r;
552 }
553
554 # $self->event ("thread_$r->{reason}" => $r, [map $_->{id}, $self->_threads ($r)]);
555 }
556
557 sub _thread_groups {
558 my ($self, $r) = @_;
559
560 exists $r->{thread_group}
561 ? $self->{thread_group}{$r->{thread_group}}
562 : values %{ $self->{thread_group} }
563 }
564
565 sub on_notify_library_loaded {
566 my ($self, undef, $r) = @_;
567
568 $_->{library}{$r->{id}} = $r
569 for $self->_thread_groups ($r);
570 }
571
572 sub on_notify_library_unloaded {
573 my ($self, undef, $r) = @_;
574
575 delete $_->{library}{$r->{id}}
576 for $self->_thread_groups ($r);
577 }
578
579 =back
580
581 =head2 EVENTS
582
583 AnyEvent::GDB is asynchronous in nature, as the goal of the MI interface
584 is to be fully asynchronous. Due to this, a user of this interface must
585 be prepared to handle various events.
586
587 When an event is produced, the GDB object will look for the following four
588 handlers and, if found, will call each one in order with the GDB object
589 and event name (without C<on_>) as the first two arguments, followed by
590 any event-specific arguments:
591
592 =over 4
593
594 =item on_event method on the GDB object
595
596 Useful when subclassing.
597
598 =item on_event constructor parameter
599
600 The callback specified as C<on_event> parameter to the constructor.
601
602 =item on_EVENTNAME method on the GDB object
603
604 Again, mainly useful when subclassing.
605
606 =item on_EVENTNAME constructor parameter
607
608 Any callback specified as C<on_EVENTNAME> parameter to the constructor.
609
610 =back
611
612 Here's the list of events with a description of their arguments.
613
614 =over 4
615
616 =item on_eof => $cb->($gdb, "eof")
617
618 Called whenever GDB closes the connection. After this event, the object is
619 partially destroyed and must not be accessed again.
620
621 =item on_target => $cb->($gdb, "target", $string)
622
623 Output received from the target. Normally, this is sent directly to STDOUT
624 by GDB, but remote targets use this hook.
625
626 =item on_log => $cb->($gdb, "log", $string)
627
628 Log output from GDB. Best printed to STDOUT in interactive sessions.
629
630 =item on_TYPE => $cb->($gdb, "TYPE", $class, $results)
631
632 Called for GDB C<exec>, C<status> and C<notify> event (TYPE is one of
633 these three strings). C<$class> is the class of the event, with C<->
634 replaced by C<_> everywhere.
635
636 For each of these, the GDB object will create I<two> events: one for TYPE,
637 and one for TYPE_CLASS. Usuaully you should provide the more specific
638 event (TYPE_CLASS).
639
640 =item on_TYPE_CLASS => $cb->($gdb, "TYPE_CLASS", $results)
641
642 Called for GDB C<exec>, C<status> and C<notify> event: TYPE is one
643 of these three strings, the class of the event (with C<-> replaced b
644 C<_>s) is appended to it to form the TYPE_CLASS (e.g. C<exec_stopped> or
645 C<notify_library_loaded>).
646
647 =back
648
649 =head1 SEE ALSO
650
651 L<AnyEvent>, L<http://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI>.
652
653 =head1 AUTHOR
654
655 Marc Lehmann <schmorp@schmorp.de>
656 http://home.schmorp.de/
657
658 =cut
659
660 1