#!/usr/bin/perl -w
# {{{ Legal stuff
# Lintian -- Debian package checker
#
# Copyright (C) 1998 Christian Schwarz and Richard Braakman
#
# This program is free software.  It is distributed under the terms of
# the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any
# later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
# }}}

# {{{ libraries and such
use strict;
use warnings;
use autodie;

use Cwd qw(abs_path);
use Getopt::Long();
use List::MoreUtils qw(any);
use POSIX qw(:sys_wait_h);

my $INIT_ROOT;

BEGIN {
    if (not defined($INIT_ROOT)) {
        require File::Basename;
        import File::Basename qw(dirname);
        my $path = abs_path(__FILE__);
        if (not defined($path)) {
            print STDERR "realpath($0) failed: $!\n";
            exit(2);
        }
        # .../lintian.git/frontend/lintian  => .../lintian.git
        $INIT_ROOT = dirname(dirname($path));
    }

    if (-d "$INIT_ROOT/lib") {
        require lib;
        import lib "$INIT_ROOT/lib";
    }
}

# }}}

# {{{ Application Variables

# Environment variables Lintian cares about - the list contains
# the ones that can also be set via the config file
#
# %opt (defined below) will be updated with values of the env
# after parsing cmd-line options.  A given value in %opt is
# updated to use the ENV variable if the one in %opt is undef
# and ENV has a value.
#
# NB: Variables listed here are not always exported.
my @ENV_VARS = (
    # LINTIAN_CFG  - handled manually
    # LINTIAN_ROOT - handled manually
    qw(
      LINTIAN_PROFILE
      LINTIAN_LAB
      TMPDIR
      ));

### "Normal" application variables

# Version number - Is inserted during build with sed, see d/rules
my $LINTIAN_VERSION;
if (not defined($LINTIAN_VERSION)) {
    # For some reason the version above has not been inserted.
    # Most likely this means we are a git clone or an unpacked
    # source package.  If so, we will use a version that best
    # describes our situation...
    my $guess = _guess_version();
    $LINTIAN_VERSION = $guess if $guess;
    # Use a placeholder if we cannot determine our version.
    $LINTIAN_VERSION //= '<VERSION>';
}
my $BANNER = "Lintian v$LINTIAN_VERSION"; #Version Banner - text form

# Variables used to record commandline options
# Commented out variables have "defined" checks somewhere to determine if
# they were set via commandline or environment variables
my $pkg_mode = 'auto';          # auto -- automatically search for
# binary and source pkgs
my $debug = 0;
my $check_everything = 0;       #flag for -a|--all switch
my $lintian_info = 0;           #flag for -i|--info switch
my $ftpmaster_tags = 0;         #flag for -F|--ftp-master-rejects switch
my $allow_root = 0;             #flag for --allow-root switch
my $keep_lab = 0;               #flag for --keep-lab switch

my $no_conf = 0;                #flag for --no-cfg
my %conf_opt;                   #names of options set in the cfg file

my %opt = (                     #hash of some flags from cmd or cfg
    # Init some cmd-line value defaults
);

# The search path - affected by --include-dir X, --[no-]user-dirs
# The LINTIAN_ROOT will be appended last and the user dirs will be
# pre-appended (depending --[no-]user-dirs).
my @search_dirs;
my @restricted_search_dirs;

my $experimental_output_opts;

my @certainties = qw(wild-guess possible certain);
my (@display_level, %display_source, %suppress_tags);
my ($pool, $action, $checks, $check_tags, $dont_check);
my (@unpack_info, $LAB, %extra_unpack, %unpack_options, @auto_remove);
my $exit_code = 0;

# Timer handling (by default to nothing)
my $start_timer = sub { 0; };
my $finish_timer =  sub { ''; };

my $memory_usage = sub { 'N/A'; };

# }}}

# {{{ Setup Code

#turn off file buffering
STDOUT->autoflush;

# Globally ignore SIGPIPE.  We'd rather deal with error returns from write
# than randomly delivered signals.
$SIG{PIPE} = 'IGNORE';

# reset locale definition (necessary for tar)
$ENV{'LC_ALL'} = 'C';
# reset timezone definition (also for tar)
$ENV{'TZ'}     = '';

# When run in some automated ways, Lintian may not have a PATH, but we assume
# we can call standard utilities without their full path.  If PATH is
# completely unset, add something basic.
$ENV{PATH} = '/bin:/usr/bin' unless $ENV{PATH};

# }}}

# {{{ Process Command Line

#######################################
# Subroutines called by various options
# in the options hash below.  These are
# invoked to process the commandline
# options
#######################################
# Display Command Syntax
# Options: -h|--help
sub syntax {
    print "$BANNER\n";
    print <<"EOT-EOT-EOT";
Syntax: lintian [action] [options] [--] [packages] ...
Actions:
    -c, --check               check packages (default action)
    -C X, --check-part X      check only certain aspects
    -F, --ftp-master-rejects  only check for automatic reject tags
    -r, --remove              remove package from the lab
    -R, --remove-lab          remove static lab
    -S, --setup-lab           set up static lab
    -T X, --tags X            only run checks needed for requested tags
    --tags-from-file X        like --tags, but read list from file
    -u, --unpack              only unpack packages in the lab
    -X X, --dont-check-part X don\'t check certain aspects
General options:
    -d, --debug               turn Lintian\'s debug messages ON
    -h, --help                display short help text
    --print-version           print unadorned version number and exit
    -q, --quiet               suppress all informational messages
    -v, --verbose             verbose messages
    -V, --version             display Lintian version and exit
Behaviour options:
    --allow-root              suppress lintian\'s warning when run as root
    --color never/always/auto disable, enable, or enable color for TTY
    --default-display-level   reset the display level to the default
    --display-source X        restrict displayed tags by source
    -E, --display-experimental display "X:" tags (normally suppressed)
    --no-display-experimental suppress "X:" tags
    --fail-on-warnings        return a non-zero exit status if warnings found
    -i, --info                give detailed info about tags
    -I, --display-info        display "I:" tags (normally suppressed)
    --keep-lab                keep lab after run, even if temporary
    -L, --display-level       display tags with the specified level
    -o, --no-override         ignore overrides
    --pedantic                display "P:" tags (normally suppressed)
    --profile X               Use the profile X or use vendor X checks
    --show-overrides          output tags that have been overriden
    --suppress-tags T,...     don\'t show the specified tags
    --suppress-tags-from-file X don\'t show the tags listed in file X
    -U X, --unpack-info X     specify which info should be collected
Configuration options:
    --cfg CONFIGFILE          read CONFIGFILE for configuration
    --no-cfg                  do not read any config files
    --ignore-lintian-env      ignore LINTIAN_* env variables
    --include-dir DIR         include checks, libraries (etc.) from DIR (*)
    -j X, --jobs X            limit the number of parallel unpacking jobs to X
    --lab LABDIR              use LABDIR as permanent laboratory
    --[no-]user-dirs          whether to use files from user directories (*)
Package selection options:
    -a, --all                 process all packages in distribution
    -b, --binary              process only binary packages
    --packages-from-file  X   process the packages in a file (if "-" use stdin)
    -s, --source              process only source packages
    --udeb                    process only udeb packages

Options marked with (*) should be the first options if given at all.
EOT-EOT-EOT

    exit 0;
}

# Display Version Banner
# Options: -V|--version, --print-version
sub banner {
    if ($_[0] eq 'print-version') {
        print "$LINTIAN_VERSION\n";
    } else {
        print "$BANNER\n";
    }
    exit 0;
}

