3
0
mirror of https://github.com/pragma-/pbot.git synced 2024-12-24 11:42:35 +01:00
pbot/modules/compiler_vm/compiler_watchdog.pl
2021-07-10 15:00:22 -07:00

623 lines
16 KiB
Perl
Executable File

#!/usr/bin/perl
# SPDX-FileCopyrightText: 2021 Pragmatic Software <pragma78@gmail.com>
# SPDX-License-Identifier: MIT
no warnings;
use strict;
use IPC::Open2;
my $debug = $ENV{DEBUG} // 0;
#my $opening = "<";
#my $closing = ">\n";
my $opening = "\n";
my $closing = "\n\n";
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;
my $cmdlineargs = '';
foreach my $arg (@ARGV) {
$arg =~ s/'/'"'"'/g;
$cmdlineargs .= "'$arg' ";
}
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;
}
sub execute {
my ($cmdline) = @_;
my ($ret, $result);
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>) {
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--;
if($bracket == 0 and not $main_ended) {
$main_end = $line_number - 1;
$main_ended = 1;
last;
}
}
}
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();
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 = '; ';
}
}
}
} 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;
}
if($line =~ m/^Breakpoint \d+, _(.*?) at/) {
<$out>;
gdb $in, "cont\n";
next;
}
if($line =~ m/^Breakpoint \d+, (.*?) at/) {
my $func = $1;
my $direction = "entered";
my $return_value = "";
my $nextline = <$out>;
chomp $nextline;
print "got bt nextline: <$nextline>\n" if $debug >= 5;
if($nextline =~ m/^\d+\s+}$/) {
$direction = "leaving";
gdb $in, "finish\n";
while(my $retval = <$out>) {
chomp $retval;
print "got retval line: <$retval>\n" if $debug >= 5;
$retval =~ s/^\(gdb\)\s+//;
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;
}
if ($line =~ m/^\d+\s+.*\bprint_last_statement\((.*)\)/) {
my $stmt = $1;
if ($stmt =~ m/^\s*(print|trace|watch|print|ptype|whatis|gdb)\b/) {
$line = "1 $stmt";
} else {
$line = "1 gdb(\"print_last_statement $stmt\");";
}
}
if ($line =~ m/^\d+\s+.*\btrace\((.*)\)/) {
$line = "1 gdb(\"break $1\");";
}
if ($line =~ m/^\d+\s+.*\bwatch\((.*)\)/) {
$line = "1 gdb(\"watch $1\");";
}
if ($line =~ m/^\d+\s+.*\bdump\((.*)\)/) {
$line = "1 gdb(\"print $1\");";
}
if ($line =~ m/^\d+\s+.*\bprint\((.*)\)/) {
$line = "1 gdb(\"print $1\");";
}
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) {
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;
}
}
}
last if $line =~ m/^\(gdb\) \$\d+ = "~Ok.~"/;
}
}
if($cmd eq "watch") {
gdb $in, "display $args\n";
<$out>;
$watching++;
$ignore_response = 1;
}
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;
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*//;
next if not length $next_line;
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";
}
}
}
gdb $in, "cont\n";
next;
}
if($line =~ m/^Watchpoint \d+: (.*)/) {
my $var = $1;
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;
my ($val1) = $old =~ m/Old value = (.*)/;
my ($val2) = $new =~ m/New value = (.*)/;
$got_output = 1;
print "$opening$var = $val2$closing";
gdb $in, "cont\n";
next;
}
if($line =~ m/^Hardware watchpoint \d+: (.*)/) {
my $var = $1;
my $ignore = <$out>;
my $old = <$out>;
my $new = <$out>;
$ignore = <$out>;
$ignore = <$out>;
my ($val1) = $old =~ m/Old value = (.*)/;
my ($val2) = $new =~ m/New value = (.*)/;
$got_output = 1;
my $output = "$opening$var changed: $val1 => $val2$closing";
flushall $in, $out;
print $output;
gdb $in, "cont\n";
next;
}
if($line =~ m/^Watchpoint \d+ deleted/) {
my $ignore = <$out>;
print "ignored $ignore\n" if $debug >= 5;
gdb $in, "cont\n";
next;
}
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;
}
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;
}
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;
}
if($line =~ m/Program terminated with signal SIGKILL/) {
print "[Killed]\n";
return 0;
}
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;
}
SIGNAL:
#print "SIGNAL - testing line [$line]\n" if $debug;
if($line =~ m/Program received signal/) {
my $result = "";
my $vars = "";
my $varsep = "";
$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+<function called from gdb>};
<$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 ";
}
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 = " <local variables: $vars>" if length $vars;
print "$result$vars\n";
exit 0;
}
if($line =~ s/^\(gdb\)\s*//) {
$got_output = 1;
print "$opening$line$closing";
next;
}
next if $line =~ m/^\d+\s+void gdb\(\) \{\}/;
next if not length $line;
$got_output = 1;
print "$line\n";
}
}
sub gdb {
my ($in, $command) = @_;
chomp $command;
print "+++ gdb command [$command]\n" if $debug >= 2;
print $in "$command\n";
}
sub flushall {
my ($in, $out) = @_;
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";
}
}
$SIG{ALRM} = sub { print "\n"; exit 1; };
alarm 8;
execute("LIBC_FATAL_STDERR=1 MALLOC_CHECK_=1 gdb -silent -q -nx -iex 'set auto-load safe-path /' ./prog");