#!/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 Getopt::Long qw(:config);
use Errno;
use Fcntl qw(:flock);
use POSIX qw(setsid);

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

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

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

sub write_pending()
{
    die unless defined $pending_fh;
    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";
    }
    close $pending_fh or die "$pending_path: $!";
    $pending_fh = undef;
}

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" unless $architecture eq 'all';
        $pending{$package} = 1;
    }
    write_pending();
}

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

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

sub process($@)
{
    my ($ignore_missing, @packages) = @_;
    @packages = normalize_package_names($ignore_missing, @packages);
    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);
    flush_debconf();
}

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

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";
    } else {
        print "$pkg: $tag @extra\n";
    }
}

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

sub get_file_map(@)
{
    my %map = ();
    open(my $fh, '-|', 'dpkg', '-L', @_) or die "dpkg -L: $!";
    my $pkg = shift;
    $map{$pkg} = [];
    while (<$fh>) {
        if (/^$/) {
            $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 UNIVERSAL::Tags : ATTR(CODE)
{
    my (undef, $symbol, $code, undef, $tags) = @_;
    for my $tag (@{$tags}) {
        $::known_tags{$tag} = 1;
    }
    no warnings qw(redefine prototype);
    *{$symbol} = sub {
        local %::visible_tags =
            map { $_ => 1 }
            grep { exists $::visible_tags{$_} }
            @{$tags};
        return $code->(@_) if %::visible_tags;
    }
}

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, "($!)";
                }
            }
        }
    }
}

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

sub check_obsolete_conffiles(@)
: Tags(qw(obsolete-conffile))
{
    my @packages = @_;
    my $pkg;
    open(my $fh, '-|',
        'dpkg-query', '-Wf', '${binary:Package},${Package}\n${Conffiles}\n',
        # 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;
            die unless defined $pkg;
            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;
            }
        }
    }
    for $pkg (@packages) {
        my $files = $pkg2files{$pkg} // [];
        die unless defined $files;
        for my $file (@{$files}) {
            if ($file2obs{$file}) {
                tag $pkg, 'obsolete-conffile', $file;
            }
        }
    }
    close($fh) or die "dpkg-query -W: " . ($! or 'failed');
}

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*$/) {
                    push @result, grep { -f "/usr/lib/$_/os.py" } split(/\s*,\s*/, $1);
                    last;
                }
            }
            close($fh);
        } 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/}) {
                    next file unless $pypy_installed;
                    $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;
            }
        }
    }
}

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',
    'libgnutls-extra.so.26' => 'GPLv3+',
    'libgnutls-openssl.so.27' => 'GPLv3+',
    'libgnutls.so.26' => 'LGPLv3+',
    'libgnutls.so.28' => 'LGPLv3+',
    '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{(.*)/[^/]+$};
    return $realpath if defined $dirs->{$realdir};
}

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,
        );
        open(my $ldconfig, '-|', '/sbin/ldconfig', '-p') or die "ldconfig -p: $!";
        foreach (<$ldconfig>) {
            when (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
            next file unless defined $interesting_dirs{$dir};
            my $on_rootfs = $path =~ m{^/s?bin/\S+$};
            next file unless -f -r $path;
            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;
        }
    }
    my $ldd_pid = open(my $ldd, '-|') // die "can't fork: $!";
    if ($ldd_pid) { # parent
        my $not_dynamic = 0;
        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;
                die "unexpected output from ldd" unless defined $pkg;
            }
            when (m/^\s+not a dynamic executable$/) {
                $not_dynamic = 1;
            }
            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);
                next unless defined $augmented_path;
                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);
                next unless defined $augmented_path;
                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;
                my $lib = $2;
                my $triggering_path = $3;
                my $augmented_path = augmented_path($path, $triggering_path, \%interesting_dirs);
                next unless defined $augmented_path;
                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: $!";
        unless ($? == 0 or ($not_dynamic and not $suspected_error and $? == (1 << 8))) {
            die "ldd -r: failed";
        }
        close $ldd;
    } 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;
        }
    }
    $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;
                die "unexpected output from ldd" unless defined $pkg;
            }
            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;
    } 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) {
        my ($sopaths, $pkg, @tagdata) = @{$license_conflicts{$path}};
        for my $sopath (keys %{$sopaths}) {
            next file if $dependency_licenses{$sopath} == 0;
        }
        tag $pkg, 'incompatible-licenses', @tagdata;
    }
}

sub switch_uid_gid($$)
{
    my ($uid, $gid) = @_;
    return unless defined $uid and defined $gid;
    # 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.)
    $! = 0;
    $( = $gid; die "setting real gid to $gid: $!" if $!;
    $) = "$gid $gid"; die "setting effective gid to $gid: $!" if $!;
    $< = $uid; die "setting real uid to $uid: $!" if $1;
    $> = $uid; die "setting effective uid to $uid: $!" if $!;
    die if $< != $uid;
    die if $> != $uid;
    die if $( ne "$gid $gid";
    die if $) ne "$gid $gid";
    delete $ENV{HOME};
}

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
    exit;
}

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

sub warning($)
{
    say STDERR "adequate: @_";
}

sub info($)
{
    say STDERR "adequate: @_" if 0;
}

my @ARGV_copy = @ARGV;

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

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 (!$opt_all and !@ARGV);
    if (defined $opt_root) {
        chroot($opt_root) or die "chroot $opt_root: $!";
        chdir('/') or die "chdir /: $!";
    }
    process(0, @ARGV);
}
exit(0);

# vim:ts=4 sw=4 et
