#!/usr/bin/perl

# Get list of debug symbol packages relevant for a core file or ELF
# program/library.
#
# Copyright (C) 2017 Stefan Fritsch <sf@debian.org>
# Copyright (C) 2017 Paul Wise <pabs@debian.org>
#
# 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, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use strict;
use warnings FATAL => 'all';
use autodie qw(:all);
use v5.14;
use IPC::System::Simple qw(capturex);

$ENV{LC_ALL} = 'C';

if (scalar @ARGV == 0 or $ARGV[0] eq '--help' or $ARGV[0] eq '-h') {
    usage();
}

my %pkgs;
foreach my $arg (@ARGV) {
    my %build_ids;
    if ($arg =~ /^\d+$/) {
        %build_ids = get_build_ids_from_pid($arg);
    } else {
        %build_ids = get_build_ids_from_file($arg);
    }

    foreach my $id (keys %build_ids) {
        my ($path, $name) = @{$build_ids{$id}};

        next if $name =~ /^linux-(gate|vdso\d*)[.]so[.]/;

        my @p = get_debs_from_id($id);
        if (scalar @p == 0) {
            @p = get_debs_from_path($path);
            if (scalar @p == 0) {
                warn "Cannot find debug package for $name ($id)\n";
            }
        } elsif (scalar @p > 1) {
            warn "Multiple packages for $name ($id): @p\n";
        }
        foreach my $p (@p) {
            $pkgs{$p} = 1;
        }
    }
}

say join(" ", sort keys %pkgs);

exit 0;

#### sub routines ####

sub parse_eu_unstrip
{
    my ($output) = @_;

    my %ids;

    foreach my $line (split(/\n/, $output)) {
        # 0x7fa9b8017000+0x39e9a0 79450f6e36287865d093ea209b85a222209925ff@0x7fa9b8017280 /lib/x86_64-linux-gnu/libc.so.6 /usr/lib/debug/.build-id/79/450f6e36287865d093ea209b85a222209925ff.debug libc.so.6
        # 0x7f7f7235e000+0x17000 - /usr/share/locale/de/LC_MESSAGES/bash.mo - /usr/share/locale/de/LC_MESSAGES/bash.mo
        # 0x7ffd4098a000+0x2000 de7dac2df9f596f46fa94a387858ef25170603ec@0x7ffd4098a7d0 . - [vdso: 1740]
        if ($line =~ m{^(?:0 | 0x[[:xdigit:]]+)
                      [+]
                      0x[[:xdigit:]]+
                      \s+
                      ([[:xdigit:]]{40} [@] 0x[[:xdigit:]]+ | - )
                      \s+
                      (\S+)
                      \s+
                      (\S+)
                      \s+
                      (\S+)?
                      $}ix) {
            my $id = $1;
            my $path = $2;
            my $debug = $3;
            my $name = $4 // $path;
            if ($debug ne '-') {
                next;
            }
            if ($name =~ /\[vdso: \d+\]/) {
                next;
            }
            if ($id eq '-') {
                warn "No build-ID for $name\n";
                next;
            } elsif ($id =~ /^([[:xdigit:]]{40})[@]/) {
                $id = $1;
            } else {
                die "BUG: id='$id'";
            }
            if ($path eq '-' || $path eq '.') {
                $path = $name;
                $path =~ s{ \(deleted\)$}{};
            }
            $ids{$id} = [$path, $name];
        } else {
            warn "Cannot parse eu-unstrip output: '$line'\n";
        }
    }
    return (%ids);
}

sub get_files_from_elf
{
    my ($filename) = @_;
    my @libs = ($filename);
    my $output = capturex(qw(ldd --), $filename);

    foreach my $line (split(/\n/, $output)) {
	chomp $line;
        my ($name, $path);
        if ($line =~ /^\t.+ => (.+) \(0x[0-9a-f]+\)$/) {
            push @libs, $1;
        } elsif ($line =~ /^\t(.+) \(0x[0-9a-f]+\)$/) {
            push @libs, $1;
        } else {
            warn "Cannot parse ldd output: '$line'\n";
        }
    }

    return @libs;
}

