Devel::GDB - Open and communicate a gdb session

    use Devel::GDB;

    $gdb = new Devel::GDB();
    print $gdb->send_cmd('-environment-path');
    print $gdb->get('info functions');

    use Devel::GDB ;

    $Devel::GDB::DEPRECATED = 1;
    $gdb = new Devel::GDB();
    print $gdb->get('info functions', $timeout, $prompt, $notyet, $alldone);

    $gdb = new Devel::GDB( '-use-threads' => 1 );
                           '-params'      => $extra_gdb_params );

    use Devel::GDB;
    use IO::BufferedSelect;

    my $gdb = new Devel::GDB( '-use-threads' => 0, 
                              '-readline-fn' => \&message_loop );

    my $gdb_fh = $gdb->get_reader;

    my $bs = new IO::BufferedSelect(\*STDIN, $gdb_fh);

    sub message_loop
    {
        my @result = $bs->read_line($gdb_fh);
        return @result ? $result[0][1] : undef;
    }

    OUTER:
    while(1)
    {
        my @ready = $bs->read_line();
        foreach( @ready )
        {
            my ($fh, $line) = @$_;
            defined($line) or last OUTER;
            chomp $line;

            if($fh == \*STDIN)
            {
                print STDERR "RECEIVED: $line\n";
                my $result = $gdb->get($line);
                last unless defined($result);
                print STDERR $result;
            }
            else
            {
                $gdb->demux($line);
            }
        }
    }

    use strict;
    use warnings;
    use threads;
    use Devel::GDB;

    my $gdb = new Devel::GDB( '-create-expect' => 1 );
    my $e = $gdb->get_expect_obj;

    $gdb->send_cmd("file tr");
    $gdb->send_cmd("set args a-zA-Z A-Za-z");
    $gdb->send_cmd("-exec-run");

    $e->send("one TWO\n");
    $e->send("ONE two\n");

    $e->expect(undef, '-re', '^.+$')
        and $e->match =~ /^ONE two/
        and print "ok 1\n"
        or die;

    $e->expect(undef, '-re', '^.+$')
        and $e->match =~ /^one TWO/
        and print "ok 2\n"
        or die;

    $gdb->end;

    $e->slave->close;
    $e->expect(undef);
    printf "EXPECT(EOF): %s\n", $e->before;

    use strict;
    use warnings;
    use threads;
    use Devel::GDB;
    use IO::Pty;
    use POSIX;

    sub set_termios_lflag($$$)
    {
        my($fd, $flag, $value) = @_;
        my $termios = new POSIX::Termios;
        $termios->getattr($fd);
        $termios->setlflag($value ? ($termios->getlflag | $flag) : ($termios->getlflag & ~$flag));
        $termios->setattr($fd);
        undef $termios;
    }

    my $pty = new IO::Pty;

    # Disable echo temporarily
    set_termios_lflag(fileno($pty), &POSIX::ECHO, 0);

    # Fork an xterm
    unless(my $xterm_pid = fork)
    {
        die "Fork failed" unless defined($xterm_pid);

        # Reopen $fd with close-on-exec disabled
        my $fd  = fileno($pty);
        $^F = $fd > $^F ? $fd : $^F;
        local *MASTER;
        open(MASTER, "<&=$fd") and $fd == fileno(\*MASTER)
            or die "Failed reopening pty handle";

        my $cmd = "xterm -Sxx$fd";

        print "calling exec($cmd)\n";
        exec($cmd);
        die "exec() failed: $!";
    }

    # xterm likes to write its window id to the pty; eat it up
    # (echo is disabled so the inferior process doesn't see this output)
    my $window_id = readline($pty->slave);

    # Now turn echo back on
    set_termios_lflag(fileno($pty), &POSIX::ECHO, 1);

    # No longer need the master (but don't close the slave!)
    close $pty;

    # Create the GDB object, telling the inferior process to use the new xterm's pty
    my $gdb = new Devel::GDB( '-use-tty' => $pty->ttyname );

    while(<STDIN>)
    {
        chomp;

        if(/^Z/)
        {
            $gdb->interrupt;
            next;
        }

        my $result = $gdb->send_cmd($_);
        last unless defined($result);
        print STDERR "[GDB] $result\n";
    }

    $gdb->end;