# Record action requested
# Options: -S, -R, -c, -u, -r
sub record_action {
    if ($action) {
        die("too many actions specified: $_[0]");
    }
    $action = "$_[0]";
    return;
}

# Record Parts requested for checking
# Options: -C|--check-part
sub record_check_part {
    if (defined $action and $action eq 'check' and $checks) {
        die('multiple -C or --check-part options not allowed');
    }
    if ($dont_check) {
        die(
            join(q{ },
                'both -C or --check-part and -X',
                'or --dont-check-part options not allowed'));
    }
    if ($action) {
        die("too many actions specified: $_[0]");
    }
    $action = 'check';
    $checks = "$_[1]";
    return;
}

# Record Parts requested for checking
# Options: -T|--tags
sub record_check_tags {
    if (defined $action and $action eq 'check' and $check_tags) {
        die('multiple -T or --tags options not allowed');
    }
    if ($checks) {
        die('both -T or --tags and -C or --check-part options not allowed');
    }
    if ($dont_check) {
        die('both -T or --tags and -X or --dont-check-part options not allowed'
        );
    }
    if ($action) {
        die("too many actions specified: $_[0]");
    }
    $action = 'check';
    $check_tags = "$_[1]";
    return;
}

# Record Parts requested for checking
# Options: --tags-from-file
sub record_check_tags_from_file {
    my ($option, $name) = @_;
    open(my $file, '<', $name);
    my @tags;
    for my $line (<$file>) {
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        next unless $line;
        next if $line =~ /^\#/;
        push(@tags, split(/\s*,\s*/, $line));
    }
    close($file);
    return record_check_tags($option, join(',', @tags));
}

# Record tags that should be suppressed.
# Options: --suppress-tags
sub record_suppress_tags {
    my ($option, $tags) = @_;
    for my $tag (split(/\s*,\s*/, $tags)) {
        $suppress_tags{$tag} = 1;
    }
    return;
}

# Record tags that should be suppressed from a file.
# Options: --suppress-tags-from-file
sub record_suppress_tags_from_file {
    my ($option, $name) = @_;
    open(my $file, '<', $name);
    for my $line (<$file>) {
        chomp $line;
        $line =~ s/^\s+//;
        # Remove trailing white-space/comments
        $line =~ s/(\#.*+|\s+)$//;
        next unless $line;
        record_suppress_tags($option, $line);
    }
    close($file);
    return;
}

# Record Parts requested not to check
# Options: -X|--dont-check-part X
sub record_dont_check_part {
    if (defined $action and $action eq 'check' and $dont_check) {
        die('multiple -X or --dont-check-part options not allowed');
    }
    if ($checks) {
        die(
            join(q{ },
                'both -C or --check-part and',
                '-X or --dont-check-part options not allowed'));
    }
    if ($action) {
        die("too many actions specified: $_[0]");
    }
    $action = 'check';
    $dont_check = "$_[1]";
    return;
}

# Record what type of data is specified
# Options: -b|--binary, -s|--source, --udeb
sub record_pkgmode {
    $pkg_mode = 'binary' if $_[0] eq 'binary';
    $pkg_mode = 'source' if $_[0] eq 'source';
    $pkg_mode = 'udeb' if $_[0] eq 'udeb';
    return;
}

# Process -L|--display-level flag
sub record_display_level {
    my ($option, $level) = @_;
    my ($op, $rel);
    if ($level =~ s/^([+=-])//) {
        $op = $1;
    }
    if ($level =~ s/^([<>]=?|=)//) {
        $rel = $1;
    }
    my ($severity, $certainty) = split('/', $level);
    $op = '=' unless defined $op;
    $rel = '=' unless defined $rel;
    if (not defined $certainty) {
        if (any { $severity eq $_ } @certainties) {
            $certainty = $severity;
            undef $severity;
        }
    }
    push(@display_level, [$op, $rel, $severity, $certainty]);
    return;
}

# Process -I|--display-info flag
sub display_infotags {
    push(@display_level, ['+', '>=', 'wishlist']);
    return;
}

# Process --pedantic flag
sub display_pedantictags {
    push(@display_level, ['+', '=', 'pedantic']);
    return;
}

# Process --default-display-level flag
sub default_display_level {
    push(@display_level,
        ['=', '>=', 'important'],
        ['+', '>=', 'normal', 'possible'],
        ['+', '>=', 'minor', 'certain'],
    );
    return;
}

# Process --display-source flag
sub record_display_source {
    $display_source{$_[1]} = 1;
    return;
}

# Process -q|--quite flag
sub record_quiet {
    $opt{'verbose'} = -1;
    return;
}

{
    my $warned = 0;

    sub warn_late_options {
        print STDERR join(q{ },
            'Warning: --include-dir and --[no-]user-dirs',
            "should be the first option(s) if given\n");
        return;
    }

    # Process --include-dir (late)
    sub record_include_dir_late {
        my (undef, $dir) = @_;
        push(@search_dirs, $dir);
        if (not $warned++) {
            warn_late_options();
        }
        return;
    }

    # Process --[no-]user-dirs (late)
    sub record_user_dirs_late {
        my (undef, $value) = @_;
        $opt{'user-dirs'} = $value;
        if (not $warned++) {
            warn_late_options();
        }
        return;
    }
}

# Process display-info and display-level options in cfg files
#  - dies if display-info and display-level are used together
#  - adds the relevant display level unless the command-line
#    added something to it.
#  - uses @display_level to track cmd-line appearences of
#    --display-level/--display-info
sub cfg_display_level {
    my ($var, $val) = @_;
    if ($var eq 'display-info' or $var eq 'pedantic'){
        die "$var and display-level may not both appear in the config file.\n"
          if $conf_opt{'display-level'};

        return unless $val; # case "display-info=no" (or "pedantic=no")

        # We are only supposed to modify @display_level if it was not
        # set by a command-line option.  However, both display-info
        # and pedantic comes here so we cannot determine this solely
        # by checking if @display_level is empty.  We use
        # "__conf-display-opts" to determine if @display_level was set
        # by a conf option or not.
        return if @display_level && !$conf_opt{'__conf-display-opts'};

        $conf_opt{'__conf-display-opts'} = 1;
        display_infotags() if $var eq 'display-info';
        display_pedantictags() if $var eq 'pedantic';
    } elsif ($var eq 'display-level'){
        foreach my $other (qw(pedantic display-info)) {
            die(
                join(q{ },
                    "$other and display-level may not",
                    "both appear in the config file.\n"))if $conf_opt{$other};
        }

        return if @display_level;
        strip($val);
        foreach my $dl (split m/\s++/, $val) {
            record_display_level('display-level', $dl);
        }
    }
    return;
}

# Processes quiet and verbose options in cfg files.
# - dies if quiet and verbose are used together
# - sets the verbosity level ($opt{'verbose'}) unless
#   already set.
sub cfg_verbosity {
    my ($var, $val) = @_;
    if (   ($var eq 'verbose' && exists $conf_opt{'quiet'})
        || ($var eq 'quiet' && exists $conf_opt{'verbose'})) {
        die "verbose and quiet may not both appear in the config file.\n";
    }
    # quiet = no or verbose = no => no change
    return unless $val;
    # Do not change the value if set by command line.
    return if defined $opt{'verbose'};
    # quiet = yes => verbosity_level = -1
    #
    # technically this allows you to enable verbose by using "quiet =
    # -1" (etc.), but most people will probably not use this
    # "feature".
    $val = -$val if $var eq 'quiet';
    $opt{'verbose'} = $val;
    return;
}

# Process overrides option in the cfg files
sub cfg_override {
    my ($var, $val) = @_;
    return if defined $opt{'no-override'};
    # This option is inverted in the config file
    $opt{'no-override'} = !$val;
    return;
}

# Hash used to process commandline options
my %opthash = (
    # ------------------ actions
    'setup-lab|S' => \&record_action,
    'remove-lab|R' => \&record_action,
    'check|c' => \&record_action,
    'check-part|C=s' => \&record_check_part,
    'tags|T=s' => \&record_check_tags,
    'tags-from-file=s' => \&record_check_tags_from_file,
    'ftp-master-rejects|F' => \$ftpmaster_tags,
    'dont-check-part|X=s' => \&record_dont_check_part,
    'unpack|u' => \&record_action,
    'remove|r' => \&record_action,

    # ------------------ general options
    'help|h' => \&syntax,
    'version|V' => \&banner,
    'print-version' => \&banner,

    'verbose|v' => \$opt{'verbose'},
    'debug|d+' => \$debug, # Count the -d flags
    'quiet|q' => \&record_quiet, # sets $opt{'verbose'} to -1

    # ------------------ behaviour options
    'info|i' => \$opt{'info'},
    'display-info|I' => \&display_infotags,
    'display-experimental|E!' => \$opt{'display-experimental'},
    'pedantic' => \&display_pedantictags,
    'display-level|L=s' => \&record_display_level,
    'default-display-level' => \&default_display_level,
    'display-source=s' => \&record_display_source,
    'suppress-tags=s' => \&record_suppress_tags,
    'suppress-tags-from-file=s' => \&record_suppress_tags_from_file,
    'no-override|o' => \$opt{'no-override'},
    'show-overrides' => \$opt{'show-overrides'},
    'color=s' => \$opt{'color'},
    'unpack-info|U=s' => \@unpack_info,
    'allow-root' => \$allow_root,
    'fail-on-warnings' => \$opt{'fail-on-warnings'},
    'keep-lab' => \$keep_lab,

    # ------------------ configuration options
    'cfg=s' => \$opt{'LINTIAN_CFG'},
    'no-cfg' => \$no_conf,
    'lab=s' => \$opt{'LINTIAN_LAB'},
    'profile=s' => \$opt{'LINTIAN_PROFILE'},
    # (NB: --root is deprecated)
    'root=s' => \$opt{'LINTIAN_ROOT'},

    'jobs|j:i' => \$opt{'jobs'},
    'ignore-lintian-env' => \$opt{'ignore-lintian-env'},
    'include-dir=s' => \&record_include_dir_late,
    'user-dirs!' => \&record_user_dirs_late,

    # ------------------ package selection options
    'all|a' => \$check_everything,
    'binary|b' => \&record_pkgmode,
    'source|s' => \&record_pkgmode,
    'udeb' => \&record_pkgmode,
    'packages-from-file=s' => \$opt{'packages-from-file'},

    # ------------------ experimental
    'exp-output:s' => \$experimental_output_opts,
);

# Options that can appear in the config file
my %cfghash = (
    'color'                => \$opt{'color'},
    'display-experimental' => \$opt{'display-experimental'},
    'display-info'         => \&cfg_display_level,
    'display-level'        => \&cfg_display_level,
    'fail-on-warnings'     => \$opt{'fail-on-warnings'},
    'info'                 => \$opt{'info'},
    'jobs'                 => \$opt{'jobs'},
    'pedantic'             => \&cfg_display_level,
    'quiet'                => \&cfg_verbosity,
    'override'             => \&cfg_override,
    'show-overrides'       => \$opt{'show-overrides'},
    'verbose'              => \&cfg_verbosity,
);

# Parse --include-dir and --[no-]user-dirs early
Getopt::Long::config(
    'bundling', 'no_getopt_compat',
    'no_auto_abbrev', 'require_order',
    'pass_through'
);

Getopt::Long::GetOptions(
    'include-dir=s' => \@search_dirs,
    'user-dirs!' => \$opt{'user-dirs'},
) or die("error parsing options\n");

# init commandline parser
Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev',
    'permute');

