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