=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