package Devel::GDB;

use 5.006;
use strict;
use warnings;

use Devel::GDB::LowLevel;
use threads::shared;
use Thread::Semaphore;

use B qw( cstring );

our $VERSION = '2.02';
our $DEBUG;
our $DEPRECATED;

sub new
{
    my $class  = shift;

    # Break up @_ into our params and those passed to $level0
    my (@params, @level0_params);
    %_ = @_;
    while(my @p = each(%_))
    {
        $p[0] =~ /^-(use-threads|readline-fn)$/ and push @params, @p
            or push @level0_params, @p
    }

    my $self = bless
    {
        next_token     => 0,
        response       => {},
        sinks          => {},
        LOCK_shared    => 0,
        LOCK_excl      => new Thread::Semaphore,
        DEAD           => 0,                            # Set to 1 when _the_gdb_thread exits
        '-use-threads' => $threads::VERSION,            # Use threads if they're enabled (user can override)
        '-readline-fn' => \&_readline, 
        @params
    };

    if($DEPRECATED)
    {
        $self->{'-readline-fn'} = undef;

        die "Threads cannot be enabled when \$Devel::GDB::DEPRECATED is set!"
            if $self->{'-use-threads'};
    }

    share($self->{'next_token'});
    share($self->{'response'});
    share($self->{'sinks'});
    share($self->{'LOCK_shared'});
    share($self->{'DEAD'});

    $self->{level0} = new Devel::GDB::LowLevel( @level0_params );

    if($self->{'-use-threads'})
    {
        # Don't dynamically load "threads" here: things get messy because
        # threads::shared is already loaded
        die "Please 'use threads' before instantiating Devel::GDB with -use-threads => 1!"
            unless($threads::VERSION);

        $self->{trT} = threads->create( \&_the_gdb_thread, $self )
            or die "can't create thread: $@\n";
    }

    return $self;
}

sub send_cmd
{
    my $self = shift;
    my ($cmd) = @_;

    $self->_lock_shared();
    my ($result, $token) = $self->_send_cmd($cmd);
    $self->_unlock_shared();

    return wantarray ? ($result, $token) : $result;
}

sub send_cmd_excl
{
    my $self = shift;
    my ($cmd, $before_fn, $after_fn) = @_;

    $self->_lock_exclusive();
    $before_fn->() if $before_fn;

    my ($result, $token) = $self->_send_cmd($cmd);

    $after_fn->() if $after_fn;
    $self->_unlock_exclusive();

    return wantarray ? ($result, $token) : $result;
}

sub send_cmd_async
{
    my $self = shift;
    my ($cmd, $callback) = @_;

    die "send_cmd_async() cannot be used in threaded mode"
        if $self->{'-use-threads'};

    $self->_send_cmd($cmd, 1, $callback);
}

sub get
{
    my $self = shift;

    if($DEPRECATED or @_ > 1)
    {
        return $self->_get_deprecated(@_);
    }

    my ($cmd) = @_;

    my $buffer = &share([]);
    my $before_fn = $self->_generate_redirector('console', $buffer);
    my $after_fn  = $self->_generate_undirector('console');

    my $result = $self->send_cmd_excl($cmd, $before_fn, $after_fn);

    # Return undef if send_cmd_excl returned undef (EOF)
    return undef unless defined($result);

    # Return the buffer, if the command succeeded
    if($result =~ /^done/)
    {
        return join('', @$buffer);
    }

    # Check if GDB gave us an error
    if($result =~ /^error,(.*)/)
    {
        return wantarray ? (undef, $1) : undef;
    }

    # Otherwise, something strange happened
    return wantarray ? (undef, "Unexpected result: $result") : undef;
}

sub get_expect_obj
{
    my $self = shift;
    return $self->{level0}->get_expect_obj;
}

sub get_reader
{
    my $self = shift;
    return $self->{level0}->get_reader;
}

sub demux
{
    my $self = shift;

    die "Cannot call demux() in threaded mode!"
        if $self->{'-use-threads'};

    return $self->_demux(@_);
}