# process commandline options
Getopt::Long::GetOptions(%opthash)
  or die("error parsing options\n");

# root permissions?
# check if effective UID is 0
if ($> == 0 and not $allow_root) {
    print STDERR join(q{ },
        'warning: the authors of lintian do not',
        "recommend running it with root privileges!\n");
}

if ($opt{'ignore-lintian-env'}) {
    delete $ENV{$_} for grep { m/^LINTIAN_/ } keys %ENV;
}

# }}}

# {{{ Read important environment

if (defined($opt{'LINTIAN_ROOT'}) or defined($ENV{'LINTIAN_ROOT'})) {
    my $desired_root = $opt{'LINTIAN_ROOT'} // $ENV{'LINTIAN_ROOT'};
    my $ok = 0;
    my $abs = abs_path($desired_root);
    die("Cannot resolve $desired_root: $!\n")
      unless defined($abs);
    $ok = 1 if $abs eq $INIT_ROOT;
    print STDERR "warning: LINTIAN_ROOT/--root is deprecated.\n";
    print STDERR "  Perhaps you wanted --include-dir instead?\n";
    print STDERR "If you are using this option to run lintian from a\n";
    print STDERR "checkout, then Lintian 2.5.18 should just work out\n";
    print STDERR "of the box without this option/ENV variable.\n";
    print STDERR "  (You may want to replace it with --no-user-dirs)\n";

    if (not $ok) {
        print STDERR "Error: Cannot use $desired_root as LINTIAN_ROOT\n";
        print STDERR "  (only valid value is $INIT_ROOT)\n";
        exit(2);
    }
    delete($opt{'LINTIAN_ROOT'});
    # --root/LINTIAN_ROOT used to imply --no-user-dirs unless
    # --user-dirs was explicitly given.  Keep this behaviour as long
    # as we accept --root.
    $opt{'user-dirs'} //= 0;
} else {
    # Enable user dirs by default
    $opt{'user-dirs'} //= 1;
}

# Set LINTIAN_ROOT to the actual root.
$ENV{'LINTIAN_ROOT'} = $INIT_ROOT;

# Filter out non-existent paths and resolve the rest.
# - as we will add them to @INC, make sure they are resolved
#   so a check doing a chdir will not suddently load anything
#   differently.
@search_dirs = map {
    if (-d $_) {
        my $resolved = abs_path($_);
        unless (defined $resolved) {
            print STDERR "Cannot resolve $_: $!\n";
            exit 2;
        }
        ($resolved);
    } else {
        ();
    }
} @search_dirs;

if ($opt{'user-dirs'} and not $ENV{'LINTIAN_INTERNAL_TESTSUITE'}){
    # Pre-append the user part of the search dirs.

    unshift @restricted_search_dirs, '/etc/lintian';

    # In some (rare) cases, $ENV{HOME} will not be available.
    # - Handle that gracefully by not emitting "Uninitialized ...".
    unshift @restricted_search_dirs, "$ENV{HOME}/.lintian"
      if defined $ENV{HOME};
}

# environment variables overwrite settings in conf file, so load them now
# assuming they were not set by cmd-line options
foreach my $var (@ENV_VARS) {
    # note $opt{$var} will usually always exists due to the call to GetOptions
    # so we have to use "defined" here
    $opt{$var} = $ENV{$var} if $ENV{$var} && !defined $opt{$var};
}

# }}}

# {{{ Sanity check command-line options (that are unaffected by the configuration file)

# option --all and packages specified at the same time?
if (($check_everything or $opt{'packages-from-file'}) and $#ARGV+1 > 0) {
    print STDERR join(q{ },
        'warning: options -a and --packages-from-file',
        "cannot be mixed with package parameters!\n");
    print STDERR "(will ignore -a or/and --packages-from-file option)\n";
    undef $check_everything;
    delete $opt{'packages-from-file'};
}