sub get_build_ids_from_file
{
    my ($filename) = @_;
    if (is_core_file($filename)) {
        return get_build_ids_from_core($filename);
    } else {
        my @filenames = get_files_from_elf($filename);
        my %build_ids;
        foreach my $filename (@filenames) {
            next if $filename =~ /^linux-vdso\.so\./;
            %build_ids = (%build_ids, get_build_ids_from_elf($filename));
        }
        return %build_ids;
    }
}

sub get_build_ids_from_elf
{
    my ($filename) = @_;
    my $output = capturex(qw(eu-unstrip --list-only --executable), $filename);

    return parse_eu_unstrip($output);
}

sub get_build_ids_from_core
{
    my ($filename) = @_;
    my $output = capturex(qw(eu-unstrip --list-only --core), $filename);

    return parse_eu_unstrip($output);
}

sub get_build_ids_from_pid
{
    my ($pid) = @_;
    my $output = capturex(qw(eu-unstrip --list-only --pid), $pid);
    chomp $output;

    return parse_eu_unstrip($output);
}

sub get_debs_from_id
{
    my ($id) = @_;

    my $output;
    eval {
        $output = capturex(qw(grep-aptavail --no-field-names --show-field Package --field Build-IDs --pattern), $id);
    };
    if ($@) {
        return;
    }

    my %pkgs = map { $_ => 1 } split(/\n/, $output);
    return sort keys %pkgs;
}

sub get_debs_from_path
{
    my ($path) = @_;

    my $output;
    eval {
        ($output, undef) = capturex(qw(dpkg-query --search --), $path);
    };
    if ($@) {
        return;
    }

    my %pkgs = ();
    foreach my $line (split(/\n/, $output)) {
        if ($line =~ /^(.*): /) {
            $pkgs{$1} = 1;
        } else {
            warn "Cannot parse dpkg-query output: '$line'\n";
        }
    }
    my @pkgs = sort keys %pkgs;
    my @strip_pkgs = map { s{:.*}{}; s{\d.*$}{}r } @pkgs;

    eval {
        ($output, undef) = capturex(qw(dpkg-query --showformat ${source:Package}\n --show --), @pkgs);
    };
    if ($@) {
        return;
    }

    my %dbg_pkgs = ();
    foreach my $src_pkg (split(/\n/, $output)) {
        my $output;
        eval {
            $output = capturex(qw(grep-aptavail --no-field-names --show-field Package --field Package --pattern -dbg --and --whole-pkg --field Source:Package --pattern), $src_pkg);
        };
        if ($@) {
            warn "No dbg package for source '$src_pkg'\n";
            next;
        }
        my %src_dbg_pkgs = map { $_ => 1 } split(/\n/, $output);
        my @src_dbg_pkgs = keys %src_dbg_pkgs;
        my @src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg-dbg/ } @src_dbg_pkgs } @pkgs;
        @src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg.*-dbg/ } @src_dbg_pkgs } @pkgs unless @src_strip_pkgs;
        @src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg-dbg/ } @src_dbg_pkgs } @strip_pkgs unless @src_strip_pkgs;
        @src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg.*-dbg/ } @src_dbg_pkgs } @strip_pkgs unless @src_strip_pkgs;
        @src_dbg_pkgs = @src_strip_pkgs if @src_strip_pkgs;
        map { $dbg_pkgs{$_} = 1; } @src_dbg_pkgs;
    };

    return sort keys %dbg_pkgs;
}

sub is_core_file
{
    my ($filename) = (@_);
    my $output = capturex(qw(eu-readelf --file-header --), $filename);
    if ($output =~ /^\s*Type:\s*CORE/m) {
        return 1;
    }
    return;
}

sub usage
{
    print << "EOF";
usage:
  $0 <core file or PID> [ ... ]

  You must already have the correct debug lines in your sources.list and have
  executed 'apt-get update'.

  $0 requires the elfutils and dctrl-tools packages to be installed.
EOF

    exit 1;
}

# vim: syntax=perl sw=4 sts=4 sr et