sub interrupt
{
    my $self = shift;
    $self->{level0}->interrupt;
}

sub end
{
    my $self = shift;

    # Don't talk to level0 if it's already dead
    unless($self->{'DEAD'})
    {
        $self->{level0}->interrupt;
        $self->{level0}->send("-gdb-exit");
    }

    $self->{trT}->join
        if $self->{trT};
}

sub _generate_redirector
{
    my $self = shift;
    my ($stream, $buffer) = @_;

    return sub
    {
        lock $self->{sinks};

        die "Something wrong here: cannot have multiple redirectors for the same stream!"
            if defined($self->{sinks}->{$stream});

        $self->{sinks}->{$stream} = $buffer;
    };
}

sub _generate_undirector
{
    my $self = shift;
    my ($stream) = @_;

    return sub
    {
        lock $self->{sinks};

        die "Something wrong here: trying to undirect $stream when no redirection is in place!"
            unless defined($self->{sinks}->{$stream});

        delete $self->{sinks}->{$stream};
    };
}

# Acquire a shared lock.  Blocks if the exclusive lock is held,
# until the exclusive lock is released.
sub _lock_shared
{
    my $self = shift;

    lock $self->{'LOCK_shared'};

    # Acquire the exclusive lock if we're the first shared lock holder
    if(!$self->{'LOCK_shared'})
    {
        # Note: if _lock_exclusive blocks, then nobody can acquire the lock on
        # LOCK_shared.  This won't result in any deadlocks, since the only 
        # possible LOCK_shared waiters are other _lock_shared() callers, and
        # NOT _unlock_shared() (since the lock count is zero!)
        $self->_lock_exclusive();
    }

    $self->{'LOCK_shared'}++;
    printf STDERR "+++ Shared lock count is now $self->{LOCK_shared}\n"
        if $DEBUG;
}

sub _unlock_shared
{
    my $self = shift;

    lock $self->{'LOCK_shared'};
    $self->{'LOCK_shared'}--;

    # Release the exclusive lock if we're the last shared lock holder
    if(!$self->{'LOCK_shared'})
    {
        $self->_unlock_exclusive();
    }

    printf STDERR "--- Shared lock count is now $self->{LOCK_shared}\n"
        if $DEBUG;
}

# Acquire an exclusive lock.  Blocks if any shared or exclusive locks are
# held, until they are all released.
sub _lock_exclusive
{
    my $self = shift;

    # Acquire the exclusive lock.  This will block until
    # (a) the shared-lock count goes to zero, and
    # (b) nobody else is holding an exclusive lock.
    $self->{'LOCK_excl'}->down;

    printf STDERR "+++ EXCLUSIVE LOCK AQUIRED\n"
        if $DEBUG;
}

# Release an exclusive lock.
sub _unlock_exclusive
{
    my $self = shift;
    $self->{'LOCK_excl'}->up;

    printf STDERR "--- EXCLUSIVE LOCK RELEASED\n"
        if $DEBUG;
}

sub _send_cmd
{
    my $self = shift;
    my ($cmd, $is_async, $callback) = @_;

    die "Not yet implemented"
        if $is_async;

    # Make sure there's no token there
    $cmd =~ s/^[0-9]+//;

    # Make sure it's a GBM/MI command; otherwise, turn it into one
    if($cmd !~ /^-/)
    {
        $cmd = '-interpreter-exec console "' . _escape($cmd) . '"';
    }

    # Generate a token
    my $token = $self->_generate_token();

    # Send the command, and wait for a response
    $self->{level0}->send($token . $cmd);

    # Wait until we get a response
    my $response = $self->_wait($token);

    return ($response, $token);
}

sub _escape
{
    my ($string) = @_;
    my $qstring = cstring($string);

    # Remove the quotes around it
    $qstring =~ s/^"(.*)"$/$1/;

    return $qstring;
}

my %unesc = (  "\\" => "\\",
               "\"" => "\"",
               "a"  => "\a",
               "b"  => "\b",
               "t"  => "\t",
               "n"  => "\n",
               "f"  => "\f",
               "r"  => "\r",
               "e"  => "\e",
               "v"  => "\013",
            );

