#!/usr/bin/perl

# Copyright © 2012, 2013 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.12; # for delete local
no feature 'unicode_strings';
no if $] >= 5.018, warnings => 'experimental::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);

BEGIN {
    $ENV{'DEBCONF_NOWARNINGS'} = 'yes';  ## no critic (RequireLocalizedPunctuationVars)
    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 $!;
    IO::Handle::flush(*STDERR) or die $!;
    return;
}

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

sub write_pending
{
    defined $pending_fh or die;
    truncate($pending_fh, 0) or die "$pending_path: $!";
    seek($pending_fh, 0, 0) or die "$pending_path: $!";
    for (sort keys %pending) {
        print {$pending_fh} "$_\n" or die "$pending_path: $!";
    }
    close $pending_fh or die "$pending_path: $!";
    $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;
        $package = "$package:$architecture" if $architecture ne 'all';
        $pending{$package} = 1;
    }
    write_pending();
    return;
}

sub do_pending
{
    process(1, keys %pending) if %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);
    flush_debconf();
    return;
}

sub debconf
{
    my ($subname, @args) = @_;
    no strict qw(refs);  ## no critic (ProhibitNoStrict)
    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 $!;
    } else {
        print "$pkg: $tag @extra\n" or die $!;
    }
    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 (RequireInterpolation)
        # 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: $!";
    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: ' . ($! or 'failed');
    return %map;
}

sub get_file_map  ## no critic (RequireArgUnpacking)
{
    my %map = ();
    flush_std_fh();
    open(my $fh, '-|', 'dpkg', '-L', @_) or die "dpkg -L: $!";
    my $pkg = shift;
    $map{$pkg} = [];
    while (<$fh>) {
        if (/^$/) {  ## no critic (ProhibitFixedStringMatches)
            $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: ' . ($! or 'failed');
    return %map;
}

sub get_alternative_map
{
    my %map = ();
    local $ENV{LC_ALL} = 'C';
    flush_std_fh();
    open(my $fh, '-|', 'update-alternatives', '--get-selections') or die 'update-alternatives --get-selections: ' . ($! or 'failed');
    while (<$fh>) {
        my ($alt, $path) = m/^(\S+)\s+\S+\s+(\S+)$/ or die 'unexpected output from update-alternatives --get-selections';
        $map{$alt}{$path} = 1;
    }
    close($fh) or die 'update-alternatives --get-selections: ' . ($! or 'failed');
    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 (ProhibitNoWarnings)
    *{$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, "($!)";
                }
            }
        }
    }
    return;
}

sub check_copyright
: Tags(qw(missing-copyright-file))
{
    my @packages = @_;
    for my $pkg (@packages) {
        $pkg =~ s/:.*//;
        my $file = "/usr/share/doc/$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 (RequireInterpolation)
        # 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: $!";
    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: ' . ($! 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: $!";
        } elsif (not $!{ENOENT}) {
            die "$path: $!";
        }
        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$
}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: $!";
                    next file if @pyc;
                } elsif (not $!{ENOENT}) {
                    die "$pycache: $!";
                }
                if ($path !~ m{^/usr/lib/python\d(?:[.]\d+)?/} and -r -x $path) {
                    # It could be a script with .py extensions, not a module.
                    open(my $fp, '<', $path) or die "$path: $!";
                    read($fp, my $head, 4) // die "$path: $!";
                    close($fp) or die "$path: $!";
                    next file if $head =~ m{^[#]! ?/};
                }
                tag $pkg, 'py-file-not-bytecompiled', $path;
            }
        }
    }
    return;
}

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

my %soname2license = (
    'libcrypto.so.0.9.8' => 'OpenSSL',
    'libcrypto.so.1.0.0' => 'OpenSSL',
    'libgmp.so.10' => 'GPLv3+',
    'libgnutls-extra.so.26' => 'GPLv3+',
    'libgnutls-openssl.so.27' => 'GPLv3+',
    'libgnutls.so.26' => 'LGPLv3+',
    'libgnutls.so.28' => 'LGPLv3+',
    'libltdl.so.7' => 'GPLv2+',
    'libpoppler.so.19' => 'GPLv2',
    'libpoppler.so.28' => 'GPLv2',
    'libpoppler.so.37' => 'GPLv2',
    'libpoppler.so.5' => 'GPLv2',
    'libreadline.so.5' => 'GPLv2+',
    'libreadline.so.6' => 'GPLv3+',
    'libssl.so.0.9.8' => 'OpenSSL',
    'libssl.so.1.0.0' => 'OpenSSL',
);

