#!/usr/bin/perl -w
# objdump-info -- maemian collection script

# The original shell script version of this script is
# Copyright (C) 1998 Christian Schwarz
# 
# This version, including support for etch's binutils, is
# Copyright (C) 2008 Adam D. Barratt
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

use strict;

# Sanity check
unless (-f "fields/package") {
    print STDERR "error: collection script called in wrong directory!\n";
    exit 2;
}

my $failed = 0;

open (FILES, '<', "file-info")
    or fail("cannot open file-info: $!");

open (OUT, '>', "objdump-info")
    or fail("cannot open objdump-info: $!");

open(PIPE, '-|', "dpkg-query -W -f='\${Version}\n' binutils")
    or fail("unable to run dpkg-query: $!");
my $binutils_version = <PIPE>;
chomp $binutils_version;
close PIPE;

chdir ("unpacked")
    or fail ("unable to chdir to unpacked: $!\n");

while (<FILES>) {
    if (m/^(.+?):\s.*ELF/) {
	my $bin = $1;

	print OUT "-- $bin\n";

	system("head $bin | grep -q 'packed.*with.*UPX'");
	print OUT "objdump: $bin: Packed with UPX" if $? == 0;

	if (open(PIPE, '-|', "readelf -l $bin 2>&1")) {
	    local $/;
	    local $_ = <PIPE>;
	    print OUT $_;
	    close PIPE;
	}

	system("objdump -T $bin >/dev/null 2>&1");
	if ($? == 0) {
	    # Seems happy so slurp the full output
	    if (open(PIPE, '-|', "objdump --headers --private-headers -T $bin 2>&1")) {
		local $/;
		local $_ = <PIPE>;
		print OUT $_;
		close PIPE;
	    }
	} else {
	    $failed = 1;
	    my $invalidop = 0;
	    my $objdumpout = '';
	    if (open(PIPE, '-|', "objdump --headers --private-headers -T $bin 2>&1")) {
		while(<PIPE>) {
		    $objdumpout .= $_;
		    if (m/Invalid operation$/) {
			$invalidop = 1;
			$failed = 0;
		    } elsif (m/File format not recognized$/) {
			$failed = 0;
		    } elsif (m/File truncated$/) {
			$failed = 0;
		    }
		}
		close PIPE;
	    }

	    last if $failed;

	    if ($invalidop or $binutils_version !~ m/^2\.17/) {
		# If we're using a binutils newer than etch's then either
		# "invalid operation" or "file format not recognized"
		# are simply passed through to the checks scripts
		# which handle the output themselves
		#
		# If objdump returned "invalid operation" and we are
		# using etch's binutils then the readelf code will tend
		# to produce false positives so we just return the
		# objdump output and let the scripts handle it

		print OUT $objdumpout;
	    } elsif (system("readelf -l $bin 2>&1 | grep -q 'Error: Not an ELF file'") == 0) {
		print OUT "objdump: $bin: File format not recognized\n";
	    } else {
		# We're using etch's binutils so attempt to build an output
		# file in the expected format without using objdump; we lose
		# some data but none that our later checks actually use

		my @sections;
		my @symbol_versions;

		if (open(PIPE, '-|', "readelf -W -l -t -d -V $bin")) {
		    my $section = '';
		    my %program_headers;

		    while(<PIPE>) {
			chomp;
			if (m/^Program Headers:/) {
			    $section = 'PH';
			    print OUT "$_\n";
			} elsif (m/^Section Headers:/) {
			    $section = 'SH';
			    print OUT "$_\n";
			} elsif (m/^Dynamic section at offset .*:/) {
			    $section = 'DS';
			    print OUT "$_\n";
			} elsif (m/^Version symbols section /) {
			    $section = 'VS';
			} elsif (m/^\s*$/) {
			    $section = '';
			} elsif (m/^\s*(\S+)\s*(?:(?:\S+\s+){4})\S+\s(...)/
			      and $section eq 'PH') {
			    my ($header, $flags) = ($1, $2);
			    $header =~ s/^GNU_//g;
			    next if $header eq 'Type';

			    my $newflags = '';
			    $newflags .= ($flags =~ m/R/) ? 'r' : '-';
			    $newflags .= ($flags =~ m/W/) ? 'w' : '-';
			    $newflags .= ($flags =~ m/E/) ? 'x' : '-';

			    $program_headers{$header} = $newflags;

			    print OUT "  $header off 0x0 X 0x0 X 0x0\n  flags $newflags\n";
			} elsif (m/^\s*\[(\d+)\]\s*(\S+)(?:\s|\Z)/
			      and $section eq 'SH') {
			    $sections[$1] = $2;
			} elsif (m/^\s*0x(?:[0-9A-F]+)\s+\((.*?)\)\s+(\S.*)\Z/i
			      and $section eq 'DS') {
			    my ($type, $value) = ($1, $2);

			    $value =~ s/^(?:Shared library|Library soname): \[(.*)\]/$1/;
			    print OUT "  $type   $value\n";
			} elsif (m/^\s*[0-9A-F]+:\s+(\S+)\s*(?:\((\S+)\))?(\s|\Z)/i
			      and $section eq 'VS') {
			    while (m/([0-9A-F]+h?)\s*(?:\((\S+)\))?(\s|\Z)/gci) {
				my ($vernum, $verstring) = ($1, $2);
				$verstring ||= '';
				if ($vernum =~ m/h$/) {
				    $verstring = "($verstring)";
				}
				push @symbol_versions, $verstring;
			    }
			} elsif (m/^There is no dynamic section in this file/
			      and exists $program_headers{DYNAMIC}) {
			    # The headers declare a dynamic section but it's
			    # empty. Generate the same error as objdump,
			    # the checks scripts special-case the string.
			    print OUT "\n\nobjdump: $bin: Invalid operation\n";
			}
		    }
		    close PIPE;
		}

		if (open(PIPE, '-|', "readelf -W -s -D $bin")) {
		    print OUT "DYNAMIC SYMBOL TABLE:\n";

		    while(<PIPE>) {
			last if m/^Symbol table of/;

			if (m/^\s*(\d+)\s+\d+:\s*[0-9a-f]+\s+\d+\s+(?:(?:\S+\s+){3})(\S+)\s+(.*)\Z/) {
			    my ($symnum, $seg, $sym, $ver) = ($1, $2, $3, '');

			    if ($sym =~ m/^(.*)@(.*)$/) {
				$sym = $1;
				$ver = $2;
			    } elsif (@symbol_versions == 0) {
				# No versioned symbols...
				$ver = '';
			    } else {
				$ver = $symbol_versions[$symnum];

				if ($ver eq '*local*' or $ver eq '*global*') {
				    if ($seg eq 'UND') {
					$ver = '   ';
				    } else {
					$ver = 'Base';
				    }
				} elsif ($ver eq '()') {
				    $ver = '(Base)';
				}
			    }

			    if ($seg =~ m/^\d+$/ and defined $sections[$seg]) {
				$seg = $sections[$seg];
			    }

			    print OUT "00      XX $seg  000000  $ver  $sym\n";
			}
		    }

		    close PIPE;
		}
	    }
	}
    }
}

close FILES;
close OUT;

exit $failed;

sub fail {
    if ($_[0]) {
        print STDERR "internal error: $_[0]\n";
    } elsif ($!) {
        print STDERR "internal error: $!\n";
    } else {
        print STDERR "internal error.\n";
    }
    exit 1;
}