sub _unescape
{
   # Looks like we have to do this one ourselves
   my ($string) = @_;

   # Unescape any \X for various characters X (including \\ and \")
   $string =~ s/\\([\\\"abtnfrev])/$unesc{$1} || "\\$1"/esg;

   # Unescape \OCTAL for various octal values
   $string =~ s/\\(0[0-7]+)/chr(oct($1))/esg;

   return $string;
}

sub _generate_token
{
    my $self = shift;

    lock $self->{next_token};
    lock $self->{response};

    # Create the actual token
    my $token = $self->{next_token}++;

    # Create a shared variable for one response received on this token (used by demux)
    # (subsequent responses will be treated as "late responses")
    $self->{response}->{$token} = &share(\my $tmp);

    # Return the token and the buffer
    return $token;
}

sub _wait
{
    my $self = shift;
    my ($token) = @_;

    # Wait until the buffer is non-empty
    my $response = $self->{response}->{$token};
    lock($response);
    until(defined $$response)
    {
        last if($self->{'DEAD'});

        if($self->{'-use-threads'})
        {
            cond_wait($response);
        }
        else
        {
            last unless $self->_message_loop();
        }
    }

    # Keep the response, then delete the entry in $self->{response}
    delete $self->{response}->{$token};
    return $$response;
}

sub _the_gdb_thread
{
    my $self = shift;

    # Close the duplicated filehandle: we don't need it in this thread
    close $self->{level0}->{TTY}
        if $self->{level0}->{TTY};

    while($self->_message_loop()) { }

    # Set the DEAD flag
    $self->{'DEAD'} = 1;

    # Wake up any threads stuck in _wait().
    #
    # Note: _wait() tests the DEAD flag AFTER locking $self->{response}->{$token},
    # so there's no race condition here: we won't get the $response lock until
    # after it's released by cond_wait().
    {
        lock $self->{response};
        foreach my $token (keys %{$self->{response}})
        {
            my $response = $self->{response}->{$token};
            if(defined $response)
            {
                lock $response;
                cond_signal($response);
            }
        }
    }
}

sub _readline
{
    my $self = shift;
    local $/ = "\n";
    return readline($self->get_reader);
}

sub _message_loop
{
    my $self = shift;

    die "The new API is not available when \$Devel::GDB::DEPRECATED is set!"
        if $DEPRECATED;

    my $line = $self->{'-readline-fn'}->($self);
    if(defined $line)
    {
        chomp $line;
        $self->_demux($line);
        return 1;
    }

    return 0;
}

sub _demux
{
    my $self = shift;
    my ($line) = @_;

    printf STDERR "<<< %s\n", $line
        if $DEBUG;

    if($line eq '(gdb) ')
    {
        # Ignore it
    }
    elsif($line =~ /^~"(.*)"$/)
    {
        $self->_record_stream('console', _unescape($1));
    }
    elsif($line =~ /^@"(.*)"$/)
    {
        $self->_record_stream('target', _unescape($1));
    }
    elsif($line =~ /^&"(.*)"$/)
    {
        $self->_record_stream('log', _unescape($1));
    }
    elsif($line =~ /^([0-9]+)\^(.*)$/)
    {
        $self->_record_result($2, $1);
    }
    elsif($line =~ /^([0-9]+)\*(.*)$/)
    {
        $self->_record_async_exec($2, $1);
    }
    elsif($line =~ /^([0-9]+)\+(.*)$/)
    {
        $self->_record_async_status($2, $1);
    }
    elsif($line =~ /^([0-9]+)=*(.*)$/)
    {
        $self->_record_async_notify($2, $1);
    }
}

sub _record_stream($$$)
{
    my $self = shift;
    my ($stream, $input) = @_;

    # Split line if it's multiple lines
    foreach my $line (split "\n", $input)
    {
        # Add (back) newline terminator
        $line = "$line\n";

        # Use redirection if it's set up
        lock $self->{sinks};
        if(defined $self->{sinks}->{$stream})
        {
            push @{$self->{sinks}->{$stream}}, $line;
            next;
        }

        # Hack: GDB prints "Quit" to the log stream if we sent it SIGINT
        # when the inferior process is not running.  Swallow this spurious
        # output.
        next if $line eq "Quit\n";

        # Otherwise, dump it to STDERR for now
        local $\ = "";
        print STDERR $line;
    }
}

sub _record_result($$$)
{
    my $self = shift;
    my ($line, $token) = @_;

    my $response = $self->{response}->{$token};
    lock $response if defined($response);

    # Process the first response, and only the first response
    #
    # Note: we avoid a race condition with _wait() by checking
    # defined($self->{response}->{$token}) rather than defined($response)
    if(defined $self->{response}->{$token} and !defined($$response))
    {
        $$response = $line;
        cond_signal($response);
    }

    # All others are handled as "late responses"
    else
    {
        return $self->_record_stream('late_response', "($token) $line");
    }
}

sub _record_async_exec($$$)
{
    my $self = shift;
    my ($line, $token) = @_;

    local $, = ": ";
    local $\ = "\n";
    print STDERR "exec-async-output", $token, $line;
}

sub _record_async_status($$$)
{
    my $self = shift;
    my ($line, $token) = @_;

    local $, = ": ";
    local $\ = "\n";
    print STDERR "status-async-output", $token, $line;
}

sub _record_async_notify($$$)
{
    my $self = shift;
    my ($line, $token) = @_;

    local $, = ": ";
    local $\ = "\n";
    print STDERR "notify-async-output", $token, $line;
}

sub _pipe_read {
    my ($out, $to, $pr, $cb) = @_ ;
    $out = $out->{OUT} unless ref($out) =~ /GLOB|FileHandle/ ;
    $to ||= undef ;
    my $rmask = '' ;
    vec ($rmask, fileno( $out ), 1) = 1 ;
    my ($buf, $buffer, $err) ;
    while (not $err) {
        my $nread;
        if ( $cb ) {
            # this call back should be called every second. if it
            # returns true, abandon. Not mswin supported
            for( ; !defined($to) or 0 < $to; --$to if defined($to)) {
                my $r = $rmask ;
                ($nread) = select ($r, undef, undef, 1 ) ;
                last if $nread ;
                last if $cb -> ($to) and $err = 'STOPPED' ;
            }
        }
        else {
            my $r = $rmask ;
            ($nread) = select $r, undef, undef, $to ;
        }
        last if ! $nread and $err = 'TIMEOUT' ;
        $buffer ||= '' ;
        sysread $out, $buf, 10_000 ;
        last if ! $buf and $err = 'EOF' ;
        $buffer .= $buf ;
        last if ! $pr or $buffer =~ /$pr/s ;
    }

    return ($buffer, $err || '');
}

sub _get_deprecated
{
    # returns (buffer, error, prompt) in array context
    # return buffer in scalar context (undef if error)
    my $self = shift or die 'whoami';
    my ($cmd, $timeout, undef, $wait_callback, $done_callback) = @_ ;

    die "This syntax is deprecated.  Please update your code, or set \$Devel::GDB::DEPRECATED = 1"
        unless $DEPRECATED;

    die "Deprecated get() is not compatible with threads"
        if $self->{'-use-threads'};

    # Make sure it's a GBM/MI command; otherwise, turn it into one
    if($cmd !~ /^-/)
    {
        $cmd = '-interpreter-exec console "' . _escape($cmd) . '"';
    }

    $self->{'level0'}->send($cmd);

    my ($buffer, $err) = _pipe_read( $self->get_reader, $timeout, qr/(^|\n)\^/, $wait_callback ) ;
    $done_callback and $done_callback->();

    if($err)
    {
        return wantarray ? ($buffer, $err) : undef;
    }

    # Filter out the console output stream (discard everything else)
    my @lines = grep { /^~"(.*)"$/ } (split /\n/, $buffer);

    # Unescape the contents of the stream
    s/^~"(.*)"$/_unescape($1)/xe
        foreach(@lines);

    # Return the result
    $buffer = join('', @lines);

    return wantarray ? ($buffer, $err) : $buffer;
}

1;

__END__