# check specified action
$action = 'check' unless $action;

# check for arguments
if (    $action =~ /^(?:check|unpack|remove)$/
    and $#ARGV == -1
    and not $check_everything
    and not $opt{'packages-from-file'}) {
    my $ok = 0;
    if ($action eq 'check' or $action eq 'unpack') {
        # If debian/changelog exists, assume an implied
        # "../<source>_<version>_<arch>.changes" (or
        # "../<source>_<version>_source.changes").
        if (-f 'debian/changelog') {
            my $file = _find_changes();
            push @ARGV, $file;
            $ok = 1;
        }
    }
    syntax() unless $ok;
}

die "Cannot use profile together with --ftp-master-rejects.\n"
  if $opt{'LINTIAN_PROFILE'} and $ftpmaster_tags;
# --ftp-master-rejects is implemented in a profile
$opt{'LINTIAN_PROFILE'} = 'debian/ftp-master-auto-reject' if $ftpmaster_tags;

# }}}

# {{{ Loading lintian's own libraries, parse config file and setup output

# Include (only existsing) lib directories from @search_dirs in @INC
# and LINTIAN_{INCLUDE,HELPER}_DIRS.
# NB: Add INIT_ROOT to @search_dirs after updating @INC as we already
# added it in BEGIN{} if needed.
unshift @INC, grep { -d } map { "$_/lib" } @search_dirs;

push(@search_dirs, $INIT_ROOT);

$ENV{'LINTIAN_INCLUDE_DIRS'} = join(':', grep { -d } @search_dirs);
$ENV{'LINTIAN_HELPER_DIRS'}
  = join(':',grep { -d } map { "$_/helpers" } @search_dirs);

require Lintian::Lab;

require Lintian::DepMap;
require Lintian::DepMap::Properties;
require Lintian::Data;
require Lintian::Output;
import Lintian::Output qw(:messages);
require Lintian::Internal::FrontendUtil;
import Lintian::Internal::FrontendUtil qw(default_parallel load_collections);
require Lintian::ProcessablePool;
require Lintian::Profile;
require Lintian::Tags;
import Lintian::Tags qw(tag);
require Lintian::Unpacker;
require Lintian::Util;
import Lintian::Util qw(fail parse_boolean strip);

if (defined $experimental_output_opts) {
    my %opts = map { split(/=/) } split(/,/, $experimental_output_opts);
    foreach (keys %opts) {
        if ($_ eq 'format') {
            if ($opts{$_} eq 'colons') {
                require Lintian::Output::ColonSeparated;
                $Lintian::Output::GLOBAL= Lintian::Output::ColonSeparated->new;
            } elsif ($opts{$_} eq 'letterqualifier') {
                require Lintian::Output::LetterQualifier;
                $Lintian::Output::GLOBAL
                  = Lintian::Output::LetterQualifier->new;
            } elsif ($opts{$_} eq 'xml') {
                require Lintian::Output::XML;
                $Lintian::Output::GLOBAL = Lintian::Output::XML->new;
            } elsif ($opts{$_} eq 'fullewi') {
                require Lintian::Output::FullEWI;
                $Lintian::Output::GLOBAL = Lintian::Output::FullEWI->new;
            }
        }
    }
}

# search for configuration file if it was not set with --cfg
# do not search the default locations if it was set.
unless ($no_conf) {
    if (not $opt{'LINTIAN_CFG'}) {
        $opt{'LINTIAN_CFG'} = _find_cfg_file() // '';
    }
} else {
    $opt{'LINTIAN_CFG'} = '';
}

# read configuration file
if ($opt{'LINTIAN_CFG'}) {
    open(my $fd, '<', $opt{'LINTIAN_CFG'});
    while (<$fd>) {
        chop;
        s/\#.*$//go;
        s/\"//go;
        next if m/^\s*$/o;

        # substitute some special variables
        s,\$HOME/,$ENV{'HOME'}/,go;
        s,\~/,$ENV{'HOME'}/,go;

        my $found = 0;
        foreach my $var (@ENV_VARS) {
            if (m/^\s*$var\s*=\s*(.*\S)\s*$/i) {
                if (exists $conf_opt{$var}){
                    print STDERR
                      "Configuration variable $var appears more than once\n";
                    print STDERR " in $opt{'LINTIAN_CFG'} (line: $.)",
                      " - Using the first value!\n";
                    next;
                }
                $opt{$var} = $1 unless defined $opt{$var};
                $conf_opt{$var} = 1;
                $found = 1;
                last;
            }
        }
        unless ($found) {
            # check if it is a config option
            if (m/^\s*([-a-z]+)\s*=\s*(.*\S)\s*$/o){
                my ($var, $val) = ($1, $2);
                my $ref = $cfghash{$var};
                die "Unknown configuration variable $var at line: ${.}.\n"
                  unless $ref;
                if (exists $conf_opt{$var}){
                    print STDERR
                      "Configuration variable $var appears more than once\n";
                    print STDERR " in $opt{'LINTIAN_CFG'} (line: $.)",
                      " - Using the first value!\n";
                    next;
                }
                $conf_opt{$var} = 1;
                $found = 1;
                # Translate boolean strings to "0" or "1"; ignore
                # errors as not all values are (intended to be)
                # booleans.
                eval { $val = parse_boolean($val); };
                if (ref $ref eq 'SCALAR'){
                    # Check it was already set
                    next if defined $$ref;
                    $$ref = $val;
                } elsif (ref $ref eq 'CODE'){
                    $ref->($var, $val);
                }

            }
        }
        unless ($found) {
            die "syntax error in configuration file: $_\n";
        }
    }
    close($fd);
}

# check permitted values for --color / color
#  - We set the default to 'auto' here; because we cannot do
#    it before the config check.
$opt{'color'} = 'auto' unless defined $opt{'color'};
if ($opt{'color'} and $opt{'color'} !~ /^(?:never|always|auto|html)$/) {
    die join(q{ },
        'The color value must be one of',
        "\"never\", \"always\", \"auto\" or \"html\"\n");
}

# We do this manually since the above would set $ENV{TMPDIR} to ''
# if it was undef and that causes tempdir to give us some "funny"
# (read: broken) paths.
$ENV{'TMPDIR'} = $opt{'TMPDIR'} if defined $opt{'TMPDIR'};

if ($debug) {
    $opt{'verbose'} = 1;
    $ENV{'LINTIAN_DEBUG'} = $debug;
    if ($debug > 1) {
        eval {
            require Time::HiRes;
            import Time::HiRes qw(gettimeofday tv_interval);

            $start_timer = sub {
                return [gettimeofday()];
            };
            $finish_timer =  sub {
                my ($start) = @_;
                my $diff = tv_interval($start);
                return sprintf(' (%.3fs)', $diff);
            };
            print "N: Using Time::HiRes to debug running times\n";
        };
        if ($@) {
            print "N: Cannot load Time::HiRes ($@)\n";
            print "N: Running times will not be timed.\n";
        }
        if ($debug > 2) {
            eval {
                require Devel::Size;
                import Devel::Size qw(total_size);
                {
                    no warnings qw(once);
                    # Disable warnings about stuff Devel::Size cannot
                    # give reliable sizes for.
                    $Devel::Size::warn = 0;
                }

                $memory_usage = sub {
                    my ($obj) = @_;
                    my $size = total_size($obj);
                    my $unit = 'B';
                    if ($size > 1536) {
                        $size /= 1024;
                        $unit = 'kB';
                        if ($size > 1536) {
                            $size /= 1024;
                            $unit = 'MB';
                        }
                    }
                    return sprintf('%.2f %s', $size, $unit);
                };
                print "N: Using Devel::Size to debug memory usage\n";
            };
            if ($@) {
                print "N: Cannot load Devel::Size ($@)\n";
                print "N: Running memory usage will not be checked.\n";
            }
        }
    }
} else {
    # Ensure verbose has a defined value
    $opt{'verbose'} = 0 unless defined $opt{'verbose'};
}

