#!/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;
use warnings;

use lib "$ENV{'LINTIAN_ROOT'}/lib/";
use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(fail);

my ($pkg, $type, $dir) = @ARGV;
my $info = Lintian::Collect->new ($pkg, $type, $dir);
my $failed = 0;

if ( -e "$dir/objdump-info" ) {
    unlink "$dir/objdump-info" or fail "unlink objdump-info: $!"
}

if ( -e "$dir/objdump-info.gz" ) {
    unlink "$dir/objdump-info.gz" or fail "unlink objdump-info.gz: $!"
}

my $file_info = $info->file_info;

my %opts = ( pipe_in => FileHandle->new,
             out => "$dir/objdump-info.gz",
             fail => 'error' );
spawn(\%opts, ['gzip', '-9c'] );
$opts{pipe_in}->blocking(1);

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

foreach my $bin (@{ $info->sorted_index }) {
    my $finfo = $file_info->{$bin};

    if ($finfo =~ m/^\bELF\b/) {

        print {$opts{pipe_in}} "-- $bin\n";

        system("head \Q$bin\E | grep -q 'packed.*with.*UPX'");
        print {$opts{pipe_in}} "objdump: $bin: Packed with UPX" if $? == 0;

        my @sections;
        my @symbol_versions;
        my $truncated = 0;

        if (open(PIPE, '-|', "readelf -W -l -t -d -V \Q$bin\E 2>&1")) {
            my $section = '';
            my %program_headers;

            while(<PIPE>) {
                chomp;
                if (m/^readelf: Error: Unable to read in 0x[0-9a-fA-F]+ bytes of/) {
                    print {$opts{pipe_in}} "objdump: $bin: File truncated\n" unless $truncated++;
                    next;
                } elsif (m/^Program Headers:/) {
                    $section = 'PH';
                    print {$opts{pipe_in}} "$_\n";
                } elsif (m/^Section Headers:/) {
                    $section = 'SH';
                    print {$opts{pipe_in}} "$_\n";
                } elsif (m/^Dynamic section at offset .*:/) {
                    $section = 'DS';
                    print {$opts{pipe_in}} "$_\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 {$opts{pipe_in}} "  $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;
                    # We need sections as well (i.e. for incomplete stripping)
                    # - The 0 0 0 0 2**3 is just there to make it look like objdump output
                    #   (supposedly we don't even check for those extra fields in
                    #    L::Collect::Binary)
                    print {$opts{pipe_in}} " $1 $2   0 0 0 0 2**3\n";
                } elsif (m/^\s*0x(?:[0-9A-F]+)\s+\((.*?)\)\s+(\S.*)\Z/i
                         and $section eq 'DS') {
                    my ($type, $value) = ($1, $2);

                    if ($type eq 'RPATH') {
                        $value =~ s/.*\[//;
                        $value =~ s/\]\s*$//;
                    }
                    $value =~ s/^(?:Shared library|Library soname): \[(.*)\]/$1/;
                    print {$opts{pipe_in}} "  $type   $value\n";
                } elsif (m/^\s*[0-9A-F]+: \s+ \S+ \s* (?:\(\S+\))? (?:\s|\Z)/xi
                         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 {$opts{pipe_in}} "\n\nobjdump: $bin: Invalid operation\n";
                }
            }
            close PIPE;
        }

        if (open(PIPE, '-|', "readelf -W -s \Q$bin\E 2>&1")) {
            my $section = '';
            print {$opts{pipe_in}} "DYNAMIC SYMBOL TABLE:\n";

            while(<PIPE>) {
                if (m/^Symbol table '.dynsym'/) {
                    $section = 'DS';
                } elsif (m/^Symbol table/) {
                    $section = '';
                } elsif (m/^\s*(\d+):\s*[0-9a-f]+\s+\d+\s+(?:(?:\S+\s+){3})(\S+)\s+(.*)\Z/
                         and $section eq 'DS') {
                    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 {$opts{pipe_in}} "00      XX $seg  000000  $ver  $sym\n";
                }
            }

            close PIPE;
        }
    }
}

close $opts{pipe_in} or fail "cannot write objdump-info.gz: $!";
reap(\%opts);

exit $failed;

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
