From 55b4ae0c57f1fcad6c8704c2c531512598f87210 Mon Sep 17 00:00:00 2001 From: Pragmatic Software Date: Fri, 28 Jan 2022 20:21:10 -0800 Subject: [PATCH] Rewrite guest-gdb to use GDB/MI --- applets/compiler_vm/guest/bin/guest-gdb | 1117 ++++++++++++----------- 1 file changed, 585 insertions(+), 532 deletions(-) diff --git a/applets/compiler_vm/guest/bin/guest-gdb b/applets/compiler_vm/guest/bin/guest-gdb index 9b76c714..38dfe45a 100755 --- a/applets/compiler_vm/guest/bin/guest-gdb +++ b/applets/compiler_vm/guest/bin/guest-gdb @@ -1,625 +1,678 @@ #!/usr/bin/perl -# SPDX-FileCopyrightText: 2021 Pragmatic Software +# File: guest-gdb +# +# Purpose: Wraps a GNU Debugger instance around a program. Watches for +# invocations of a gdb() function to handle gdb commands from the program. +# Reports information about local variables when signals are detected. +# +# Usage: guest-gdb [executable] +# +# If [executable] is omitted, it will default to `prog`. Don't forget to +# compile with -g for debugging symbols. + +# The DEBUG environment variable can be set to an integer value to enable +# internal debugging output. Set it to 1 for minimal debugging; to 2 to +# also dump the parsed GDB/MI data structures. + +# SPDX-FileCopyrightText: 2022 Pragmatic Software # SPDX-License-Identifier: MIT -# This script was thrown together quickly and sloppily. It will be -# rewritten "soon". +use 5.020; -no warnings; +use warnings; use strict; -my $cmdlineargs = ''; -foreach my $arg (@ARGV) { - $arg =~ s/'/'"'"'/g; - $cmdlineargs .= "'$arg' "; -} +use feature qw(signatures); +no warnings qw(experimental::signatures); use IPC::Open2; +use JSON::XS; +use Data::Dumper; +# set debug flag from DEBUG env or here my $debug = $ENV{DEBUG} // 0; -#my $opening = "<"; -#my $closing = ">\n"; +# output from gdb will be prefixed with GDB_PREFIX and suffixed with GDB_SUFFIX. +# e.g., to wrap gdb output with <>'s set GDB_PREFIX to "<" and GDB_SUFFIX to ">". +use constant { + GDB_PREFIX => "\n", + GDB_SUFFIX => "\n\n", +}; -my $opening = "\n"; -my $closing = "\n\n"; +# files to read stdin and write stdout +use constant { + INPUT_FILENAME => '.input', + OUTPUT_FILENAME => '.output', +}; -my $watching = 0; -my $got_output = 0; -my $local_vars = ""; -my $locals_start; -my $locals_end; -my $last_statement; -my ($main_start, $main_end); -sub flushall; -sub gdb; +# GDB/MI message types +use constant { + STATUS => '+', + EXEC => '*', + NOTIFY => '=', + CONSOLE => '~', + TARGET => '@', + LOG => '&', + RESULT => '^', +}; -my ($out, $in); - -sub getlocals { - print "getting locals\n" if $debug >= 5; - gdb $in, "print \"Go.\"\ninfo locals\nprint \"~Ok.~\"\n"; - - while(my $peep = <$out>) { - chomp $peep; - print "got peep: [$peep]\n" if $debug >= 5; - last if $peep =~ m/\(gdb\) \$\d+ = "Go."/; - - next if $peep =~ m/Missing separate debug/; - # fix this - $peep =~ s/^\d+: (.*?) =/$1 =/; - print "$opening$peep$closing"; - $got_output = 1; - } - - my $result = {}; - - while(my $line = <$out>) { - chomp $line; - print "got: [$line]\n" if $debug >= 5; - last if $line =~ m/\(gdb\) \$\d+ = "~Ok.~"/; - if($line =~ m/([^=]+)=\s+(.*)/) { - my $var = $1; - my $value = $2; - $var =~ s/^\(gdb\)\s+//; - $var =~ s/\s+$//; - $result->{$var} = $value; - print " got local: $var = $value\n" if $debug >= 4; - } - } - - return $result; +# send a command to gdb +sub gdb_send($in, $command) { + print STDERR "-> $command\n" if $debug; + print $in "$command\n"; } -sub execute { - my ($cmdline) = @_; - my ($ret, $result); +# read a line from gdb +sub gdb_read($out) { + my $line; - open2($out, $in, "$cmdline 2>&1"); - - while(my $line = <$out>) { - chomp $line; - print "--- got: [$line]\n" if $debug >= 1; - - my $ignore_response = 0; - - next if not length $line; - <$out> and next if $line =~ m/^\(gdb\) No line \d+ in/; - next if $line =~ m/No default breakpoint address/; - next if $line =~ m/^\(gdb\) No symbol table/; - next if $line =~ m/^\[Detaching after/; - next if $line =~ m/^\[New Thread/; - next if $line =~ m/^\(gdb\) Continuing/; - next if $line =~ m/^\(gdb\) \$\d+ = "~Ok\.~"/; - next if $line =~ m/^(\(gdb\) )*Breakpoint \d+ at 0x/; - next if $line =~ m/^\(gdb\) Breakpoint \d+ at 0x/; - next if $line =~ m/^\(gdb\) Note: breakpoint \d+ also set/; - next if $line =~ m/^(\(gdb\) )*Starting program/; - next if $line =~ m/PRETTY_FUNCTION__ =/; - next if $line =~ m/libc_start_main/; - next if $line =~ m/Thread debugging using libthread_db enabled/; - next if $line =~ m/Using host libthread_db library/; - next if $line =~ m/\s*Catchpoint \d+/; - next if $line =~ m/Missing separate debuginfo/; - next if $line =~ m/^Try: dnf/; - - if($line =~ m/^\d+: (.*? = .*)/) { - print "$opening$1$closing"; - $got_output = 1; - next; - } - - if($line =~ m/^Reading symbols from/) { - gdb $in, "break gdb\n"; - - gdb $in, "list main,9001\n"; - gdb $in, "\nprint \"~Ok.~\"\n"; - my ($bracket, $main_ended) = (0); - while(my $line = <$out>) { + while ($line = <$out>) { chomp $line; - print "list got: [$line]\n" if $debug >= 4; - my ($line_number) = $line =~ m/^(?:\(gdb\)\s+)?(\d+)/g; - while($line =~ m/(.)/g) { - my $char = $1; - if($char eq '{' and not $main_ended) { - if ($bracket == 0) { - $main_start = $line_number; - } - $bracket++; - } elsif($char eq '}') { - $bracket--; + print STDERR "<- [$line]\n" if $debug; + next if $line eq '(gdb) '; # ignore gdb prompt + last; + } - if($bracket == 0 and not $main_ended) { - $main_end = $line_number - 1; - $main_ended = 1; - last; - } - } + return undef if not defined $line; + return parse_gdbmi_output($line); +} + +# send a command to gdb and return all ~console and ^result output +sub gdb_send_and_read_console($context, $command, $report_error = 1) { + gdb_send($context->{gdb_input}, $command); + + my $gdb = $context->{gdb_output}; + my @console; + my $output; + + while ($output = gdb_read_console($gdb)) { + push @console, $output; + last if $output->{_type} eq RESULT; + } + + if ($report_error && $output->{_type} eq RESULT && $output->{_class} eq 'error') { + print_gdb_output($context, $output->{msg}); + } + + return \@console; +} + +# send a command to gdb and return only the ^result output +sub gdb_send_and_read_result($context, $command, $report_error = 1) { + gdb_send($context->{gdb_input}, $command); + + my $gdb = $context->{gdb_output}; + my $output; + + while ($output = gdb_read($gdb)) { + last if $output->{_type} eq RESULT; + } + + if ($report_error && $output->{_class} eq 'error') { + print_gdb_output($context, $output->{msg}); + } + + return $output; +} + +# alias to send_and_read_result +*gdb_send_and_discard = \&gdb_send_and_read_result; + +# read line from gdb, discarding types other than ~console or ^result +sub gdb_read_console($out) { + my $output; + + while ($output = gdb_read($out)) { + last if $output->{_type} eq RESULT; + last if $output->{_type} eq CONSOLE; + } + + return $output; +} + +# read and discard all output until ^result is reached +sub gdb_read_result($out) { + my $output; + + while ($output = gdb_read($out)) { + last if $output->{_type} eq RESULT; + } + + return $output; +} + +sub gdbmi_to_json($text, $makejson = 1) { + $text =~ s/([\w-]+)=/"$1":/g if $makejson; + return decode_json("{$text}"); +} + +sub parse_gdbmi_output($line) { + my ($type, $text) = $line =~ /^\d*(.)(.*)/; + + my $class = 'none'; + my $makejson = 0; + + if ($type =~ /[+*=]/) { + ($class, $text) = split /,/, $text, 2; + $makejson = 1 if length $text; + } elsif ($type eq RESULT) { + ($class, $text) = split /,/, $text, 2; + $text //= ''; + $makejson = 1 if length $text; + } else { + $text = "\"_text\":$text"; + } + + my $output = gdbmi_to_json($text, $makejson); + + if (exists $output->{_text}) { + chomp $output->{_text}; + } + + $output->{_type} = $type; + $output->{_class} = $class; + + print STDERR Dumper($output), "\n" if $debug >= 2; + + return $output; +} + +# get local variables at current frame +sub get_locals($context) { + # use `info locals` gdb command + my $console = gdb_send_and_read_console($context, "info locals"); + my @locals; + + foreach my $output (@$console) { + last if $output->{_type} eq RESULT; + + if ($output->{_text} =~ /([^=]+)\s+=\s+(.*)/) { + push @locals, [$1, $2]; } - - last if $line =~ m/^\(gdb\) \$\d+ = "~Ok.~"/; - } - - gdb $in, "break $main_start\n"; - gdb $in, "break $main_end\n"; - gdb $in, "set width 0\n"; - gdb $in, "set height 0\n"; -# gdb $in, "set auto-solib-add off\n"; - gdb $in, "catch exec\n"; - gdb $in, "run $cmdlineargs < .input\n"; - next; } - if($line =~ m/^Breakpoint \d+, main/) { - my $line = <$out>; - print "== got: $line\n" if $debug >= 5; - if ($line =~ m/^\d+\s+return.*?;\s*$/ or $line =~ m/^\d+\s+}\s*$/) { - if($got_output == 0) { - $locals_end = getlocals(); + return \@locals; +} - my $sep = ''; - foreach my $var (keys %$locals_end) { - print "checking local $var...\n" if $debug >= 4; - $locals_start->{$var} //= ''; - if ($locals_start->{$var} ne $locals_end->{$var}) { - $local_vars .= "$sep$var = $locals_end->{$var}"; - $sep = '; '; - } - } +# compare two lists of locals and returns list containing just the +# newly modified locals +sub compare_locals($old, $new) { + # build hashtable of left-side locals for easier access + my %ht; + + foreach my $local (@$old) { + my ($ident, $value) = @$local; + $ht{$ident} = $value; + } + + # check for modified locals and add to modified list + my @modified; + + foreach my $local (@$new) { + my ($ident, $value) = @$local; + $ht{$ident} //= ''; # set non-existing key to empty string + if ($ht{$ident} ne $value) { + push @modified, [$ident, $value]; } - } elsif ($line =~ m/^$main_start\s+/) { - $locals_start = getlocals(); - } - - gdb $in, "cont\n"; - next; } - if($line =~ m/Breakpoint \d+, gdb/) { - gdb $in, "up\n"; - $line = <$out>; - print "ignored $line\n" if $debug >= 2; - $line = <$out>; - print "ignored $line\n" if $debug >= 2; - next; + return \@modified; +} + +sub locals_to_string($locals) { + my @strings; + + foreach my $local (@$locals) { + my ($ident, $value) = @$local; + push @strings, "$ident = $value"; } - if($line =~ m/^Breakpoint \d+, _(.*?) at/) { - <$out>; - gdb $in, "cont\n"; - next; + return join '; ', @strings; +} + +sub args_to_string($args) { + my @strings; + + foreach my $arg (@$args) { + push @strings, "$arg->{name}=$arg->{value}"; } - if($line =~ m/^Breakpoint \d+, (.*?) at/) { - my $func = $1; - my $direction = "entered"; - my $return_value = ""; - my $nextline = <$out>; - chomp $nextline; + return join ', ', @strings; +} - print "got bt nextline: <$nextline>\n" if $debug >= 5; +# determine on which line numbers the main() function begins and ends +sub get_main_start_end($context) { + gdb_send_and_discard($context, 'set listsize unlimited'); - if($nextline =~ m/^\d+\s+}$/) { - $direction = "leaving"; + my ($start, $end); - gdb $in, "finish\n"; - while(my $retval = <$out>) { - chomp $retval; - print "got retval line: <$retval>\n" if $debug >= 5; - $retval =~ s/^\(gdb\)\s+//; + # use `info functions` to find where main starts + my $console = gdb_send_and_read_console($context, 'info functions -q ^main$'); - if($retval =~ m/^Run till exit/) { - <$out>; - <$out>; - next; - } - - if($retval =~ m/Value returned is \$\d+ = (.*)/) { - $return_value = ", returned $1"; - last; - } - - next if not length $retval; - next if $retval =~ m/^\$\d+ = 0/; - - print "$retval\n"; - $got_output = 1; - } - } - - flushall $in, $out; - - my $indent = 0; - gdb $in, "bt\n"; - while(my $bt = <$out>) { - chomp $bt; - print "got bt: <$bt>\n" if $debug >= 5; - $bt =~ s/^\(gdb\) //; - if($bt =~ m/^#(\d+) .* main .* at prog/) { - $indent = $1; - last; - } - } - - $indent++ if $direction eq "leaving"; - - print "$opening$direction [$indent]", ' ' x $indent, "$func$return_value$closing"; - gdb $in, "cont\n"; - next; + foreach my $output (@$console) { + last if $output->{_type} eq RESULT; + ($start) = $output->{_text} =~ /^(\d+)/; } - if ($line =~ m/^\d+\s+.*\bprint_last_statement\((.*)\)/) { - my $stmt = $1; + $console = gdb_send_and_read_console($context, 'list main'); - if ($stmt =~ m/^\s*(print|trace|watch|print|ptype|whatis|gdb)\b/) { - $line = "1 $stmt"; - } else { - $line = "1 gdb(\"print_last_statement $stmt\");"; - } - } + # gdb shows extra context surrounding main, so we have to parse the output + # and count the braces to find the true end of main() + my $braces = 0; + foreach my $output (@$console) { + last if $output->{_type} eq RESULT; - if ($line =~ m/^\d+\s+.*\btrace\((.*)\)/) { - $line = "1 gdb(\"break $1\");"; - } + # we have already found end; don't parse output + last if $end; - if ($line =~ m/^\d+\s+.*\bwatch\((.*)\)/) { - $line = "1 gdb(\"watch $1\");"; - } + my ($line, $code) = split /\t/, $output->{_text}; - if ($line =~ m/^\d+\s+.*\bdump\((.*)\)/) { - $line = "1 gdb(\"print $1\");"; - } + # this line isn't part of main() yet + next if $line < $start; - if ($line =~ m/^\d+\s+.*\bprint\((.*)\)/) { - $line = "1 gdb(\"print $1\");"; - } + # blank out contents of string and char literals + $code =~ s/(?:\"((?:\\\"|(?!\").)*)\")/'"' . ('-' x length $1) . '"'/ge; + $code =~ s/(?:\'((?:\\\'|(?!\').)*)\')/"'" . ('-' x length $1) . "'"/ge; - if ($line =~ m/^\d+\s+.*\bptype\((.*)\)/) { - $line = "1 gdb(\"ptype $1\");"; - } - - if ($line =~ m/^\d+\s+.*\bwhatis\((.*)\)/) { - $line = "1 gdb(\"whatis $1\");"; - } - - if($line =~ m/^\d+\s+.*\bgdb\("(.*)"\)/) { - my $command = $1; - my ($cmd, $args) = split / /, $command, 2; - $args = "" if not defined $args; - - print "got command [$command][$cmd][$args]\n" if $debug >= 10; - - flushall $in, $out; - - if ($cmd eq "print_last_statement") { - $command =~ s/;$//; - gdb $in, "print $args\nprint \"~Ok.~\"\n"; - - while ($line = <$out>) { - chomp $line; - print "got last output line: [$line]\n" if $debug >= 10; - $line =~ s/^\(gdb\)\s*//; - if ($line =~ m/^\$\d+ = "~Ok.~"/) { - last; - } elsif ($line =~ s/\$\d+ = (.*)$//) { - unless ($1 eq 'void' || $args eq $1) { - $last_statement = "$args = $1"; - print "got last statement [$last_statement]\n" if $debug; - } - if (length $line) { - print "$line\n"; - $got_output = 1; - } - } else { - if ($line =~ m/Program received signal/) { - print "GOT SIGNAL!\n" if $debug; - goto SIGNAL; - last; - } - - $line =~ s/\$\d+ = \d+$//; - print "$line\n"; - $got_output = 1; - } - } - gdb $in, "cont\n"; - next; - } - - if($cmd eq "break") { - $ignore_response = 1; - - gdb $in, "list $args,9001\n"; - gdb $in, "print \"~Ok.~\"\n"; - my $break = 0; - my $bracket = 0; - my $func_ended = 0; - while(my $line = <$out>) { - chomp $line; - print "list break got: [$line]\n" if $debug >= 4; - my ($line_number) = $line =~ m/^(\d+)/g; - while($line =~ m/(.)/g) { + while ($code =~ /(.)/g) { my $char = $1; - if($char eq '{') { - $bracket++; - } elsif($char eq '}') { - $bracket--; - if($bracket == 0 and not $func_ended) { - gdb $in, "break $line_number\n"; - print "func ended, breaking at $line_number\n" if $debug >= 5; - $func_ended = 1; - last; - } + if ($char eq '{') { + $braces++; + } elsif ($char eq '}') { + $braces--; + + if ($braces == 0) { + $end = $line; + last; + } } - } - - last if $line =~ m/^\(gdb\) \$\d+ = "~Ok.~"/; } - } + } - if($cmd eq "watch") { - gdb $in, "display $args\n"; - <$out>; - $watching++; - $ignore_response = 1; - } + return ($start, $end); +} - my $final_closing = ""; - gdb $in, "$command\nprint \"~Ok.~\"\n"; - while(my $next_line = <$out>) { - chomp $next_line; - print "nextline: $next_line\n" if $debug >= 1; +sub get_backtrace($context) { + my $console = gdb_send_and_read_console($context, "bt"); - print $final_closing and last if $next_line =~ m/\$\d+ = "~Ok.~"/; - $next_line =~ s/^\(gdb\)\s*\(gdb\)\s+\$\d+ = "~Ok.~"//; - $next_line =~ s/^\(gdb\)\s+\$\d+//; - $next_line =~ s/^\(gdb\)\s+type//; - $next_line =~ s/^\(gdb\)\s*//; + my @backtrace; - next if not length $next_line; + foreach my $output (@$console) { + last if $output->{_type} eq RESULT; + #0 0x0000555555555995 in bar () at prog3.c:18\n + $output->{_text} =~ /in (\w+) (.*) at/; + push @backtrace, { func => $1, args => $2 }; + } - if(not $ignore_response) { - if($next_line =~ m/=/) { # ptype - $got_output = 1; - print "$opening$args$next_line"; - $final_closing = $closing; - } else { - $got_output = 1; - $next_line =~ s/^\s+//; - print "\n$next_line"; - } + return \@backtrace; +} + +# returns the source line at a given line number +sub get_lineno($context, $lineno) { + my $console = gdb_send_and_read_console($context, "list $lineno,$lineno"); + + my $line; + + foreach my $output (@$console) { + last if $output->{_type} eq RESULT; + ($line) = $output->{_text} =~ /\t\s+(.*)/; + } + + return $line; +} + +sub handle_breakpoint_hit($context, $data) { + if ($data->{frame}->{func} eq 'main') { + if ($data->{frame}->{line} == $context->{main_end}) { + $context->{locals_end} = get_locals($context); } - } + } + elsif ($data->{frame}->{func} eq 'gdb') { + my $command = $data->{frame}->{args}->[0]->{value};; - gdb $in, "cont\n"; - next; + # strip gdb junk from command + $command =~ s/^.*?"//; + $command =~ s/"$//; + + dispatch_user_command($context, $command); } - if($line =~ m/^Watchpoint \d+: (.*)/) { - my $var = $1; + gdb_send_and_discard($context, "cont"); +} - my $ignore = <$out>; - print "ignored $ignore\n" if $debug >= 5; - my $old = <$out>; - my $new = <$out>; - $ignore = <$out>; - print "ignored $ignore\n" if $debug >= 5; - $ignore = <$out>; - print "ignored $ignore\n" if $debug >= 5; +# gdb commands invoked by end-users +sub dispatch_user_command($context, $command) { + state %commands = ( + 'ptype' => \&cmd_ptype, + 'whatis' => \&cmd_whatis, + 'print' => \&cmd_print, + 'dump' => \&cmd_print, - my ($val1) = $old =~ m/Old value = (.*)/; - my ($val2) = $new =~ m/New value = (.*)/; + # special PBot command + 'print_last_statement' => \&cmd_print, + ); - $got_output = 1; - print "$opening$var = $val2$closing"; - gdb $in, "cont\n"; - next; + $command = unescape($command); + + # move out of gdb() function to caller + gdb_send_and_discard($context, "up"); + + my ($cmd, $args) = split /\s+/, $command, 2; + + if (not exists $commands{$cmd}) { + cmd_gdb($context, $command); + } else { + $commands{$cmd}->($context, $args); + } +} + +sub cmd_gdb($context, $command) { + my $console = gdb_send_and_read_console($context, "$command"); + + my $text = ''; + + foreach my $output (@$console) { + if ($output->{_class} eq 'error') { + print_gdb_output($context, $output->{msg}); + last; + } + + last if $output->{_type} eq RESULT; + $text .= "$output->{_text}\n"; } - if($line =~ m/^Hardware watchpoint \d+: (.*)/) { - my $var = $1; + print_gdb_output($context, $text); +} - my $ignore = <$out>; - my $old = <$out>; - my $new = <$out>; - $ignore = <$out>; - $ignore = <$out>; +sub cmd_ptype($context, $args) { + my $console = gdb_send_and_read_console($context, "ptype $args"); - my ($val1) = $old =~ m/Old value = (.*)/; - my ($val2) = $new =~ m/New value = (.*)/; + my $text = ''; - $got_output = 1; - my $output = "$opening$var changed: $val1 => $val2$closing"; - flushall $in, $out; - print $output; - gdb $in, "cont\n"; - next; + foreach my $output (@$console) { + if ($output->{_class} eq 'error') { + print_gdb_output($context, $output->{msg}); + last; + } + + last if $output->{_type} eq RESULT; + + if ($output->{_text} =~ /type\s*=\s*(.*)/) { + $text .= "$args = $1" + } else { + $output->{_text} =~ s/^\s+//; + $text .= " $output->{_text}"; + } } - if($line =~ m/^Watchpoint \d+ deleted/) { - my $ignore = <$out>; - print "ignored $ignore\n" if $debug >= 5; - gdb $in, "cont\n"; - next; + print_gdb_output($context, $text); +} + +sub cmd_whatis($context, $args) { + my $console = gdb_send_and_read_console($context, "whatis $args"); + + foreach my $output (@$console) { + if ($output->{_class} eq 'error') { + print_gdb_output($context, $output->{msg}); + next; + } + + last if $output->{_type} eq RESULT; + + if ($output->{_text} =~ /type\s*=\s*(.*)/) { + print_gdb_output($context, "$args = $1"); + } + } +} + +sub cmd_print($context, $args) { + my $console = gdb_send_and_read_console($context, "print $args"); + + foreach my $output (@$console) { + if ($output->{_class} eq 'error') { + print_gdb_output($context, $output->{msg}); + next; + } + + last if $output->{_type} eq RESULT; + + if ($output->{_text} =~ /^\$\d+\s*=\s*(.*)/) { + print_gdb_output($context, "$args = $1"); + } + } +} + +sub handle_program_exit($context, $data) { + my $reason = $data->{reason}; + + if (not -s OUTPUT_FILENAME) { # -s gets size of file + my $locals = locals_to_string($context->{locals_end}); + + if (length $locals) { + print_gdb_output($context, "no output: $locals"); + } } - if($line =~ m/^Program exited/) { - if (not $got_output and (length $local_vars or defined $last_statement)) { - print $opening . "no output:"; - print " $last_statement" if defined $last_statement; - print ";" if defined $last_statement and length $local_vars; - print " $local_vars" if length $local_vars; - print $closing . "\n"; - } - exit 0; + _exit($context); +} + +sub handle_program_signal($context, $data) { + my $locals = locals_to_string(get_locals($context)); + + my $text = "Program received signal $data->{'signal-name'}, $data->{'signal-meaning'} "; + + if ($data->{frame}->{func} eq '??') { + $text .= "in ?? "; + } else { + $text .= "in $data->{frame}->{func} "; } - if($line =~ s/\[Inferior .* exited with code (\d+)\]//) { - print "$line\n" if length $line; - print $opening . "Exit " . (oct $1) . $closing; - if (not $got_output and (length $local_vars or defined $last_statement)) { - print $opening . "no output:"; - print " $last_statement" if defined $last_statement; - print ";" if defined $last_statement and length $local_vars; - print " $local_vars" if length $local_vars; - print $closing . "\n"; - } - exit 0; + my $args = args_to_string($data->{frame}->{args}); + + $text .= "($args) "; + + my $line; + + if (exists $data->{frame}->{line}) { + $line = get_lineno($context, $data->{frame}->{line}); + $text .= "at statement: $line "; } - if($line =~ s/\[Inferior .* exited normally\]//) { - print "$line\n" if length $line; - $got_output = 1 if length $line; - if (not $got_output and (length $local_vars or defined $last_statement)) { - print $opening . "no output:"; - print " $last_statement" if defined $last_statement; - print ";" if defined $last_statement and length $local_vars; - print " $local_vars" if length $local_vars; - print $closing . "\n"; - } - exit 0; - } + my $backtrace = get_backtrace($context); - if($line =~ m/Program terminated with signal SIGKILL/) { - print "[Killed]\n"; - return 0; - } + shift @$backtrace; # remove current frame - if($line =~ m/Program received signal SIGTRAP/) { - my $output = ""; - my $line = <$out>; - print "ignored $line\n" if $debug >= 5; - $line = <$out>; - print "ignored $line\n" if $debug >= 5; - for(my $i = 0; $i < $watching; $i++) { - $line = <$out>; - chomp $line; - $line =~ s/^\d+:\s//; - $got_output = 1; - $output .= "$opening$line$closing"; - } - flushall $in, $out; - print $output; - gdb $in, "cont\n"; - next; - } + foreach my $trace (@$backtrace) { + my $console = gdb_send_and_read_console($context, "up"); - SIGNAL: - #print "SIGNAL - testing line [$line]\n" if $debug; - if($line =~ m/Program received signal/) { - my $result = ""; - my $vars = ""; - my $varsep = ""; + foreach my $output (@$console) { + last if $output->{_type} eq RESULT; - $line =~ s/\.$//; - $got_output = 1; - print "$line "; - - while(my $line = <$out>) { - chomp $line; - $line =~ s/^\(gdb\)\s+//; - $line =~ s/main \(.*?\)/main ()/g; - - print "signal got: [$line]\n" if $debug >= 5; - - next if $line =~ m/__PRETTY_FUNCTION__ =/; - gdb $in, "up\n" and next if $line =~ m{^\#\d+\s+}; - <$out> and gdb $in, "up\n" and next if $line =~ m/^\#\d+\s+gdb \(\)/; - - if($line =~ s/^(#\d+\s+)?0x[0-9A-Fa-f]+\s// || $line =~ m/\w+ \(\) (at|in) /) { - $line =~ s/\s+at .*:\d+//; - $line =~ s/\s+from \/lib.*//; - - gdb $in, "up\n" and next if $line =~ m{in \?\?}; - gdb $in, "up\n" and next if $line =~ m{/usr/lib/}; - gdb $in, "up\n" and next if $line =~ m{^_}; - - if($line =~ s/^\s*in\s+//) { - if(not length $result) { - $result .= "in $line "; - } else { - $result .= "called by $line "; + if ($output->{_text} =~ /^\d+\t\s+(.*)/) { + $line = $1; } - gdb $in, "info locals\n"; - } else { - $result = "in $line from "; - gdb $in, "info locals\n"; - } } - elsif($line =~ m/^No symbol table info available/ || $line =~ m/^No locals/) { - gdb $in, "up\n"; - } - elsif($line =~ s/^\d+\s+//) { - next if $line =~ /No such file/; - $line = $1 if $line =~ m/print_last_statement\((.*)\)/; - - $result .= "at statement: $line "; - gdb $in, "up\n"; - } - elsif($line =~ m/([^=]+)=\s+(.*)/) { - unless ($2 =~ m/~Ok\.~/) { - $vars .= "$varsep$1= $2"; - $varsep = "; "; - } - } - elsif($line =~ m/^Initial frame selected; you cannot go up/) { - last; - } - } - - $result =~ s/^\s+//; - $result =~ s/\s+$//; - $result =~ s/in main \(\) //; - - $vars = " " if length $vars; - - print "$result$vars\n"; - exit 0; + $text .= "called by $trace->{func} $trace->{args} at statement: $line "; } - if($line =~ s/^\(gdb\)\s*//) { - $got_output = 1; - print "$opening$line$closing"; - next; + if (length $locals) { + $text .= "" } - next if $line =~ m/^\d+\s+void gdb\(\) \{\}/; - - next if not length $line; - - $got_output = 1; - print "$line\n"; - } + print_gdb_output($context, $text); + _exit($context); } -sub gdb { - my ($in, $command) = @_; +sub unescape($text) { + state %unescape = ( + "\\n" => "\n", + "\\t" => "\t", + "\\\\" => "\\", + "\\\"" => '"', + ); - chomp $command; - print "+++ gdb command [$command]\n" if $debug >= 2; - print $in "$command\n"; + $text =~ s/(\\n|\\t|\\\\|\\")/$unescape{$1}/g; + return $text; } -sub flushall { - my ($in, $out) = @_; +# dispatch output from gdb commands to handlers +sub dispatch_gdbmi_output($context, $output) { + state %dispatch = ( + STATUS , \&handle_status_async_output, + EXEC , \&handle_exec_async_output, + NOTIFY , \&handle_notify_async_output, + CONSOLE , \&handle_console_stream_output, + TARGET , \&handle_target_stream_output, + LOG , \&handle_log_stream_output, + RESULT , \&handle_result_output, + ); - gdb $in, "call (int(*)(FILE *)) fflush(0)\nprint \"~Ok.~\"\n"; - while(my $line = <$out>) { - chomp $line; - $line =~ s/^\(gdb\)\s*//; - $line =~ s/\$\d+ = \Q(int (*)(FILE *)) 0x0\E$//; - last if $line =~ m/\$\d+ = "~Ok.~"/; - next unless length $line; - $got_output = 1; - print "$line\n"; - } + print STDERR "dispatch: ", Dumper($output), "\n" if $debug >= 3; + + $dispatch{$output->{_type}}->($context, $output); } -$SIG{ALRM} = sub { print "\n"; exit 1; }; -alarm 8; +# (+) status-async-output contains on-going status information about the progress +# of a slow operation. It can be discarded. +sub handle_status_async_output($context, $output) { +} -execute("LIBC_FATAL_STDERR=1 MALLOC_CHECK_=1 gdb -silent -q -nx -iex 'set auto-load safe-path /' ./prog"); +# (*) exec-async-output contains asynchronous state change on the target (stopped, +# started, disappeared). +sub handle_exec_async_output($context, $output) { + if ($output->{_class} eq 'stopped') { + my $reason = $output->{reason}; + + if ($reason eq 'breakpoint-hit') { + handle_breakpoint_hit($context, $output); + } + elsif ($reason eq 'exited-normally') { + handle_program_exit($context, $output); + } + elsif ($reason eq 'signal-received') { + handle_program_signal($context, $output); + } + } +} + +# (=) notify-async-output contains supplementary information that the client should +# handle (e.g., a new breakpoint information). +sub handle_notify_async_output($context, $output) { +} + +# (~) console-stream-output is output that should be displayed as is in the console. +# It is the textual response to a CLI command. +sub handle_console_stream_output($context, $output) { + if ($output->{_text} =~ /^Reading symbols/) { + perform_preamble($context); + run_program($context); + } +} + +# (@) target-stream-output is the output produced by the target program. +sub handle_target_stream_output($context, $output) { +} + +# (&) log-stream-output is output text coming from GDB’s internals, for instance +# messages that should be displayed as part of an error log. +sub handle_log_stream_output($context, $output) { +} + +# (^) result-output "done" | "running" | "connected" | "error" | "exit" +sub handle_result_output($context, $output) { +} + +sub start_timeout($context, $timeout) { + $SIG{ALRM} = sub { + print_prog_output($context, "[gdb time-out]\n"); + _exit($context); + }; + alarm $timeout; +} + +sub _exit($context) { + close $context->{prog_output}; + + open my $fh, '<', OUTPUT_FILENAME or die "could not open ".OUTPUT_FILENAME." for read: $!\n"; + my $output = do { local $/; <$fh> }; + close $fh; + + print STDOUT "$output\n"; + + exit; +} + +# send text to OUTPUT_FILENAME file +sub print_prog_output($context, $text) { + print { $context->{prog_output} } $text; + $context->{prog_output}->flush(); +} + +# send gdb output to OUTPUT_FILENAME file, wrapped with prefix and suffix +sub print_gdb_output($context, $text) { + print { $context->{prog_output} } GDB_PREFIX . $text . GDB_SUFFIX; + $context->{prog_output}->flush(); +} + +sub perform_preamble($context) { + # get start and end line numbers for main() function + my ($start, $end) = get_main_start_end($context); + + $context->{main_start} = $start; + $context->{main_end} = $end; + + # break on main start and end so we can get locals + gdb_send_and_discard($context, "break $start"); + gdb_send_and_discard($context, "break $end"); + + # break on gdb() function so we can pass along user-submitted gdb commands + gdb_send_and_discard($context, "break gdb"); + gdb_send_and_discard($context, "set print null-stop on"); +} + +sub shellquote_args_to_string(@args) { + my $string = ''; + + foreach my $arg (@args) { + $arg =~ s/'/'"'"'/g; + $string .= "'$arg' "; + } + + return $string; +} + +sub run_program($context) { + my $cmdline_args = shellquote_args_to_string(@ARGV); + gdb_send($context->{gdb_input}, "run $cmdline_args < ".INPUT_FILENAME." >> ".OUTPUT_FILENAME); +} + +sub main { + # first command-line argument can override file to debug + my $prog = $ARGV[0] // 'prog'; + + # start gdb and grab references to its input and output streams + open2(my $out, my $in, "LIBC_FATAL_STDERR=1 MALLOC_CHECK_=1 gdb -i mi3 -q -nx ./$prog"); + + my $context = { + gdb_output => $out, # gdb output stream + gdb_input => $in, # gdb input stream + }; + + # open OUTPUT_FILENAME file to send gdb output + unlink OUTPUT_FILENAME; + open($context->{prog_output}, '>>', OUTPUT_FILENAME) or die "Could not open ".OUTPUT_FILENAME." for append: $!"; + + # time-out after a few seconds + start_timeout($context, 8); + + # handle gdb output + while (my $output = gdb_read($out)) { + dispatch_gdbmi_output($context, $output); + } +} + +main();