#!/usr/bin/perl

# Copyright © 2012-2016 Jakub Wilk <jwilk@debian.org>
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the “Software”), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

use strict;
use warnings;

use v5.14;
no feature 'unicode_strings';
no if $] >= 5.017011, warnings => 'experimental::smartmatch';
no if $] >= 5.037010, warnings => 'deprecated::smartmatch';

use Attribute::Handlers;
use Cwd;
use English qw(-no_match_vars);
use Getopt::Long qw(:config);
use Errno;
use Fcntl qw(:flock);
use IO::Handle qw();
use POSIX qw(setsid);

our $VERSION = '0';

BEGIN {
    $ENV{'DEBCONF_NOWARNINGS'} = 'yes';  ## no critic (LocalizedPunctuationVars)
    local %::known_tags = ();
    local %::visible_tags = ();
}

my $pending_path = '/var/lib/adequate/pending';
my %pending = ();
my $pending_fh;

sub flush_std_fh
{
    IO::Handle::flush(*STDOUT) or die $ERRNO;
    IO::Handle::flush(*STDERR) or die $ERRNO;
    return;
}

sub read_pending
{
    die if defined $pending_fh;
    if (open($pending_fh, '+>>', $pending_path)) {  ## no critic (BriefOpen)
        flock $pending_fh, LOCK_EX or die "$pending_path: $ERRNO";
        seek($pending_fh, 0, 0) or die "$pending_path: $ERRNO";
        while (<$pending_fh>) {
            chomp;
            $pending{$_} = 1;
        }
    } elsif ($ERRNO{ENOENT}) {
        return;
    } else {
        die "$pending_path: $ERRNO";
    }
    return;
}

sub write_pending
{
    defined $pending_fh or die;
    truncate($pending_fh, 0) or die "$pending_path: $ERRNO";
    seek($pending_fh, 0, 0) or die "$pending_path: $ERRNO";
    for (sort keys %pending) {
        print {$pending_fh} "$_\n" or die "$pending_path: $ERRNO";
    }
    close $pending_fh or die "$pending_path: $ERRNO";
    $pending_fh = undef;
    return;
}

sub do_apt_preinst
{
    my $enabled = undef;
    while (<STDIN>) {
        given ($_) {
            when ("Adequate::Enabled=true\n") {
                $enabled = 1;
            }
            when ("Adequate::Enabled=false\n") {
                $enabled = 0;
            }
            when ("\n") {
                last;
            }
        }
    }
    if (not defined $enabled) {
        warning('apt hook is not enabled');
    }
    if (not $enabled) {
        return;
    }
    while (<STDIN>) {
        my ($package, $architecture) = m{^(\S+) \s+ \S+ \s+ \S+ \s+ \S+ \s+ /.+_([a-z0-9]+)[.]deb$}x or next;
        if ($architecture ne 'all') {
            $package = "$package:$architecture";
        }
        $pending{$package} = 1;
    }
    write_pending();
    return;
}

sub do_pending
{
    if (%pending) {
        process(1, keys %pending);
        %pending = ();
    }
    write_pending();
    return;
}

my $use_debconf = 0;
my @debconf_buffer = ();
my $ldd_uid = undef;
my $ldd_gid = undef;

sub process
{
    my ($ignore_missing, @packages) = @_;
    my %package_map = get_package_map($ignore_missing, @packages);
    @packages = keys %package_map;
    if (not @packages) {
        if ($ignore_missing) {
            return;
        } else {
            error('no packages to check');
        }
    }
    my %file_map = get_file_map(@packages);
    check_broken_symlinks(%file_map);
    check_copyright(@packages);
    check_obsolete_conffiles(@packages);
    check_python_bytecompilation(%file_map);
    check_elfs(%file_map);
    check_paths(%file_map);
    check_alternatives(\%package_map, \%file_map);
    check_binfmts(@packages);
    check_pkgconfig(%file_map);
    flush_debconf();
    return;
}

sub debconf
{
    my ($subname, @args) = @_;
    no strict qw(refs);  ## no critic (NoStrict)
    my $sub = \&{"Debconf::Client::ConfModule::$subname"};
    my ($rc, $msg) = $sub->(@args);
    if ($rc != 0) {
        die "interaction with debconf failed: $msg";
    }
}

sub flush_debconf
{
    @debconf_buffer or return;
    my $debconf_buffer = join("\n", @debconf_buffer);
    $debconf_buffer =~ s/\\/\\\\/g;
    $debconf_buffer =~ s/\n/\\n/g;
    my $t = 'adequate/error';
    debconf('version', '2.0');
    debconf('capb', 'escape');
    debconf('fset', $t, 'seen', 0);
    debconf('subst', $t, 'tags', $debconf_buffer);
    debconf('input', 'critical', $t);
    debconf('title', 'adequate found packaging bugs');
    debconf('go');
    return;
}

sub tag
{
    my ($pkg, $tag, @extra) = @_;
    die "attempted to emit unknown tag $tag" if not defined $::known_tags{$tag};
    $::visible_tags{$tag} or return;
    if ($use_debconf) {
        push @debconf_buffer, "$pkg: $tag @extra";
    } elsif (-t STDOUT) {
        print "$pkg: \e[31m$tag\e[0m @extra\n" or die $ERRNO;
    } else {
        print "$pkg: $tag @extra\n" or die $ERRNO;
    }
    return;
}