$Lintian::Output::GLOBAL->verbosity_level($opt{'verbose'});
$Lintian::Output::GLOBAL->debug($debug);
$Lintian::Output::GLOBAL->color($opt{'color'});
$Lintian::Output::GLOBAL->showdescription($opt{'info'});

# }}}

# {{{ Load profile, setup display setting etc.

# Print Debug banner, now that we're finished determining
# the values and have Lintian::Output available
debug_msg(
    1,
    $BANNER,
    "Lintian root directory: $INIT_ROOT",
    "Configuration file: $opt{'LINTIAN_CFG'}",
    'Laboratory: ' . ($opt{'LINTIAN_LAB'} // '<N/A>'),
    delimiter(),
);

my $PROFILE;
our $TAGS = Lintian::Tags->new;
$TAGS->show_experimental($opt{'display-experimental'});
$TAGS->show_overrides($opt{'show-overrides'});
$TAGS->sources(keys %display_source) if %display_source;

$PROFILE
  = Lintian::Profile->new($opt{'LINTIAN_PROFILE'},\@search_dirs,
    { 'restricted-search-dirs' => \@restricted_search_dirs },
  );
# Ensure $opt{'LINTIAN_PROFILE'} is defined
$opt{'LINTIAN_PROFILE'} = $PROFILE->name
  unless defined $opt{'LINTIAN_PROFILE'};
v_msg('Using profile ' . $PROFILE->name . '.');

if ($dont_check || %suppress_tags || $checks || $check_tags) {
    _update_profile($PROFILE, $dont_check, \%suppress_tags, $checks,
        $check_tags);
}

$TAGS->profile($PROFILE);
Lintian::Data->set_vendor($PROFILE);

# Initialize display level settings.
for my $level (@display_level) {
    eval { $TAGS->display(@$level) };
    if ($@) {
        my $error = $@;
        $error =~ s/ at .*//;
        die $error, "\n";
    }
}

# }}}

# {{{ Set up clean-up handlers.

$SIG{'INT'} = \&interrupted;
$SIG{'QUIT'} = \&interrupted;

# }}}

# {{{ Create/Maintain Lab and add any specified Debian Archives (*.debs)

$LAB = Lintian::Lab->new($opt{'LINTIAN_LAB'});

#######################################
# Process -S option
if ($action eq 'setup-lab') {
    if ($#ARGV+1 > 0) {
        warning('ignoring additional command line arguments');
    }

    $LAB->create
      or fail('There was an error while setting up the static lab.');

    exit 0;

#######################################
    # Process -R option
} elsif ($action eq 'remove-lab') {
    if ($#ARGV+1 > 0) {
        warning('ignoring additional command line arguments');
    }

    $LAB->remove
      or fail('There was an error while removing the static lab.');

    exit 0;

#######################################
    #  Check for non deb specific actions
} elsif (
    not(   ($action eq 'unpack')
        or ($action eq 'check')
        or ($action eq 'remove'))
  ) {
    fail("bad action $action specified");
}

if (!$LAB->is_temp) {
    # sanity check:
    fail(
        join(q{ },
            'lintian lab has not been set up correctly',
            '(perhaps you forgot to run lintian --setup-lab?)')
    ) unless $LAB->exists;
} else {
    $LAB->create({'keep-lab' => $keep_lab});
}

$LAB->open;

#  Update the ENV var as well - unlike the original values,
#  $LAB->dir is always absolute
$ENV{'LINTIAN_LAB'} = $opt{'LINTIAN_LAB'} = $LAB->dir;

v_msg("Setting up lab in $opt{'LINTIAN_LAB'} ...")
  if $LAB->is_temp;

# }}}

# {{{ Compile list of files to process

$pool = Lintian::ProcessablePool->new($LAB);
# process package/file arguments

while (my $arg = shift) {
    # file?
    if (-f $arg) {
        if ($arg =~ m/\.(?:u?deb|dsc|changes)$/o){
            eval {$pool->add_file($arg);};
            if ($@) {
                print STDERR "Skipping $arg: $@";
                $exit_code = 2;
            }
        } else {
            fail(
                join(q{ },
                    "bad package file name $arg",
                    '(neither .deb, .udeb, .changes or .dsc file)'));
        }
    } else {
        # parameter is a package name--so look it up
        handle_lab_query($arg);
    }
}

if ($check_everything) {
    my $t = $pkg_mode;
    my $visitor = sub {
        my ($lpkg) = @_;
        $pool->add_proc($lpkg);
    };
    $t = undef if $pkg_mode eq 'auto';
    $LAB->visit_packages($visitor, $t);
} elsif ($opt{'packages-from-file'}){
    my $fd;
    if ($opt{'packages-from-file'} eq '-') {
        $fd = \*STDIN;
    } else {
        open($fd, '<', $opt{'packages-from-file'});
    }
    while (my $file = <$fd>) {
        chomp $file;
        if ($file =~ m/^!query:\s*(\S(?:.*\S)?)/o) {
            my $query = $1;
            handle_lab_query($query);
        } else {
            $pool->add_file($file);
        }
    }
    # close unless it is STDIN (else we will see a lot of warnings
    # about STDIN being reopened as "output only")
    close($fd) unless $opt{'packages-from-file'} eq '-';
}

# }}}

# {{{ Some silent exit
if ($pool->empty()) {
    v_msg('No packages selected.');
    exit $exit_code;
}
# }}}

# {{{ Handle $action eq 'remove'
# We have enough information to handle remove now.

if ($action eq 'remove') {
    # Handle remove here - makes the unpack/check loop simpler.
    foreach my $group ($pool->get_groups()){
        foreach my $lpkg ($group->get_processables()){

            $TAGS->file_start($lpkg);

            unless ($lpkg->remove) {
                my $pkg_name = $lpkg->pkg_name();
                warning("cannot remove entry for $pkg_name: $!");
                $exit_code = 2;
            }
        }
    }
    $TAGS->file_end();
    # Write the lab state to the disk, so it remembers they are gone.
    $LAB->close;
    exit $exit_code;
}
# }}}

# {{{ Load information about collector scripts

# $map is just here to check that all the needed collections are present.
my $map = Lintian::DepMap->new();
my @scripts = sort $PROFILE->scripts;
my $collmap = Lintian::DepMap::Properties->new();

{
    my $load_coll = sub {
        my ($cs) = @_;
        my $coll = $cs->name;
        debug_msg(2, "Read collector description for $coll ...");
        $collmap->add($coll, $cs->needs_info, $cs);
        $map->addp('coll-' . $coll, 'coll-', $cs->needs_info);
        push @auto_remove, $coll if $cs->auto_remove;
    };

    load_collections($load_coll, "$INIT_ROOT/collection");
}

for my $c (@scripts) {
    # Add the checks with their dependency information
    my $cs = $PROFILE->get_script($c);
    $map->add('check-' . $c);
    if ($cs->needs_info) {
        $map->addp('check-' . $c, 'coll-', $cs->needs_info);
    }
}

# Make sure the resolver is in a sane state:
scalar($map->missing) == 0
  or
  fail('There are missing nodes on the resolver: '. join(', ', $map->missing));
undef $map;

# }}}

# {{{ determine which info is needed by the collection scripts
if ($action eq 'check') {

    # For overrides we need "overrride-file" as well
    unless ($opt{'no-override'}) {
        $extra_unpack{'override-file'} = 1;
    }
    # For checking, pass a profile to the unpacker to limit what it
    # unpacks.
    $unpack_options{'profile'} = $PROFILE;
    $unpack_options{'extra-coll'} = \%extra_unpack;
} else {
    # With --unpack we want all of them.  That's the default so,
    # "done!"
    1;
}

if (@unpack_info) {
    # Add collections specifically requested by the user (--unpack-info)
    for my $i (map { split m/,/ } @unpack_info) {
        unless ($collmap->getp($i)) {
            fail("unknown info specified: $i");
        }
        $extra_unpack{$i} = 1;
    }
    # Never auto-remove anything explicitly requested by the user
    @auto_remove = grep { !exists $extra_unpack{$_} } @auto_remove
      if not $keep_lab;
}
# Never auto-remove anything if $keep_lab is set...
@auto_remove = () if $keep_lab;

# }}}

# {{{ Okay, now really processing the packages in one huge loop
$opt{'jobs'} = default_parallel() unless defined $opt{'jobs'};
$unpack_options{'jobs'} = $opt{'jobs'};

# Filter out the "lintian" check if present - it does no real harm,
# but it adds a bit of noise in the debug output.
@scripts = grep { $_ ne 'lintian' } @scripts;

debug_msg(
    1,
    "Selected action: $action",
    sprintf('Extra data to collect: %s', join(',',sort keys %extra_unpack)),
    sprintf('Selected checks: %s', join(',', @scripts)),
    "Parallelization limit: $opt{'jobs'}",
);

# Now action is always either "check" or "unpack"
# these two variables are used by process_package
#  and need to persist between invocations.
my $unpacker = Lintian::Unpacker->new($collmap, \%unpack_options);
my %overrides;

if ($action eq 'check') {
    # Ensure all checks can actually be loaded...
    foreach my $script (@scripts) {
        my $cs = $PROFILE->get_script($script);
        eval {$cs->load_check;};
        if ($@) {
            warning("Cannot load check \"$script\"");
            print STDERR $@;
            exit 2;
        }
    }
}

foreach my $gname (sort $pool->get_group_names()) {
    my $group = $pool->get_group($gname);
    unpack_group($gname, $group);
    if ($action eq 'check'){
        process_group($group);
        $group->clear_cache;
        # Double check that no processes are running;  hopefully
        # it will catch regressions like 3bbcc3b earlier.
        fail('Unreaped processes after running checks!?')
          if waitpid(-1, WNOHANG) != -1;
    }
}

# Write the lab state to the disk, so it remembers the new packages
$LAB->close;

if (    $action eq 'check'
    and not $opt{'no-override'}
    and not $opt{'show-overrides'}) {
    my $errors = $overrides{errors} || 0;
    my $warnings = $overrides{warnings} || 0;
    my $info = $overrides{info} || 0;
    my $total = $errors + $warnings + $info;
    if ($total > 0) {
        my $text
          = ($total == 1)
          ? "$total tag overridden"
          : "$total tags overridden";
        my @output;
        if ($errors) {
            push(@output, ($errors == 1) ? "$errors error" : "$errors errors");
        }
        if ($warnings) {
            push(@output,
                ($warnings == 1) ? "$warnings warning" : "$warnings warnings");
        }
        if ($info) {
            push(@output, "$info info");
        }
        msg("$text (". join(', ', @output). ')');
    }
}

my $ign_over = $TAGS->ignored_overrides;
if (keys %$ign_over) {
    msg(
        join(q{ },
            'Some overrides were ignored,',
            'since the tags were marked "non-overridable".'));
    if ($opt{'verbose'}) {
        v_msg(
            join(q{ },
                'The following tags were "non-overridable"',
                'and had at least one override'));
        foreach my $tag (sort keys %$ign_over) {
            v_msg("  - $tag");
        }
    } else {
        msg('Use --verbose for more information.');
    }
}

# }}}

# Wait for any remaining jobs - There will usually not be any
# unless we had an issue examining the last package.  We patiently wait
# for them here; if the user cannot be bothered to wait, he/she can send
# us a signal and the END handler will kill any remaining jobs.
$unpacker->wait_for_jobs;

exit $exit_code;

# {{{ Some subroutines

# Removes all collections with "Auto-Remove: yes"; takes a Lab::Package
#  - depends on global variables %collection_info and %extra_unpack
#
sub auto_clean_package {
    my ($lpkg) = @_;
    my $pkg_name = $lpkg->pkg_name();
    my $pkg_type = $lpkg->pkg_type();
    my $base = $lpkg->base_dir();
    my $changed = 0;
    for my $coll (@auto_remove) {
        my $ci = $collmap->getp($coll);
        next unless $lpkg->is_coll_finished($coll, $ci->version);
        debug_msg(1, "Auto removing: $coll ...");
        $changed = 1;
        eval {$ci->collect($pkg_name, "remove-${pkg_type}", $base);};
        if ($@) {
            warning(
                $@,
                "removing collect info $coll about package $pkg_name failed",
                "skipping cleanup of $pkg_type package $pkg_name"
            );
            return -1;
        }
        $lpkg->_clear_coll_status($coll);
    }
    return $changed;
}

sub post_pkg_process_overrides{
    my ($lpkg) = @_;

    # Report override statistics.
    if (not $opt{'no-override'} and not $opt{'show-overrides'}) {
        my $stats = $TAGS->statistics($lpkg);
        my $errors = $stats->{overrides}{types}{E} || 0;
        my $warnings = $stats->{overrides}{types}{W} || 0;
        my $info = $stats->{overrides}{types}{I} || 0;
        $overrides{errors} += $errors;
        $overrides{warnings} += $warnings;
        $overrides{info} += $info;
    }
    return;
}

sub prep_unpack_error {
    my ($group, $lpkg) = @_;
    my $err = $!;
    my $pkg_type = $lpkg->pkg_type;
    my $pkg_name = $lpkg->pkg_name;
    warning(
        "could not create the package entry in the lab: $err",
        "skipping $action of $pkg_type package $pkg_name"
    );
    $exit_code = 2;
    $group->remove_processable($lpkg);
    return;
}

sub unpack_group {
    my ($gname, $group) = @_;
    my $errhandler = sub { prep_unpack_error($group, @_) };

    # Kill pending jobs, if any
    $unpacker->kill_jobs;
    $unpacker->reset_worklist;

    # Stop here if there is nothing list for us to do
    return
      unless $unpacker->prepare_tasks($errhandler, $group->get_processables);

    v_msg("Unpacking packages in group $gname");

    my %timers = ();
    my %hooks = (
        'coll-hook' => sub { coll_hook($group, \%timers, @_); },
        'finish-hook' => \&finish_hook,
    );

    $unpacker->process_tasks(\%hooks);
    return;
}

sub finish_hook {
    my ($lpkg, $state, $changed) = @_;
    if ($state eq 'sf-error') {
        # The status file could not be written; give a warning.
        my $err = $!;
        my $pkg_name = $lpkg->pkg_name;
        warning("could not create status file for package $pkg_name: $err");
    } elsif ($state eq 'unchanged' or $state eq 'changed') {
        # If we are only unpacking stuff, auto-remove colls
        # immediately.
        if ($action ne 'check' and @auto_remove) {
            # we are done now - start auto-cleaning
            my $ret = auto_clean_package($lpkg);
            # We don't have to remove it from the group if it
            # fails as we are pretty much done.
            $exit_code = 2 if $ret < 0;
            $changed->() if $ret;
        }
    }
    return;
}

sub coll_hook {
    my ($group, $timers, $lpkg, $event, $cs, $pid, $exitval) = @_;
    my $coll = $cs->name;
    my $procid = $lpkg->identifier;

    if ($event eq 'start') {
        if ($pid < 0) {
            # failed
            my $pkg_name = $lpkg->pkg_name;
            my $pkg_type = $lpkg->pkg_type;
            warning(
                "collect info $coll about package $pkg_name failed",
                "skipping $action of $pkg_type package $pkg_name"
            );
            $exit_code = 2;
            $group->remove_processable($lpkg);
        } else {
            # Success
            $timers->{$pid} = $start_timer->();
            debug_msg(1, "Collecting info: $coll for $procid ...");
        }
    } elsif ($event eq 'finish') {
        if ($exitval) {
            # Failed
            my $pkg_name  = $lpkg->pkg_name;
            my $pkg_type = $lpkg->pkg_type;
            warning("collect info $coll about package $pkg_name failed");
            warning("skipping $action of $pkg_type package $pkg_name");
            $exit_code = 2;
            $group->remove_processable($lpkg);
        } else {
            # success
            my $tres = $finish_timer->($timers->{$pid});
            debug_msg(1, "Collection script $coll for $procid done$tres");
        }
    }
    return;
}

sub process_group {
    my ($group) = @_;
  PROC:
    foreach my $lpkg ($group->get_processables){
        my $pkg_name = $lpkg->pkg_name;
        my $pkg_type = $lpkg->pkg_type;
        my $base = $lpkg->base_dir();

        $TAGS->file_start($lpkg);

        debug_msg(1, "Base directory in lab: $base");

        if (not $opt{'no-override'} and $collmap->getp('override-file')) {
            debug_msg(1, 'Loading overrides file (if any) ...');
            $TAGS->load_overrides;
        }
        foreach my $script (@scripts) {
            my $cs = $PROFILE->get_script($script);
            my $check = $cs->name;
            my $timer = $start_timer->();

            # The lintian check is done by this frontend and we
            # also skip the check if it is not for this type of
            # package.
            next if !$cs->is_check_type($pkg_type);

            debug_msg(1, "Running check: $check ...");
            eval {$cs->run_check($lpkg, $group);};
            my $err = $@;
            my $tres = $finish_timer->($timer);
            if ($err) {
                print STDERR $err;
                print STDERR "internal error: cannot run $check check",
                  " on package $pkg_name\n";
                warning("skipping $action of $pkg_type package $pkg_name");
                $exit_code = 2;
                next PROC;
            }
            debug_msg(1, "Finished check: $check$tres");
        }

        unless ($exit_code) {
            my $stats = $TAGS->statistics($lpkg);
            if ($stats->{types}{E}) {
                $exit_code = 1;
            } elsif ($opt{'fail-on-warnings'} && $stats->{types}{W}) {
                $exit_code = 1;
            }
        }
        post_pkg_process_overrides($lpkg);
    } # end foreach my $lpkg ($group->get_processable)

    $TAGS->file_end;

    if ($debug > 2) {
        for my $lpkg ($group->get_processables) {
            my $id = $lpkg->identifier;
            my $usage = $memory_usage->($lpkg->info);
            my $breakdown = $lpkg->info->_memory_usage($memory_usage);
            debug_msg(3, "Memory usage [$id]: $usage");
            for my $field (sort(keys(%{$breakdown}))) {
                debug_msg(4, "  -- $field: $breakdown->{$field}");
            }
        }
    }

    if (@auto_remove) {
        # Invoke auto-clean now that the group has been checked
        foreach my $lpkg ($group->get_processables){
            my $ret = auto_clean_package($lpkg);
            $exit_code = 2 if $ret < 0;
            if ($ret) {
                # Update the status file as auto_clean_package may
                # have removed some collections
                unless ($lpkg->update_status_file) {
                    my $pkg_name = $lpkg->pkg_name;
                    warning(
                        join(q{ },
                            'could not create status',
                            "file for package $pkg_name: $!"));
                }
            }
        }

    }

    return 1;
}

sub handle_lab_query {
    my ($query) = @_;
    my @res;
    my $type = undef;
    my ($pkg, $version, $arch);
    my $orig = $query; # Save for the error message later

    # "britney"-like format - note this catches the old style, where
    # only the package name was specified.
    # Check if it starts with a type specifier
    # (e.g. "binary:" in "binary:eclipse/3.5.2-1/amd64")
    if ($query =~ m,^([a-z]+):(.*),i) {
        ($type, $query) = ($1, $2);
    }
    # Split on /
    ($pkg, $version, $arch) = split m,/,o, $query, 3;
    if (   $pkg =~ m|^\.{0,2}$|
        or $pkg =~ m,[_:],
        or (defined $arch and $arch =~ m,/,)) {
        # Technically, a string like "../somewhere/else",
        # "somepkg_version_arch.deb", "/somewhere/somepkg.deb" or even
        # "http://ftp.debian.org/pool/l/lintian/lintian_2.5.5_all.deb"
        # could match the above.  Obviously, that is not a lab query.
        # But the frontend sends it here, because the file denoted by
        # that string does not exist.
        warning("\"$orig\" cannot be processed.");
        warning('It is not a valid lab query and it is not an existing file.');
        exit 2;
    }

    if (not defined $type and $pkg_mode ne 'auto') {
        # No type specified and "auto" is not the default so we
        # pre-append the default type.
        $query = "$pkg_mode:$query";
        $type = $pkg_mode;
    } else {
        # Type specified or no type and "auto" being the default.  In
        # this case we just process the original query.
        $query = $orig;
    }

    eval {@res = $LAB->lab_query($query);};
    if (my $err = $@) {
        $err =~ s/ at .*? line \d+\s*$//;
        warning("Bad lab-query: $orig");
        warning("Error: $err");
        $exit_code = 2;
        return ();
    }

    if (@res) {
        foreach my $p (@res) {
            $pool->add_proc($p);
        }
    } else {
        my $tuple = join(', ', map { $_//'*'} ($type, $pkg, $version, $arch));
        debug_msg(
            1,
            "Did not find a match for $orig (pkg_mode = $pkg_mode)",
            " - Search tuple: ($tuple)"
        );
        warning(
            join(q{ },
                'cannot find binary, udeb or source package',
                "$orig in lab (skipping)"));
        $exit_code = 2;
    }
    return;
}

sub _find_cfg_file {
    return $ENV{'LINTIAN_CFG'}
      if exists $ENV{'LINTIAN_CFG'} and -f $ENV{'LINTIAN_CFG'};

    if ($opt{'user-dirs'}) {
        my $rcfile;
        {
            # File::BaseDir sprews warnings if $ENV{'HOME'} is undef, so
            # make sure it is defined when we load the module.  Though,
            # we need to scope this, so $ENV{HOME} becomes undef again
            # when we check for it later.
            local $ENV{'HOME'} = $ENV{'HOME'} // '/nonexistent';
            require File::BaseDir;
            import File::BaseDir qw(config_home config_files);
        };
        # only accept config_home if either HOME or
        # XDG_CONFIG_HOME was set.  If both are unset, then this
        # will return the "bogus" path
        # "/nonexistent/lintian/lintianrc" and we don't want that
        # (in the however unlikely case that file actually
        # exists).
        $rcfile = config_home('lintian/lintianrc')
          if exists $ENV{'HOME'}
          or exists $ENV{'XDG_CONFIG_HOME'};
        return $rcfile if defined $rcfile and -f $rcfile;
        if (exists $ENV{'HOME'}) {
            $rcfile = $ENV{'HOME'} . '/.lintianrc';
            return $rcfile if -f $rcfile;
        }
        return '/etc/lintianrc' if -f '/etc/lintianrc';
        # config_files checks that the file exists for us
        $rcfile = config_files('lintian/lintianrc');
        return $rcfile if defined $rcfile and $rcfile ne '';

    }

    return; # None found
}

sub _find_changes {
    require Parse::DebianChangelog;
    my $dch = Parse::DebianChangelog->init(
        { infile => 'debian/changelog', quiet => 1 });
    my $data = $dch->data;
    my $last = $data ? $data->[0] : undef;
    my ($source, $version);
    my $changes;
    my @archs;
    my @dirs = ('..', '../build-area', '/var/cache/pbuilder/result');

    if (not $last) {
        my @errors = $dch->get_parse_errors;
        if (@errors) {
            print STDERR "Cannot parse debian/changelog due to errors:\n";
            for my $error (@errors) {
                print STDERR "$error->[2] (line $error->[1])\n";
            }
        } else {
            print STDERR "debian/changelog does not have any data?\n";
        }
        exit 2;
    }
    $version = $last->Version;
    $source = $last->Source;
    if (not defined $version or not defined $source) {
        $version//='<N/A>';
        $source//='<N/A>';
        print STDERR
          "Cannot determine source and version from debian/changelog:\n";
        print STDERR "Source: $source\n";
        print STDERR "Version: $source\n";
        exit 2;
    }
    # remove the epoch
    $version =~ s/^\d+://;
    if (exists $ENV{'DEB_BUILD_ARCH'}) {
        push @archs, $ENV{'DEB_BUILD_ARCH'};
    } else {
        chomp(my $arch = `dpkg --print-architecture 2>/dev/null`);
        push @archs, $arch if $arch ne '';
    }
    push @archs, $ENV{'DEB_HOST_ARCH'} if exists $ENV{'DEB_HOST_ARCH'};
    if (system('dpkg', '--assert-multi-arch') == 0) {
        # Maybe cross-built for something dpkg knows about...
        open(my $foreign, '-|', 'dpkg', '--print-foreign-architectures');
        while (my $line = <$foreign>) {
            chomp $line;
            # Skip already attempted architectures (e.g. via DEB_BUILD_ARCH)
            next if any { $_ eq $line } @archs;
            push @archs, $line;
        }
        close($foreign);
    }
    push @archs, qw(multi all source);
    foreach my $dir (@dirs) {
        foreach my $arch (@archs) {
            $changes = "$dir/${source}_${version}_${arch}.changes";
            return $changes if -f $changes;
        }
    }
    print STDERR "Cannot find changes file for ${source}/${version}, tried:\n";
    foreach my $arch (@archs) {
        print STDERR "  ${source}_${version}_${arch}.changes\n";
    }
    print STDERR " in the following dirs:\n";
    print STDERR '  ', join("\n  ", @dirs), "\n";
    exit 0;
}

sub _guess_version {
    my $guess;

    if (-d "$INIT_ROOT/.git") {
        # Lets try git
        eval {
            # Disabling IPC::Run::Debug saves tons of useless calls.
            $ENV{'IPCRUNDEBUG'} = 'none'
              unless exists $ENV{'IPCRUNDEBUG'};
            require IPC::Run;
            IPC::Run::run(['git', "--git-dir=$INIT_ROOT/.git", 'describe'],
                \undef, \$guess, \undef);
            chomp $guess;
        };
        return $guess if $guess;
    }
    # git was not possible - maybe the changelog is available
    if (-f "$INIT_ROOT/debian/changelog") {
        require Parse::DebianChangelog;
        eval {
            my $changelog
              = Parse::DebianChangelog->init(
                { infile => "$INIT_ROOT/debian/changelog" });
            $guess = $changelog->dpkg()->{'Version'} if $changelog;
        };
        return $guess if $guess;
    }
    # Out of guesses ...
    return;
}

sub _update_profile {
    my ($profile, $sup_check, $sup_tags, $only_check, $only_tags) = @_;
    my %abbrev = ();

    if ($sup_check || $only_check) {
        # Build an abbreviation map
        for my $c ($profile->scripts(1)) {
            my $cs = $profile->get_script($c, 1);
            next unless $cs->abbrev;
            $abbrev{$cs->abbrev} = $cs;
        }
    }

    # if tags are listed explicitly (--tags) then show them even if
    # they are pedantic/experimental etc.  However, for --check-part
    # people explicitly have to pass the relevant options.
    if ($checks || $check_tags) {
        $profile->disable_tags($profile->tags);
        if ($check_tags) {
            $TAGS->show_experimental(1);
            # discard whatever is in @display_level and request
            # everything
            @display_level = ();
            display_infotags();
            display_pedantictags();
            $profile->enable_tags(split /,/, $check_tags);
        } else {
            for my $c (split /,/, $checks) {
                my $cs = $profile->get_script($c, 1) || $abbrev{$c};
                fail("Unknown check script $c") unless $cs;
                $profile->enable_tags($cs->tags);
            }
        }
    } elsif ($sup_check) {
        # we are disabling checks
        for my $c (split(/,/, $sup_check)) {
            my $cs = $profile->get_script($c, 1) || $abbrev{$c};
            fail("Unknown check script $c") unless $cs;
            $profile->disable_tags($cs->tags);
        }
    }

    # --suppress-tags{,-from-file} can appear alone, but can also be
    # mixed with -C or -X.  Though, ignore it with --tags.
    if (%$sup_tags and not $check_tags) {
        $profile->disable_tags(keys %$sup_tags);
    }
    return;
}

# }}}

# {{{ Exit handler.

sub END {

    $SIG{'INT'} = 'DEFAULT';
    $SIG{'QUIT'} = 'DEFAULT';

    # We have to ensure that our exit code is 0, 1 or 2.  Quote from
    # "perldoc -f die":
    #
    # """
    # If an uncaught exception results in interpreter exit, the exit
    # code is determined from the values of $! and $? with this
    # pseudocode:
    #
    #   exit $! if $!; # errno
    #   exit $? >> 8 if $? >> 8; # child exit status
    #   exit 255;
    # """
    #
    # So, here in the END handler, we abuse the fact that we can alter
    # the exit code by changing $?.  It is not a perfect solution
    # (e.g.  if $! is 1, then we might still exit 1 instead of 2), but
    # it is definitely better than exiting with undocumented exit codes.
    if ($? != 0 && $? != 2) {
        # If $? is not 1, then we definitely want $? to be 2.  If
        # $exit_code != 1, then either we got an uncaught exception
        # before the first policy violation or we already saw an
        # internal error that we caught.  Either way, we want to
        # exit with 2 in this case.
        #
        # Sadly, this is unreliable if we saw a policy violation and
        # then cause an uncaught internal error (where e.g. $! is 1).
        # In this case we will still exit 1 instead of 2 as we should.
        # Nevertheless, this is probably a lot more reliable than
        # Lintian <= 2.5.12 was.
        if ($? != 1 || $exit_code != 1) {
            $? = 2;
        }
    }

    if (1) {
        # Prevent LAB->close and $unpacker->kill_jobs from affecting
        # the exit code.
        local $?;

        # Kill any remaining jobs.
        $unpacker->kill_jobs if $unpacker;

        $LAB->close if $LAB;
    }
}

sub interrupted {
    $SIG{$_[0]} = 'DEFAULT';
    die "N: Interrupted.\n";
}

# }}}

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
