lintian 2.5.30+deb8u4 / usr / share / lintian / helpers / coll / objdump-info-helper

#!/usr/bin/perl
# objdump-info-helper -- lintian collection script

# Most of it is taken from objdump-info (Lintian 2.5.9), which had the
# following copyright/license statements:
#
# 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 autodie;

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

my (@sections, @symbol_versions);
my @dyn_symbols;
my %program_headers;
my $bin;
my $truncated = 0;
my $section = '';

# it would have been nice to do open '-|', "readelf ... 2>&1" but
# then we have to escape the args and that puts us over the
# argument limit in some cases...
my $pid = open(my $readelf, '-|');

if (not $pid) {
    # child - re-direct standerr and exec
    open(STDERR, '>&', \*STDOUT);
    exec 'readelf', '-WltdVs', @ARGV;
}

if (scalar @ARGV == 1) {
    # Special case - readelf will not prefix the output with "File:
    # $name" if it only gets one file argument, so act as if it did...
    # - In fact, if readelf always emitted that File: header, we could
    #   simply use xargs directly on readelf and just parse its output
    #   in the loop below.
    $bin = $ARGV[0];
    print "Filename: $bin\n";

    if (spawn(undef, ['head', $bin], '|', ['grep', '-q', 'packed.*with.*UPX']))
    {
        print "UPX: yes\n";
    }
}

while (my $line = <$readelf>) {

    chomp $line;

    if ($line =~ m/^File: (.+)$/) {
        my $file = $1;
        finish_file();

        $bin = $file;
        print "Filename: $bin\n";

        if (
            spawn(
                undef, ['head', $bin],
                '|', ['grep', '-q', 'packed.*with.*UPX'])
          ) {
            print "UPX: yes\n";
        }
    } elsif ($line
        =~ m/^readelf: Error: Reading 0x[0-9a-fA-F]+ bytes extends past end of file for section headers/
        or $line
        =~ m/^readelf: Error: Unable to read in 0x[0-9a-fA-F]+ bytes of/
        or $line
        =~ m/^readelf: Error: .*: Failed to read .*(?:magic number|file header)/
      ) {
       # Various errors for corrupt / broken files.  Note, readelf may spit out
       # multiple errors per file, hench the "unless".
        print "Broken: yes\n" unless $truncated++;
        next;
    } elsif ($line =~ m/^Program Headers:/) {
        $section = 'PH';
        print "Program-Headers:\n";
    } elsif ($line =~ m/^Section Headers:/) {
        $section = 'SH';
        print "Section-Headers:\n";
    } elsif ($line =~ m/^Dynamic section at offset .*:/) {
        $section = 'DS';
        print "Dynamic-Section:\n";
    } elsif ($line =~ m/^Version symbols section /) {
        $section = 'VS';
    } elsif ($line =~ m/^Symbol table '.dynsym'/) {
        $section = 'DS';
    } elsif ($line =~ m/^Symbol table/) {
        $section = '';
    } elsif ($line =~ m/^\s*$/) {
        $section = '';
    } elsif ($line =~ 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 = '';
        my $redo = 0;
        my $extra = '';
        $newflags .= ($flags =~ m/R/) ? 'r' : '-';
        $newflags .= ($flags =~ m/W/) ? 'w' : '-';
        $newflags .= ($flags =~ m/E/) ? 'x' : '-';

        $program_headers{$header} = $newflags;

        if ($header eq 'INTERP') {
            # Check if the next line is the "requesting an interpreter"
            # (readelf appears to always emit on the next line if at all)
            my $next = <$readelf>;
            if ($next =~ m,\[Requesting program interpreter:\s([^\]]+)\],) {
                $extra .= " interp=$1";
            } else {
                # Nope, give it back
                $redo = 1;
                $line = $next;
            }
        }

        print "  $header flags=${newflags}$extra\n";

        redo if $redo;
        next;

    } elsif ($line =~ m/^\s*\[(\d+)\]\s*(\S+)(?:\s|\Z)/
        and $section eq 'SH') {
        # We also match " [<addr>]: flags*, but don't need them
        # - in this case $2 will be ':'.
        next if $2 eq ':';
        $sections[$1] = $2;
        # We need sections as well (e.g. for incomplete stripping)
        print " $1 $2\n";
    } elsif ($line =~ 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 "  $type   $value\n";
    } elsif ($line =~ m/^\s*[0-9A-F]+: \s+ \S+ \s* (?:\(\S+\))? (?:\s|\Z)/xi
        and $section eq 'VS') {
        while ($line =~ 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 ($line
        =~ m/^\s*(\d+):\s*[0-9a-f]+\s+\d+\s+(?:(?:\S+\s+){3})(\S+)\s+(.*)\Z/
        and $section eq 'DS') {
        # We (somtimes) need to read the "Version symbols section" first to
        # use this data and readelf tends to print after this section, so
        # save for later.
        push(@dyn_symbols, [$1, $2, $3]);

    } elsif ($line =~ m/^There is no dynamic section in this file/
        and exists $program_headers{DYNAMIC}) {
        # The headers declare a dynamic section but it's
        # empty.
        print "Bad-Dynamic-Table: Yes\n";
    }
}

# Finish the last file
finish_file();

close($readelf);

exit 0;

sub finish_file {

    if (@dyn_symbols) {
        print "Dynamic-Symbols:\n";
        foreach my $dynsym (@dyn_symbols) {
            my ($symnum, $seg, $sym) = @{$dynsym};
            my $ver;

            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 " $seg $ver $sym\n";
        }
    }
    # Add an newline to end the current paragraph
    print "\n";

    # reset variables
    @sections = ();
    @symbol_versions = ();
    @dyn_symbols = ();
    $truncated = 0;
    $section = '';
    %program_headers = ();
    $bin = '';
    return;
}