X-Git-Url: https://git.jankratochvil.net/?p=nethome.git;a=blobdiff_plain;f=bin%2Fretrace;fp=bin%2Fretrace;h=e6ede77cdaf4020fd3719bf9d1409d42c75617c9;hp=0000000000000000000000000000000000000000;hb=17aa3c569ad21a99b0446694ec9096a8c958b29c;hpb=3157551e7929b74159491ee8556c470f654c2b8e

diff --git a/bin/retrace b/bin/retrace
new file mode 100755
index 0000000..e6ede77
--- /dev/null
+++ b/bin/retrace
@@ -0,0 +1,179 @@
+#! /usr/bin/perl
+# $Id$
+# (eu-unstrip -n --core=`echo ./core.*`; echo; gdb -nx -ex "set debug-file-directory /_N" -ex "core-file `echo ./core.*`" -ex bt -ex q) | ./retrace
+
+use strict;
+use warnings;
+
+delete @ENV{qw(PATH BASH_ENV)};
+my $hex=qr/[[:xdigit:]]/;
+my $tmp="/tmp/retrace.$$";
+
+sub spawn($)
+{
+  my($cmd)=@_;
+
+  $cmd.=" >&2";
+  system $cmd and die "$cmd: $!";
+}
+
+sub readfile($)
+{
+  my($fname)=@_;
+
+  local *F;
+  open F,$fname or die $fname;
+  my $F=do { local $/; <F>; };
+  defined $F or die $fname;
+  close F or die $fname;
+  return $F;
+}
+
+sub writefile
+{
+  my($fname,$content)=@_;
+
+  local *F;
+  open F,">$fname" or die $fname;
+  print F $content or die $fname;
+  close F or die $fname;
+}
+
+my $gdbcmd;
+sub cmd_prep()
+{
+  $gdbcmd=<<"HERE";
+set width 0
+set height 0
+set pagination off
+set confirm no
+set architecture i386:x86-64
+HERE
+}
+
+sub buildid_to_filename($)
+{
+  my($hash)=@_;
+
+  $hash=~/^($hex{2})($hex{38})$/o or die;
+  local $_=readfile "readlink -f /usr/lib/debug/.build-id/$1/$2 |";
+  chomp;
+  return $_;
+}
+
+sub filename_to_text_off($)
+{
+  my($filename)=@_;
+
+  my $headers=readfile "eu-readelf --section-headers $filename |";
+
+  # Section Headers:
+  # [Nr] Name                 Type         Addr             Off      Size     ES Flags Lk Inf Al
+  # [...]
+  # [12] .text                PROGBITS     000000000001e6a0 0001e6a0 000fe2b4  0 AX     0   0 16
+  $headers=~/^\[ *\d+\] \.text +PROGBITS +$hex+ +($hex+) /mo or die "No .text Addr found:\n".$headers;
+  return $1;
+}
+
+sub cmd_add_symbol_file($$)
+{
+  my($base0x,$buildid_hash)=@_;
+
+  my $buildid_filename=buildid_to_filename $buildid_hash;
+  if (!-r $buildid_filename) {
+    print "$buildid_hash Missing: $buildid_filename\n";
+    return;
+  }
+  print "$buildid_hash $buildid_filename\n";
+
+  my $text_addr=filename_to_text_off $buildid_filename;
+
+  $gdbcmd.=<<"HERE";
+add-symbol-file $buildid_filename $base0x+0x$text_addr
+HERE
+}
+
+sub cmd_add_address0x($)
+{
+  my($address0x)=@_;
+
+  # addr2line/eu-addr2line do not print symbols with no .debug_line.
+  $gdbcmd.=<<"HERE";
+echo =S=$address0x\\n
+info sym $address0x
+echo =E=$address0x\\n
+HERE
+  # __nanosleep_nocancel + 7 in section .text of /lib64/libc-2.10.1.so
+}
+
+sub cmd_finish()
+{
+  $gdbcmd.=<<"HERE";
+quit
+HERE
+}
+
+sub eu_unstrip_n_read($)
+{
+  my($F)=@_;
+
+  local $_;
+  while (<$F>) {
+    # 0x36b5a00000+0x36e000 ec8dd400904ddfcac8b1c343263a790f977159dc@0x36b5a00280 /lib64/libc-2.10.1.so /usr/lib/debug/lib64/libc-2.10.1.so.debug  on
+    chomp;
+    last if $_ eq "";
+    my($base0x,$buildid_hash)=(/^(0x$hex+)[+]0x$hex+ +($hex+)\Q@\E0x$hex+/) or die "Invalid eu-unstrip -n line: $_";
+    cmd_add_symbol_file $base0x,$buildid_hash;
+  }
+}
+
+sub gdb_bt_read()
+{
+  my @r;
+  local $_;
+  while (<>) {
+    # #0  0x00000036b5aa3f70 in ?? ()
+    if (!/^(#\d+ +(0x$hex+) in )\Q?? ()\E\s*$/) {
+      push @r,$_;
+      next;
+    }
+    my($prefix,$address0x)=($1,$2);
+    cmd_add_address0x $address0x;
+    push @r,[$_,$prefix,$address0x];
+  }
+  return @r;
+}
+
+spawn "renice 20 -p $$ 2>/dev/null";
+unlink $tmp;
+cmd_prep;
+eu_unstrip_n_read \*STDIN;
+my @output=gdb_bt_read;
+cmd_finish;
+
+writefile $tmp,$gdbcmd;
+###print $gdbcmd;
+my $gdbout=readfile "TERM=dumb gdb -nx -batch -x $tmp </dev/null |";
+
+print "### retrace begin\n";
+
+for (@output) {
+  if (!ref) {
+    print;
+    next;
+  }
+  my($origline,$prefix,$address0x)=@$_;
+  # __nanosleep_nocancel + 7 in section .text of /lib64/libc-2.10.1.so
+  if ($gdbout!~/\n=S=$address0x\n(.*?\n)=E=$address0x\n/) {
+    # This should not happen for addresses not found, they would have valid
+    # marked output just with unsuccessful result from GDB.
+    print "### retrace fail: $origline";
+    next;
+  }
+  my $gdbline=$1;
+  print $prefix.$gdbline;
+}
+
+unlink $tmp;
+print "### retrace finish\n";
+exit 0;