sub is_inside_directories
{
    my ($path, $dirs) = @_;
    my $realpath = Cwd::realpath($path) // die "resolving $path failed: $!";
    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: $!";
    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))
{
    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 ldconfing 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: $!";
        while (<$ldconfig>) {
            if (m{\s[(]libc[^)]+[)]\s+=>\s+(\S+)[/][^/]+$}) {
                $interesting_dirs{$1} = 1;
            }
        }
        close($ldconfig) or die 'ldconfig -p: ' . ($! 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: $!";
                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} = 1 if $on_rootfs;
        }
    }
    my $path = undef;
    my $pkg = undef;
    my $on_rootfs = undef;
    my $depends = {};
    my @licenses = ();
    my $license_id_product = -1;
    my %license_conflicts = ();
    given (scalar keys %path2pkg) {
        when (0) {
            # nothing to do
            return;
        }
        when (1) {
            # ldd won't print the path, so let's save it here
            ($path, $pkg) = each %path2pkg;
            (undef, $on_rootfs) = each %path_on_rootfs;
        }
    }
    flush_std_fh();
    my $ldd_pid = open(my $ldd, '-|') // die "can't fork: $!";
    if ($ldd_pid) { # parent
        my $all_dynamic = 1;
        my $suspected_error = 0;
        foreach (<$ldd>) {
            when (m/^(\S+):$/) {
                $path = $1;
                $pkg = $path2pkg{$path};
                $on_rootfs = $path_on_rootfs{$path};
                $depends = {};
                @licenses = ();
                $license_id_product = -1;
                defined $pkg or die 'unexpected output from ldd';
            }
            when (m/^\s+not a dynamic executable$/) {
                $all_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 (ProhibitReusedNames)
                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 { "$_->[1] ($_->[0])" } @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: $!";
        if ($? == 0) {
            # okay!
        } elsif (not $all_dynamic and not $suspected_error and $? == (1 << 8)) {
            # also okay!
        } else {
            die 'ldd -r: failed';
        }
        close $ldd;  ## no critic (RequireCheckedSyscalls)
    } else { # child
        open(STDIN, '<', '/dev/null') or die "can't redirect stdin: $!";
        open(STDERR, '>&STDOUT') or die "can't redirect stderr: $!";
        switch_uid_gid($ldd_uid, $ldd_gid);
        exec('ldd', '-r', sort keys %path2pkg);
        die "can't exec ldd: $!";
    }
    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;
            }
        }
    }
    given (scalar keys %dependency_licenses) {
        when (0) {
            # nothing to do
            return;
        }
        when (1) {
            # ldd won't print the path, so let's save it here
            ($path, undef) = each %dependency_licenses;
        }
    }
    flush_std_fh();
    $ldd_pid = open($ldd, '-|') // die "can't fork: $!";
    if ($ldd_pid) { # parent
        my $suspected_error = 0;
        foreach (<$ldd>) {
            when (m/^(\S+):$/) {
                $path = $1;
                $license_id_product = -1;
                defined $pkg or die 'unexpected output from 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 -r: $!";
        if ($? != 0) {
            die 'ldd -r: failed';
        }
        close $ldd;  ## no critic (RequireCheckedSyscalls)
    } else { # child
        open(STDIN, '<', '/dev/null') or die "can't redirect stdin: $!";
        open(STDERR, '>&STDOUT') or die "can't redirect stderr: $!";
        switch_uid_gid($ldd_uid, $ldd_gid);
        exec('ldd', sort keys %dependency_licenses);
        die "can't exec ldd: $!";
    }
    file:
    while (my ($path, $license_conflict) = each %license_conflicts) {  ## no critic (ProhibitReusedNames)
        my ($sopaths, $pkg, @tagdata) = @{$license_conflicts{$path}};  ## no critic (ProhibitReusedNames)
        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);
    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;
                for my $ddir (@dirs) {
                    my $dfile = "$ddir/$suffix";
                    -f $dfile or next;
                    next if exists $files{$dfile};
                    tag $pkg, 'program-name-collision', $sfile, $dfile;
                }
                last;
            }
        }
    }
    return;
}

sub check_alternatives
: Tags(qw(missing-alternative))
{
    my ($package_map, $file_map) = @_;
    my %providers;
    while (my ($pkg, $provides) = each %{$package_map}) {
        for my $vpkg (qw(x-window-manager x-terminal-emulator)) {
            if ($provides->{$vpkg}) {
                push @{$providers{$vpkg}}, $pkg;
            }
        }
    }
    %providers or return;
    my %alternative_map = get_alternative_map();
    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 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 (RequireLocalizedPunctuationVars)
    $! = 0;
    $GID = $gid; die "setting real gid to $gid: $!" if $!;
    $EGID = "$gid $gid"; die "setting effective gid to $gid: $!" if $!;
    $UID = $uid; die "setting real uid to $uid: $!" if $!;
    $EUID = $uid; die "setting effective uid to $uid: $!" if $!;
    ## 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 of the APT hook)
  --pending                (used internally of the APT hook)
  --help                   display this help and exit
EOF
    or die $!;
    exit(0);
}

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

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

sub info
{
    say {*STDERR} "adequate: @_" or die $! if 0;
    return;
}

my @ARGV_copy = @ARGV;

sub enable_debconf
{
    $use_debconf = 1;
    if (not exists $ENV{DEBIAN_HAS_FRONTEND}) {
        @ARGV = @ARGV_copy;  ## no critic (RequireLocalizedPunctuationVars)
        # 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,
);
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;
        }
    }
}

enable_debconf() if $opt_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: $!";
        chdir('/') or die "chdir /: $!";
    }
    process(0, @ARGV);
}
exit(0);

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

# vim:ts=4 sw=4 et
