#!/usr/bin/perl -w
# objdump-info -- lintian 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;

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;

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

	print OUT "-- $bin\n";

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

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

	if (open(PIPE, '-|', "objdump --headers --private-headers -T unpacked/$bin 2>&1")) {
	    while (<PIPE>) {
		print OUT $_;
	    }
	    close PIPE;
	} elsif ($binutils_version !~ m/^2\.17/) {
	    # etch's binutils (2.17) can't read 64-bit binaries on 32-bit
	    # platforms so we special-case that below
	    #
	    # Otherwise we allow the two specific errors "Invalid operation" and
	    # "File format not recognized" as the checks scripts handle them

	    # From the original script:
	    # If the objdump error is "Invalid operation", we handle it later
	    # in the check script, since this is the expected output (for now)
	    # on detached debugging information in /usr/lib/debug.

	    if (!system("objdump -T unpacked/$bin 2>&1 | grep -q 'Invalid operation\$'") and
		!system("objdump -T unpacked/$bin 2>&1 | grep -q 'File format not recognized\$'")) {

		$failed = 1;
		last;
	    }
	} else {
	    # We're using etch's binutils so attempt to build an output file
	    # in the expected format without using objcopy; we lose some
	    # data but none that our later checks actually use

	    my @sections;
	    my @symbol_versions;

	    if (system("readelf -l unpacked/$bin 2>&1 | grep -q 'Error: Not an ELF file'") {
		print OUT "objdump: $bin: File format not recognized\n";
		next;
	    elsif (open(PIPE, '-|', "readelf -W -l -t -d -V unpacked/$bin")) {
		my $section = '';
		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' : '-';

			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/i
			     and $section eq 'VS') {
			while (m/\s(\S+)\s*\((\S+)\)(\s|\Z)/gc) {
			    my ($vernum, $verstring) = ($1, $2);
			    push @symbol_versions, $verstring;
			}
		    }
		}
		close PIPE;
	    }

	    if (open(PIPE, '-|', "readelf -W -s -D unpacked/$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;
			} else {
			    $ver = $symbol_versions[$symnum];

			    if ($ver eq '*local*' or $ver eq '*global*') {
				if ($seg eq 'UND') {
				    $ver = '   ';
				} else {
				    $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;
}