#! /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) 2>/dev/null | 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;