sub get_package_map
{
    my ($ignore_dpkg_query_errors, @packages) = @_;
    my %map;
    flush_std_fh();
    open(my $fh, '-|',
        'dpkg-query', '-Wf', '${binary:Package} ${Package};${Status};${Provides}\n',  ## no critic (Interpolation)
        # try both ${binary:Package} and ${Package}; the former gives us
        # architecture information, but the later works with pre-multiarch dpkg
        '--', @packages
    ) or die "dpkg-query -W: $ERRNO";
    while (<$fh>) {
        my ($package, $status, $provides) = m/^\s*(\S+).*;.*\s(\S+);(.*)$/;
        if ($status eq 'installed') {
            my %provides = map { $_ => 1 } split(m/,\s*/, $provides);
            $map{$package} = \%provides;
        } elsif (@packages) {
            info("skipping $package because it's not installed");
        }
    }
    close($fh) or $ignore_dpkg_query_errors or die 'dpkg-query -W: ' . ($ERRNO or 'failed');
    return %map;
}

sub get_file_map  ## no critic (ArgUnpacking)
{
    my %map = ();
    flush_std_fh();
    open(my $fh, '-|', 'dpkg', '-L', @_) or die "dpkg -L: $ERRNO";
    my $pkg = shift;
    $map{$pkg} = [];
    while (<$fh>) {
        if (/^$/) {  ## no critic (FixedStringMatches)
            $pkg = shift;
            $map{$pkg} = [];
            next;
        }
        if (m{^(?:locally diverted|diverted by \S+) to: (/.+)$}) {
            $map{$pkg}->[-1] = $1;
            next;
        }
        m{^(/.+)$} or next;
        push @{$map{$pkg}}, $1;
    }
    close($fh) or die 'dpkg -L: ' . ($ERRNO or 'failed');
    return %map;
}

sub get_alternatives
{
    my ($alt) = @_;
    my @paths = ();
    local $ENV{LC_ALL} = 'C';
    flush_std_fh();
    open(my $fh, '-|', 'update-alternatives', '--list', $alt) or die "update-alternatives --list: $ERRNO";
    while (<$fh>) {
        chomp;
        push(@paths, $_);
    }
    close($fh) or die 'update-alternatives --list: ' . ($ERRNO or 'failed');
    return @paths;
}

sub get_alternative_map
{
    my @interesting_alts = @_;
    my %seen_alts = ();
    local $ENV{LC_ALL} = 'C';
    flush_std_fh();
    open(my $fh, '-|', 'update-alternatives', '--get-selections') or die "update-alternatives --get-selections: $ERRNO";
    while (<$fh>) {
        my ($alt) = m/^(\S+)\s+\S+\s+\S+$/ or die 'unexpected output from update-alternatives --get-selections';
        $seen_alts{$alt} = 1;
    }
    close($fh) or die 'update-alternatives --get-selections: ' . ($ERRNO or 'failed');
    my %map = ();
    for my $alt (@interesting_alts) {
        next if not $seen_alts{$alt};
        for my $path (get_alternatives($alt)) {
            $map{$alt}{$path} = 1;
        }
    }
    return %map;
}

sub UNIVERSAL::Tags : ATTR(CODE)
{
    my (undef, $symbol, $code, undef, $tags) = @_;
    for my $tag (@{$tags}) {
        $::known_tags{$tag} = 1;
    }
    no warnings qw(redefine);  ## no critic (NoWarnings)
    *{$symbol} = sub {
        local %::visible_tags =
            map { $_ => 1 }
            grep { exists $::visible_tags{$_} }
            @{$tags};
        return $code->(@_) if %::visible_tags;
        return;
    };
    return;
}

sub check_broken_symlinks
: Tags(qw(broken-symlink))
{
    my %map = @_;
    while (my ($pkg, $files) = each %map) {
        for my $file (@{$files}) {
            if (-l $file and not stat($file)) {
                my $target = readlink $file;
                if (defined $target) {
                    tag $pkg, 'broken-symlink', $file, '->', $target;
                } else {
                    tag $pkg, 'broken-symlink', $file, "($ERRNO)";
                }
            }
        }
    }
    return;
}

sub check_copyright
: Tags(qw(missing-copyright-file))
{
    my @packages = @_;
    for my $pkg (@packages) {
        s/:.*// for my $noarch_pkg = $pkg;  ## no critic (PostfixControls)
        my $file = "/usr/share/doc/${noarch_pkg}/copyright";
        if (! -f $file) {
            tag $pkg, 'missing-copyright-file', $file;
        }
    }
    return;
}

sub check_obsolete_conffiles
: Tags(qw(obsolete-conffile))
{
    my @packages = @_;
    my $pkg;
    flush_std_fh();
    open(my $fh, '-|',
        'dpkg-query', '-Wf', '${binary:Package},${Package}\n${Conffiles}\n',  ## no critic (Interpolation)
        # try both ${binary:Package} and ${Package}; the former gives us
        # architecture information, but the later works with pre-multiarch dpkg
    ) or die "dpkg-query -W: $ERRNO";
    my %file2obs = ();
    my %pkg2files = ();
    while (<$fh>) {
        if (m/^,?([^,\s]+)/) {
            $pkg = $1;
        } elsif (m{^ (.*) [0-9a-f]+( obsolete)?$}) {
            my $file = $1;
            my $obsolete = defined $2;
            defined $pkg or die 'unexpected output from dpkg-query -W';
            if ($obsolete) {
                $file2obs{$file} //= 1;
                my $files = $pkg2files{$pkg} //= [];
                push @{$files}, $file;
            } else {
                # Work-around for dpkg bug #645849: don't consider a conffile
                # obsolete if it's listed as non-obsolete in a different
                # package.
                $file2obs{$file} = 0;
            }
        }
    }
    close($fh) or die 'dpkg-query -W: ' . ($ERRNO or 'failed');
    for my $pkg (@packages) {
        my $files = $pkg2files{$pkg} // [];
        defined $files or die;
        for my $file (@{$files}) {
            if ($file2obs{$file}) {
                tag $pkg, 'obsolete-conffile', $file;
            }
        }
    }
    return;
}

