#!/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

use Getopt::Long qw(:config auto_help);
use Errno;
use Fcntl qw(:flock);

BEGIN {
    $ENV{'DEBCONF_NOWARNINGS'} = 'yes';
}
use Debconf::Client::ConfModule qw();

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;
        seek($pending_fh, 0, 0);
        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);
    seek($pending_fh, 0, 0);
    for (sort keys %pending) {
        print $pending_fh "$_\n";
    }
    close $pending_fh or die "$pending_path: $!";
    $pending_fh = undef;
}

sub do_apt_preinst()
{
    read_pending();
    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) {
        say STDERR 'adequate 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();
    exit(0);
}

sub do_pending()
{
    read_pending();
    process(keys %pending);
    %pending = ();
    write_pending();
    exit(0);
}

sub do_all()
{
    my @packages = ();
    open(my $fh, '-|', 'dpkg-query', '-Wf', '${binary:Package}\n') or die "dpkg-query -W: $!";
    while (<$fh>) {
        chomp;
        push @packages, $_;
    }
    close($fh) or die "dpkg-query -W: " . ($! or 'failed');
    process(@packages);
    exit(0);
}

my $debconf = 0;
my @debconf_buffer = ();

sub process(@)
{
    my @packages = @_;
    return unless @packages;
    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_bin_sbin_libraries(%file_map);
    check_undefined_symbols(%file_map);
    if ($debconf and @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('high', $t);
        Debconf::Client::ConfModule::title('adequate found packaging bugs');
        Debconf::Client::ConfModule::go();
    }
}

sub tag($$@)
{
    my ($pkg, $tag, @extra) = @_;
    if ($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 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;
        }
        m{^(/.+)$} or next;
        push($map{$pkg}, $1);
    }
    close($fh) or die "dpkg -L: " . ($! or 'failed');
    return %map;
}

sub check_broken_symlinks(%)
{
    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(@)
{
    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(@)
{
    my $pkg;
    open(my $fh, '-|', 'dpkg-query', '-Wf', '${binary:Package}\n${Conffiles}\n', @_) or die "dpkg-query -W: $!";
    while (<$fh>) {
        if (m/^(\S+)$/) {
            $pkg = $1;
        } elsif (m{^ (.*) [0-9a-f]+ obsolete$}) {
            my $file = $1;
            die unless defined $pkg;
            tag $pkg, 'obsolete-conffile', $file;
        }
    }
    close($fh) or die "dpkg-query -W: " . ($! or 'failed');
}

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/lib/pypy/
| usr/lib/debug/usr/sbin/
| usr/lib/pypy/
| usr/sbin/
| usr/share/doc/
| usr/share/jython/
}x;
# Please keep it in sync with lintian4python!

sub check_python_bytecompilation(%)
{
    my %map = @_;
    my @pythons = map { m/(python2[.]\d+)/ } glob('/usr/lib/python2.*/');
file:
    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;
                my $ok = 0;
                for my $python (@pythons) {
                    next file if -f "/usr/lib/$python/dist-packages/${subpath}c";
                    next file if -f "/usr/lib/pymodules/$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:
                next file if
                    $path =~ m{^(/usr/lib/python2[.]\d+)/dist-packages/}
                    and not -f "$1/os.py";
                # Check for PEP-3147 *.pyc repository directories:
                my $pycache = "$dir/__pycache__";
                if (opendir(my $fh, $pycache)) {
                    my @pyc = grep { /^\Q$base.\Ecpython-.+[.]pyc$/ and -f "$pycache/$_" } readdir($fh);
                    next file if @pyc;
                    closedir($fh) or die $!;
                }
                tag $pkg, 'py-file-not-bytecompiled', $path;
            }
        }
    }
}

sub check_bin_sbin_libraries(%)
{
    my %map = @_;
    my @ld_vars = grep { /^LD_/ } keys @ENV;
    delete local @ENV{@ld_vars};
    local $ENV{LC_ALL} = 'C';
    while (my ($pkg, $files) = each %map) {
        file:
        for my $path (@{$files}) {
            next file unless $path =~ m{^/s?bin/.+};
            next file if -l $path;
            next file unless -f $path;
            open (my $ldd, '-|', 'ldd', $path) or die "ldd $path: $!";
            my $not_dynamic = 0;
            foreach (<$ldd>) {
                when (m/^\s+not a dynamic executable$/) {
                    $not_dynamic = 1;
                }
                when (m{=> (/usr/lib/\S+)}) {
                    tag $pkg, 'bin-or-sbin-binary-requires-usr-lib-library', $path, '=>', $1;
                }
            }
            close($ldd) or $not_dynamic or die "ldd $path: " . ($! or 'failed');
        }
    }
}

sub check_undefined_symbols(%)
{
    eval {
        require IPC::Run;
    };
    return if $@;
    my %map = @_;
    my @ld_vars = grep { /^LD_/ } keys @ENV;
    delete local @ENV{@ld_vars};
    local $ENV{LC_ALL} = 'C';
    my $lines;
    IPC::Run::run(['/sbin/ldconfig', '-p'], '>', \$lines) or die "ldconfig -p failed";
    my %interesting_dirs = (
        '/bin' => 1,
        '/sbin' => 1,
        '/usr/bin' => 1,
        '/usr/games' => 1,
        '/usr/sbin' => 1,
    );
    foreach (split /\n/, $lines) {
        when (m{\s[(]libc[^)]+[)]\s+=>\s+(\S+)[/][^/]+$}) {
            $interesting_dirs{$1} = 1;
        }
    }
    while (my ($pkg, $files) = each %map) {
        file:
        for my $path (@{$files}) {
            my ($dir) = $path =~ m{(.*)/[^/]+$};
            next file unless defined $interesting_dirs{$dir};
            next file if -l $path;
            next file unless -f $path;
            my $lines;
            my $ldd_error = IPC::Run::run(['ldd', '-r', $path], '&>', \$lines);
            my $not_dynamic = 0;
            foreach (split /\n/, $lines) {
                when (m/^\s+not a dynamic executable$/) {
                    $not_dynamic = 1;
                }
                when (m/^loader cannot load itself$/) {
                    $not_dynamic = 1;
                }
                when (m/^undefined symbol:\s+(\S+)\s+[(]\Q$path\E[)]$/) {
                    my $symbol = $1;
                    next if $path =~ m/python|py[23]/ and $symbol =~ /^_?Py/;
                    next if $path =~ m/perl/ and $symbol =~ /^(?:Perl|PL)_/;
                    tag $pkg, 'undefined-symbol', $path, '=>', $symbol;
                }
            }
            $ldd_error or $not_dynamic or die "ldd $path: failed";
        }
    }
}

my @ARGV_copy = @ARGV;

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

umask 022;
my $rc = GetOptions(
    'debconf' => \&enable_debconf,
    'apt-preinst' => \&do_apt_preinst,
    'pending' => \&do_pending,
    'all' => \&do_all,
);
if (not $rc) {
    exit(1);
}

=head1 SYNOPSIS

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

=cut

process(@ARGV);
exit(0);

# vim:ts=4 sw=4 et