sub get_python_versions
{
    my @group = (undef, undef);
    for my $version (2..3) {
        my @result = ();
        my $path = "/usr/share/python$version/debian_defaults";
        $path =~ s{/python\K2/}{/};
        if (open(my $fh, '<', $path)) {
            while (<$fh>) {
                if (/^supported-versions\s*=\s*(\S.+\S)\s*$/) {
                    my $versions = $1;
                    push @result, grep { -f "/usr/lib/$_/os.py" } split(/\s*,\s*/, $versions);
                    last;
                }
            }
            close($fh) or die "$path: $ERRNO";
        } elsif (not $ERRNO{ENOENT}) {
            die "$path: $ERRNO";
        }
        push @group, \@result;
    }
    return @group;
}

my $bytecompilation_not_needed_re = qr{
  etc/
| bin/
| sbin/
| usr/bin/
| usr/games/
| usr/lib/debug/bin/
| usr/lib/debug/sbin/
| usr/lib/debug/usr/bin/
| usr/lib/debug/usr/games/
| usr/lib/debug/usr/sbin/
| usr/lib/pypy/lib-python/\d[.]\d+/test/bad
| usr/lib/pypy/lib-python/\d[.]\d+/lib2to3/tests/data/
| usr/sbin/
| usr/share/apport/package-hooks/
| usr/share/doc/
| usr/share/jython/
| usr/share/paster_templates/
| usr/lib/python\d[.]\d+/__phello__[.]foo[.]py$
| usr/lib/python\d[.]\d+/lib2to3/tests/data/
| usr/lib/python\d[.]\d+/test/bad
}x;
# Please keep it in sync with lintian4python!

sub check_python_bytecompilation
: Tags(qw(pyshared-file-not-bytecompiled py-file-not-bytecompiled))
{
    my %map = @_;
    my @pythons = get_python_versions();
    my @python2s = @{$pythons[2]};
    my @python3s = @{$pythons[3]};
    my $pypy_installed = -f '/usr/bin/pypy';
    my $pysupport_old = -d '/usr/lib/python-support/private/'; # python-support < 0.90
    my $pysupport_new = -d '/usr/share/python-support/private/'; # python-support >= 0.90
    while (my ($pkg, $files) = each %map) {
        file:
        for (@{$files}) {
            my ($path, $dir, $base) = m{^((/.+/)([^/]+)[.]py)$} or next;
            next file if m{^/$bytecompilation_not_needed_re};
            if (m{^/usr/share/pyshared/(.+)} or m{^/usr/share/python-support/[^/]+/(?<!/private/)(.+)}) {
                my $subpath = $1;
                next file if not @python2s;
                for my $python (@python2s) {
                    my $sitepkgs = ($python =~ m/^python2[.][0-5]$/) ? 'site-packages' : 'dist-packages';
                    next file if -f "/usr/lib/$python/$sitepkgs/${subpath}c";
                    next file if $pysupport_new and -f "/usr/lib/pymodules/$python/${subpath}c";
                    next file if $pysupport_old and -f "/var/lib/python-support/$python/${subpath}c";
                }
                tag $pkg, 'pyshared-file-not-bytecompiled', $path;
                next file;
            }
            if (-f $path) {
                next file if -f "${path}c";
                # Don't expect third-party Python 2.X modules to be
                # byte-compiled if the corresponding Python version is not
                # installed or not supported:
                next file if
                    $path =~ m{^/usr/lib/(python2[.]\d+)/(?:site|dist)-packages/}
                    and not grep { $1 eq $_ } @python2s;
                # Don't expect third-party Python 3.X modules to be
                # byte-compiled if no supported Python 3.X version is
                # installed:
                next file if
                    $path =~ m{^/usr/lib/python3/dist-packages/}
                    and not @python3s;
                # Check for PEP-3147 *.pyc repository directories:
                my $imp = 'cpython';
                if ($path =~ m{^/usr/lib/pypy/}) {
                    $pypy_installed or next file;
                    $imp = 'pypy';
                }
                my $pycache = "$dir/__pycache__";
                if (opendir(my $fh, $pycache)) {
                    my @pyc = grep { /^\Q$base.$imp\E-.+[.]pyc$/ and -f "$pycache/$_" } readdir($fh);
                    closedir($fh) or die "$pycache: $ERRNO";
                    next file if @pyc;
                } elsif (not $ERRNO{ENOENT}) {
                    die "$pycache: $ERRNO";
                }
                if ($path !~ m{^/usr/lib/python\d(?:[.]\d+)?/(?!config-)} and -r -x $path) {
                    # It could be a script with .py extensions, not a module.
                    open(my $fp, '<', $path) or die "$path: $ERRNO";
                    read($fp, my $head, 4) // die "$path: $ERRNO";
                    close($fp) or die "$path: $ERRNO";
                    next file if $head =~ m{^[#]! ?/};
                }
                tag $pkg, 'py-file-not-bytecompiled', $path;
            }
        }
    }
    return;
}

my %license2id = (
    'GPLv2' => 0x04,
    'GPLv3' => 0x08,
    'AGPLv3' => 0x08,
    'GPLv2+' => 0x0c,
    'GPLv3+' => 0x08,
    'AGPLv3+' => 0x08,
    'LGPLv2.1' => 0x14c,
    'LGPLv3' => 0x188,
    'LGPLv2.1+' => 0x1cc,
    'LGPLv3+' => 0x188,
    'LGPLv3+ | GPLv2+' => 0x18c,
    'OpenSSL' => 0x100,
);

my %soname2license = (
    'libcrypto.so.0.9.8' => 'OpenSSL',
    'libcrypto.so.1.0.0' => 'OpenSSL',
    'libgmp.so.10' => 'LGPLv3+ | GPLv2+',
    # FIXME: libgmp10 in wheezy is LGPLv3+-only
    'libgnutls-extra.so.26' => 'GPLv3+',
    'libgnutls-openssl.so.27' => 'GPLv3+',
    # FIXME: libgs9 and libjbig2dec in jessie are GPLv2+
    'libgs.so.9' => 'AGPLv3+',
    'libjbig2dec.so.0' => 'AGPLv3+',
    'libltdl.so.7' => 'GPLv2+',
    'libpoppler.so.19' => 'GPLv2',
    'libpoppler.so.28' => 'GPLv2',
    'libpoppler.so.37' => 'GPLv2',
    'libpoppler.so.43' => 'GPLv2',
    'libpoppler.so.44' => 'GPLv2',
    'libpoppler.so.46' => 'GPLv2',
    'libpoppler.so.47' => 'GPLv2',
    'libpoppler.so.5' => 'GPLv2',
    'libpoppler.so.57' => 'GPLv2',
    'libpoppler.so.60' => 'GPLv2',
    'libpoppler.so.61' => 'GPLv2',
    'libreadline.so.5' => 'GPLv2+',
    'libreadline.so.6' => 'GPLv3+',
    'libreadline.so.7' => 'GPLv3+',
    'libssl.so.0.9.8' => 'OpenSSL',
    'libssl.so.1.0.0' => 'OpenSSL',
    'libssl.so.1.0.2' => 'OpenSSL',
    'libssl.so.1.1' => 'OpenSSL',
);

sub parse_copyright_files
{
    my @packages = @_;
    my %licenses = ();
    for my $pkg (@packages) {
        s/:.*// for my $noarch_pkg = $pkg;  ## no critic (PostfixControls)
        my %pkg_licenses = ();
        my $path = "/usr/share/doc/${noarch_pkg}/copyright";
        if (open(my $fh, '<', $path)) {
            my $firstpara = 1;
            my $machine_readable = 0;
            line:
            while (<$fh>) {
                if (m/^\s*$/) {
                    $firstpara = 0;
                    $machine_readable or last;
                    next line;
                }
                if ($firstpara && m{^Format:\s+(\S+)\s*$}i) {
                    my $url = $1;
                    if ($url eq 'http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/') {
                        $machine_readable = 1;
                        next line;
                    } else {
                        $machine_readable = 0;
                        last line;
                    }
                }
                if (not $firstpara and m/^License:\s+(.+\S)\s*$/i) {
                    my $license = $1;
                    $pkg_licenses{$license} = 1;
                    $machine_readable or die;
                }
            }
            close($fh) or die "$path: $ERRNO";
            if (scalar keys %pkg_licenses == 1) {
                my ($license) = keys %pkg_licenses;
                # “AGPL” is not one the of standard short names, so in theory
                # one could use it for something else than FSF's GPL.
                # Hopefully nobody will ever do that…
                if ($license =~ /^([AL]?GPL)-([2-3])([.][0-9]+)?([+]?)$/) {
                    my ($lname, $lmajor, $lminor, $lsuffix) = ($1, $2, $3, $4);
                    $lminor //= '';
                    if ($lminor eq '.0') {
                        $lminor = '';
                    }
                    $license = "${lname}v${lmajor}${lminor}${lsuffix}";
                }
                if (defined $license2id{$license}) {
                    $licenses{$pkg} = $license;
                }
            }
        } elsif (not $ERRNO{ENOENT}) {
            die "$path: $ERRNO";
        }
    }
    return %licenses;
}

sub is_inside_directories
{
    my ($path, $dirs) = @_;
    my $realpath = Cwd::realpath($path) // die "resolving $path failed: $ERRNO";
    my ($realdir) = $realpath =~ m{(.*)/[^/]+$};
    if (defined $dirs->{$realdir}) {
        return $realpath;
    } else {
        return;
    }
}

sub augmented_path
{
    my ($orig_path, $path, $interesting_dirs) = @_;
    if ($orig_path eq $path) {
        return $path;
    }
    my $realpath = Cwd::realpath($path) // die "resolving $path failed: $ERRNO";
    my ($realdir) = $realpath =~ m{(.*)/[^/]+$};
    # If the symlink target is still in an “interesting” directory,
    # then any issue hopefully will be reported against another
    # package.
    return if defined $interesting_dirs->{$realdir};
    return "$orig_path => $realpath";
}

sub check_elfs
: Tags(qw(bin-or-sbin-binary-requires-usr-lib-library undefined-symbol symbol-size-mismatch missing-symbol-version-information library-not-found incompatible-licenses ldd-failure))
{
    my %map = @_;
    my @ld_vars = grep { /^LD_/ } keys %ENV;
    delete local @ENV{@ld_vars};
    local $ENV{LC_ALL} = 'C';
    my %interesting_dirs = (
        '/bin' => 1,
        '/sbin' => 1,
    );
    if ([keys %::visible_tags] ~~ ['bin-or-sbin-binary-requires-usr-lib-library']) {
        # /usr/* and ldconfig paths are not interesting in this case.
    } else {
        %interesting_dirs = (%interesting_dirs,
            '/usr/bin' => 1,
            '/usr/games' => 1,
            '/usr/sbin' => 1,
        );
        flush_std_fh();
        open(my $ldconfig, '-|', '/sbin/ldconfig', '-p') or die "ldconfig -p: $ERRNO";
        while (<$ldconfig>) {
            if (m{\s[(]libc[^)]+[)]\s+=>\s+(\S+)[/][^/]+$}) {
                $interesting_dirs{$1} = 1;
            }
        }
        close($ldconfig) or die 'ldconfig -p: ' . ($ERRNO or 'failed');
    }
    my %path2pkg = ();
    my %path_on_rootfs = ();
    while (my ($pkg, $files) = each %map) {
        file:
        for my $path (@{$files}) {
            my ($dir) = $path =~ m{(.*)/[^/]+$};
            next file if $path =~ /\s/;
            next file if $path =~ m{^/lib\d*/.*(?<=/)ld(?:-.+)[.]so(?:$|[.])}; # dynamic linker
            defined $interesting_dirs{$dir} or next file;
            my $on_rootfs = $path =~ m{^/s?bin/\S+$};
            -f -r $path or next file;
            if (-l $path) {
                my $realpath = Cwd::realpath($path) // die "resolving $path failed: $ERRNO";
                my ($realdir) = $realpath =~ m{(.*)/[^/]+$};
                # If the symlink target is still in an “interesting” directory,
                # then any issue hopefully will be reported against another
                # package.
                next file if defined $interesting_dirs{$realdir};
                $on_rootfs &&= $realpath =~ m{^/s?bin/\S+$}
            }
            $path2pkg{$path} = $pkg;
            $path_on_rootfs{$path} = $on_rootfs;
        }
    }
    my %dep5_licenses = parse_copyright_files(keys %map);
    my @licenses;
    my %license_conflicts = ();
    for my $path (sort keys %path2pkg) {
        my $pkg = $path2pkg{$path};
        my $on_rootfs = $path_on_rootfs{$path};
        my $depends = {};
        my $license = $dep5_licenses{$pkg};
        my $license_id_product;
        if (defined $license) {
            $license_id_product = $license2id{$license};
            @licenses = ([undef, $license]);
        } else {
            $license_id_product = -1;
            @licenses = ();
        }
        flush_std_fh();
        my $ldd_pid = open(my $ldd, '-|') // die "can't fork: $ERRNO";
        if ($ldd_pid) { # parent
            my $dynamic = 1;
            my $suspected_error = 0;
            foreach (<$ldd>) {
                when (m/^\s+not a dynamic executable$/) {
                    $dynamic = 0;
                }
                when (m/^\s+statically linked$/) {
                    # skip
                }
                when (m/^undefined symbol:\s+(\S+)(?:,\s+version\s+(\S+))?\s+[(](\S+)[)]$/) {
                    my $symbol = $1;
                    if (defined $2) {
                        $symbol = "$symbol\@$2";
                    }
                    my $triggering_path = $3;
                    next if $path =~ m/python|py[23]/ and $symbol =~ /^_?Py/;
                    next if $path =~ m/perl/ and $symbol =~ /^(?:Perl|PL)_/;
                    next if $path =~ m{/liblua} and $symbol =~ /^luaL?_/;
                    next if $path =~ m{/libthread_db-[0-9.]+[.]so$} and $symbol =~ /^ps_/;
                    my $augmented_path = augmented_path($path, $triggering_path, \%interesting_dirs);
                    defined $augmented_path or next;
                    tag $pkg, 'undefined-symbol', $augmented_path, '=>', $symbol;
                }
                when (m/^symbol (\S+), version (\S+) not defined in file (\S+) with link time reference\s+[(](\S+)[)]/) {
                    my $symbol = "$1\@$2";
                    my $lib = $3;
                    my $triggering_path = $4;
                    my $augmented_path = augmented_path($path, $triggering_path, \%interesting_dirs);
                    defined $augmented_path or next;
                    tag $pkg, 'undefined-symbol', $augmented_path, '=>', $symbol, "($lib)";
                }
                when (m/^(\S+): Symbol `(\S+)' has different size in shared object, consider re-linking$/) {
                    next if $path ne $1;
                    my $symbol = $2;
                    tag $pkg, 'symbol-size-mismatch', $path, '=>', $symbol;
                }
                when (m/^(\S+): (\S+): no version information available [(]required by (\S+)[)]$/) {
                    my $path = $1;  ## no critic (ReusedNames)
                    my $lib = $2;
                    my $triggering_path = $3;
                    my $augmented_path = augmented_path($path, $triggering_path, \%interesting_dirs);
                    defined $augmented_path or next;
                    tag $pkg, 'missing-symbol-version-information', $augmented_path, '=>', $lib;
                }
                when (m/^\t(\S+) => not found$/) {
                    tag $pkg, 'library-not-found', $path, '=>', $1;
                }
                when (m{^\t(\S+) => (\S+) [(]0x[0-9a-f]+[)]$}) {
                    my ($soname, $sopath) = ($1, $2);
                    if ($on_rootfs and $sopath =~ m{^/usr/lib/}) {
                        #tag $pkg, 'bin-or-sbin-binary-requires-usr-lib-library', $path, '=>', $sopath;
                    }
                    my $realsopath = is_inside_directories($sopath, \%interesting_dirs);
                    if (defined $realsopath) {
                        $depends->{$realsopath} = 1;
                    }
                    my $license = $soname2license{$soname};
                    if (defined $license) {
                        my $license_id = $license2id{$license} or die "unknown license $license";
                        my $new_license_id_product = $license_id_product & $license_id;
                        if ($license_id_product != $new_license_id_product) {
                            push @licenses, [$soname, $license];
                            $license_id_product = $new_license_id_product;
                            if ($license_id_product == 0) {
                                # Don't emit incompatible-licenses tag yet, because
                                # the conflict might have been caused by one of the
                                # dependencies.
                                my @tagdata = ($pkg, $path,
                                    join(' + ', map { defined $_->[0] ? "$_->[1] ($_->[0])" : $_->[1] } @licenses)
                                );
                                $license_conflicts{$path} = [$depends, @tagdata];
                            }
                        }
                    }
                }
                when (m/^\t(?:\S+)\s.*(?<=\s)[(]0x[0-9a-f]+[)]$/) {
                    # skip
                }
                when (m/^ldd: /) {
                    $suspected_error = 1;
                    s/^ldd:\s+//; chomp;
                    warning("ldd -r $path: $_");
                }
                default {
                    s/^\s+//;
                    s/^\Q$path\E:\s+//;
                    chomp;
                    warning("ldd -r $path: $_");
                }
            }
            wait or die "ldd -r: $ERRNO";
            if ($CHILD_ERROR == 0) {
                # okay!
            } elsif (not $dynamic and not $suspected_error and $CHILD_ERROR == (1 << 8)) {
                # also okay!
            } else {
                tag $pkg, 'ldd-failure', $path;
            }
            close $ldd;  ## no critic (CheckedSyscalls)
        } else { # child
            open(STDIN, '<', '/dev/null') or die "can't redirect stdin to /dev/null: $ERRNO";
            open(STDERR, '>&STDOUT') or die "can't redirect stderr: $ERRNO";
            switch_uid_gid($ldd_uid, $ldd_gid);
            exec('ldd', '-r', $path);
            die "can't exec ldd -r $path: $ERRNO";
        }
    }
    my %dependency_licenses = ();
    for my $path (keys %license_conflicts) {
        for my $sopaths ($license_conflicts{$path}->[0]) {
            for my $sopath (keys %{$sopaths}) {
                $dependency_licenses{$sopath} = -1;
            }
        }
    }
    for my $path (sort keys %dependency_licenses) {
        my $license_id_product = -1;
        flush_std_fh();
        my $ldd_pid = open(my $ldd, '-|') // die "can't fork: $ERRNO";
        if ($ldd_pid) { # parent
            my $suspected_error = 0;
            foreach (<$ldd>) {
                when (m{^\t(\S+) => (\S+) [(]0x[0-9a-f]+[)]$}) {
                    my ($soname, $sopath) = ($1, $2);
                    my $license = $soname2license{$soname};
                    if (defined $license) {
                        my $license_id = $license2id{$license} or die "unknown license $license";
                        $dependency_licenses{$path} &= $license_id;
                    }
                }
            }
            wait or die "ldd: $ERRNO";
            if ($CHILD_ERROR != 0) {
                die "ldd $path: failed";
            }
            close $ldd;  ## no critic (CheckedSyscalls)
        } else { # child
            open(STDIN, '<', '/dev/null') or die "can't redirect stdin: $ERRNO";
            open(STDERR, '>&STDOUT') or die "can't redirect stderr: $ERRNO";
            switch_uid_gid($ldd_uid, $ldd_gid);
            exec('ldd', $path);
            die "can't exec ldd $path: $ERRNO";
        }
    }
    file:
    while (my ($path, $license_conflict) = each %license_conflicts) {
        my ($sopaths, $pkg, @tagdata) = @{$license_conflicts{$path}};
        for my $sopath (keys %{$sopaths}) {
            next file if $dependency_licenses{$sopath} == 0;
        }
        tag $pkg, 'incompatible-licenses', @tagdata;
    }
    return;
}

sub check_paths
: Tags(qw(program-name-collision))
{
    my %map = @_;
    my @dirs = qw(/usr/sbin /usr/bin /sbin /bin /usr/games);
    my %whitelist = (
        # molly-guard: bugs #733213, #660064
        '/usr/sbin/halt' => 'molly-guard',
        '/usr/sbin/poweroff' => 'molly-guard',
        '/usr/sbin/reboot' => 'molly-guard',
        '/usr/sbin/shutdown' => 'molly-guard',
        # safe-rm
        '/usr/bin/rm' => 'safe-rm',
    );
    my @bash_builtins = qw< . [ alias bg bind break builtin caller case cd command compgen complete compopt continue coproc declare dirs disown echo enable eval exec exit export false fc fg for function getopts hash help history if jobs kill let local logout mapfile popd printf pushd pwd read readarray readonly return select set shift shopt source suspend test time times trap true type typeset ulimit umask unalias unset until variables wait while >;
    my %bash_builtins = map { $_ => 1 } @bash_builtins;
    my %bash_whitelist = map { $_ => 1 } qw( coreutils time procps );
    while (my ($pkg, $files) = each %map) {
        my %files = map { $_ => 1 } @{$files};
        for my $sfile (@{$files}) {
            for my $sdir (@dirs) {
                $sfile =~ qr{^$sdir/(.*)} or next;
                -f $sfile or next;
                my $suffix = $1;
                if (not exists $bash_whitelist{$pkg} and exists $bash_builtins{$suffix}) {
                    tag $pkg, 'program-name-collision', $sfile, '(bash builtin command)';
                }
                for my $ddir (@dirs) {
                    my $dfile = "$ddir/$suffix";
                    -f $dfile or next;
                    next if exists $files{$dfile};
                    next if exists $whitelist{$dfile};
                    next if ($whitelist{$sfile} // '') eq $pkg;
                    my $real_sfile = Cwd::realpath($sfile) // die "resolving $sfile failed: $ERRNO";
                    my $real_dfile = Cwd::realpath($dfile) // die "resolving $dfile failed: $ERRNO";
                    next if $real_dfile eq $real_sfile;
                    tag $pkg, 'program-name-collision', $sfile, $dfile;
                }
                last;
            }
        }
    }
    return;
}

sub check_alternatives
: Tags(qw(missing-alternative))
{
    my ($package_map, $file_map) = @_;
    my %providers;
    my @vpkgs = qw(x-window-manager x-terminal-emulator);
    while (my ($pkg, $provides) = each %{$package_map}) {
        for my $vpkg (@vpkgs) {
            if ($provides->{$vpkg}) {
                push @{$providers{$vpkg}}, $pkg;
            }
        }
    }
    %providers or return;
    my %alternative_map = get_alternative_map(@vpkgs);
    while (my ($vpkg, $pkgs) = each %providers) {
        my @registered_paths = keys %{$alternative_map{$vpkg} // {}};
        for my $pkg (@{$pkgs}) {
            my $files = $file_map->{$pkg};
            my $found = 0;
            if (@registered_paths) {
                for my $file (@{$files}) {
                    if ($file ~~ @registered_paths) {
                        $found = 1;
                        last;
                    }
                }
            }
            if (not $found) {
                tag $pkg, 'missing-alternative', $vpkg;
            }
        }
    }
    return;
}

sub get_binfmt_map
{
    local $ENV{LC_ALL} = 'C';
    flush_std_fh();
    my $update_binfmts = '/usr/sbin/update-binfmts';
    -x $update_binfmts or return ();
    open(my $fh, '-|', $update_binfmts, '--display') or die "update-binfmts --display: $ERRNO";
    my %map = ();
    my $name = undef;
    my $format = {};
    while (<$fh>) {
        if (/^(\S+) .*:$/) {
            $name = $1;
            if (exists $map{$name}) {
                die 'unexpected output from update-binfmts --display';
            }
            $map{$name}{NAME} = $name;
            next;
        }
        if (/^ +([a-z]+) = (.*)$/) {
            my ($key, $value) = ($1, $2);
            if (not defined $name or exists $map{$name}{$key}) {
                die 'unexpected output from update-binfmts --display';
            }
            if ($value ne '') {
                $map{$name}{$key} = $value;
            }
            next;
        }
        die 'unexpected output from update-binfmts --display';
    }
    close($fh) or die 'update-binfmts --display: ' . ($ERRNO or 'failed');
    return %map;
}

sub check_binfmts
: Tags(qw(broken-binfmt-detector broken-binfmt-interpreter))
{
    my @packages = @_;
    my %packages = map  ## no critic (ComplexMappings, MutatingList)
        { s/:.*// for my $pkg = $_; $pkg => 1 }  ## no critic (PostfixControls)
        @packages;
    my %formats = get_binfmt_map();
    for my $fmt (sort { $a->{NAME} cmp $b->{NAME} } values %formats) {
        my $name = $fmt->{NAME};
        my $interpreter = $fmt->{interpreter};
        my $pkg = $fmt->{package};
        defined $name or next;
        defined $interpreter or next;
        exists $packages{$pkg} or next;
        local $ERRNO = 0;
        if (stat($interpreter) and -x _) {
            # okay
        } else {
            my @errno = ();
            if ($ERRNO) {
                push @errno, "($ERRNO)";
            }
            tag $pkg, 'broken-binfmt-interpreter', $name, '=>', $interpreter, @errno;
        }
        my $detector = $fmt->{detector};
        defined $detector or next;
        local $ERRNO = 0;
        if (stat($detector) and -x _) {
            # okay
        } else {
            my @errno = ();
            if ($ERRNO) {
                push @errno, "($ERRNO)";
            }
            tag $pkg, 'broken-binfmt-detector', $name, '=>', $detector, @errno;
        }
    }
    return;
}

sub check_pkgconfig
: Tags(qw(missing-pkgconfig-dependency))
{
    my %file_map = @_;
    my %pkg_map = ();
    -x '/usr/bin/pkg-config' or return;
    while (my ($debpkg, $files) = each %file_map) {
        for my $file (@{$files}) {
            $file =~ m{^/usr/(?:share|lib(?:/[^/]+)?)/pkgconfig/([^/]+)[.]pc$} or next;
            my $pkg = $1;
            $pkg_map{$pkg} = $debpkg;
        }
    }
    while (my ($pkg, $debpkg) = each %pkg_map) {
        local $ENV{LC_ALL} = 'C';
        flush_std_fh();
        my $pkgconfig_pid = open(my $pkgconfig, '-|') // die "can't fork: $ERRNO";
        if ($pkgconfig_pid) { # parent
            while (<$pkgconfig>) {
                if (m/^Package '(.+)', required by '\Q$pkg\E', not found$/) {
                    my $deppkg = $1;
                    tag $debpkg, 'missing-pkgconfig-dependency', $pkg, '=>', $deppkg;
                }
            }
            wait or die "pkg-config --exists: $ERRNO";
            close $pkgconfig;  ## no critic (CheckedSyscalls)
        } else { # child
            open(STDERR, '>&STDOUT') or die "can't redirect stderr: $ERRNO";
            exec('pkg-config', '--exists', '--print-errors', $pkg);
            die "can't exec pkg-config: $ERRNO";
        }
    }
    return;
}

sub switch_uid_gid
{
    my ($uid, $gid) = @_;
    defined $uid or return;
    defined $gid or return;
    # If the child process had a controlling terminal, the user we switch to
    # could take over the process with ptrace(2), and then hijack the terminal
    # using TIOCSTI.
    setsid() or die;
    # Similarly, if the child process inherited an fd of an open terminal, the
    # user could do nefarious things with the terminal.
    die if -t STDIN;
    die if -t STDOUT;
    die if -t STDERR;
    # (There might be other fds open at this point, but Perl conveniently
    # closes them for us on exec.)
    ## no critic (LocalizedPunctuationVars)
    $ERRNO = 0;
    $GID = $gid; die "setting real gid to $gid: $ERRNO" if $ERRNO;
    $EGID = "$gid $gid"; die "setting effective gid to $gid: $ERRNO" if $ERRNO;
    $UID = $uid; die "setting real uid to $uid: $ERRNO" if $ERRNO;
    $EUID = $uid; die "setting effective uid to $uid: $ERRNO" if $ERRNO;
    ## use critic
    die if $UID != $uid;
    die if $EUID != $uid;
    die if $GID ne "$gid $gid";
    die if $EGID ne "$gid $gid";
    delete $ENV{HOME};
    return;
}

sub display_help
{
    print <<'EOF'
usage:

  adequate [options] <package-name>...
  adequate [options] --all
  adequate [options] --apt-preinst
  adequate [options] --pending
  adequate --help

options:

  --all                    check all installed packages
  --tags <t1>[,<t2>...]    emit only these tags
  --tags -<t1>[,<t2>...]   don't emit these tags
  --debconf                report issues via debconf
  --root <dir>             switch root directory
  --user <user>[:<group>]  switch user and group
  --apt-preinst            (used internally by the APT hook)
  --pending                (used internally by the APT hook)
  --help                   display this help and exit
EOF
    or die $ERRNO;
    exit(0);
}

sub display_version
{
    my $version;
    if (not $VERSION) {
        s{[^/]*$}{} for my $dir = $PROGRAM_NAME;  ## no critic (PostfixControls)
        open (my $fp, '<', "$dir/debian/changelog") or die $ERRNO;
        $_ = <$fp>;
        ($version) = m/^\w+ [(]([^)]+)[)]/;
        close($fp) or die $ERRNO;
    } else {
        $version = $VERSION;
    }
    say "adequate $version" or die $ERRNO;
    exit(0)
}

sub error
{
    say {*STDERR} "adequate: error: @_" or die $ERRNO;
    exit(1);
}

sub warning
{
    say {*STDERR} "adequate: @_" or die $ERRNO;
    return;
}

sub info
{
    if (0) {  # disabled for the moment
        say {*STDERR} "adequate: @_" or die $ERRNO;
    }
    return;
}

my @ARGV_copy = @ARGV;

sub enable_debconf
{
    $use_debconf = 1;
    if (not exists $ENV{DEBIAN_HAS_FRONTEND}) {
        @ARGV = @ARGV_copy;  ## no critic (LocalizedPunctuationVars)
        # import will re-exec this program
    }
    require Debconf::Client::ConfModule;
    Debconf::Client::ConfModule::import();
    return;
}

umask 022;
my $opt_all = 0;
my $opt_tags = undef;
my $opt_debconf = 0;
my $opt_root = undef;
my $opt_user = undef;
my $opt_apt_preinst = 0;
my $opt_pending = 0;
my $rc = GetOptions(
    'all' => \$opt_all,
    'tags=s' => \$opt_tags,
    'debconf' => \$opt_debconf,
    'root=s' => \$opt_root,
    'user=s' => \$opt_user,
    'apt-preinst' => \$opt_apt_preinst,
    'pending' => \$opt_pending,
    'help' => \&display_help,
    'version' => \&display_version,
);
if (not $rc) {
    exit(1);
}

%::visible_tags = %::known_tags;
if (defined $opt_tags) {
    my $negative;
    if ($opt_tags =~ s/^-//) {
        $negative = 1;
    } else {
        $negative = 0;
        %::visible_tags = ();
    }
    my @tags = split(m/,/, $opt_tags);
    for my $tag (@tags) {
        if (not $::known_tags{$tag}) {
            error("unknown tag $tag");
        }
        if ($negative) {
            delete $::visible_tags{$tag};
        } else {
            $::visible_tags{$tag} = 1;
        }
    }
}

if ($opt_debconf) {
    enable_debconf();
}

if (defined $opt_user) {
    my ($user, $group) = $opt_user =~ m/^([^\s:]++)(?::(\S+))?$/ or error('invalid user/group specification');
    if ($user =~ m/^\d+$/) {
        (undef, undef, $ldd_uid, $ldd_gid) = getpwuid($user) or error("$user: no such user");
    } else {
        (undef, undef, $ldd_uid, $ldd_gid) = getpwnam($user) or error("$user: no such user");
    }
    if (defined $group) {
        if ($group =~ m/^\d+$/) {
            (undef, undef, $ldd_gid) = getgrgid($group) or error("$group: no such group");
        } else {
            (undef, undef, $ldd_gid) = getgrnam($group) or error("$group: no such group");
        }
    }
}

if ($opt_apt_preinst) {
    error('--apt-preinst and --pending cannot be used together') if $opt_pending;
    error('--apt-preinst and --all cannot be used together') if $opt_all;
    error('--apt-preinst and --root cannot be used together') if defined $opt_root;
    error('too many arguments') if @ARGV;
    read_pending();
    do_apt_preinst();
} elsif ($opt_pending) {
    error('--pending and --all cannot be used together') if $opt_all;
    error('--pending and --root cannot be used together') if defined $opt_root;
    error('too many arguments') if (@ARGV);
    read_pending();
    do_pending();
} else {
    error('too many arguments') if ($opt_all and @ARGV);
    error('no packages to check') if (not $opt_all and not @ARGV);
    if (defined $opt_root) {
        chroot($opt_root) or die "chroot $opt_root: $ERRNO";
        chdir('/') or die "chdir /: $ERRNO";
    }
    process(0, @ARGV);
}
exit(0);

END {
    # Catch late write errors:
    local $ERRNO = 0;
    close(STDOUT) or die $ERRNO;
    close(STDERR) or die $ERRNO;
}

# vim:ts=4 sts=4 sw=4 et
