#!/usr/bin/perl
#
# Lintian -- Debian package checker
#
# Copyright © 1998 Christian Schwarz and Richard Braakman
# Copyright © 2013 Niels Thykier
# Copyright © 2017-2019 Chris Lamb <lamby@debian.org>
# Copyright © 2020 Felix Lechner
#
# 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.

use v5.20;
use warnings;
use utf8;
use autodie;

# use Lintian modules that belong to this program
use FindBin;
use lib "$FindBin::RealBin/../lib";

# substituted during package build
my $LINTIAN_VERSION;

use Cwd qw(abs_path getcwd realpath);
use Carp qw(croak verbose);
use Config::Tiny;
use File::BaseDir qw(config_home config_files data_home);
use File::Basename;
use Getopt::Long ();
use List::Compare;
use List::MoreUtils qw(any none);
use Path::Tiny;
use POSIX qw(:sys_wait_h);

use Lintian::Data;
use Lintian::Inspect::Changelog;
use Lintian::IPC::Run3 qw(safe_qx);
use Lintian::Output::Standard;
use Lintian::Pool;
use Lintian::Profile;
use Lintian::Util qw(version_from_changelog);

use constant EMPTY => q{};
use constant SPACE => q{ };
use constant COMMA => q{,};
use constant COLON => q{:};
use constant NEWLINE => qq{\n};

# only in GNOME; need original environment
my $interactive = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT));
my $hyperlinks_capable = $interactive && qx{env | fgrep -i gnome};

# only do once; layers are additive
binmode(STDOUT, ':encoding(UTF-8)');
binmode(STDERR, ':encoding(UTF-8)');

my %PRESERVE_ENV = map { $_ => 1 } qw(
  DEBRELEASE_DEBS_DIR
  HOME
  LANG
  LC_ALL
  LC_MESSAGES
  PATH
  TMPDIR
  XDG_CACHE_HOME
  XDG_CONFIG_DIRS
  XDG_CONFIG_HOME
  XDG_DATA_DIRS
  XDG_DATA_HOME
);

my @disallowed
  = grep { !exists $PRESERVE_ENV{$_} && $_ !~ /^LINTIAN_/ } keys %ENV;

delete $ENV{$_} for @disallowed;

$ENV{LINTIAN_BASE} = realpath("$FindBin::RealBin/..")
  // die 'Cannot resolve LINTIAN_BASE';

$ENV{LINTIAN_VERSION} = $LINTIAN_VERSION // guess_version($ENV{LINTIAN_BASE});

if (my $coverage_arg = $ENV{LINTIAN_COVERAGE}) {
    my $p5opt = $ENV{PERL5OPT} // EMPTY;
    $p5opt .= SPACE unless $p5opt eq EMPTY;
    $ENV{PERL5OPT} = "${p5opt} ${coverage_arg}";
}

my $experimental_output_opts;

# options set in config file
my %config;

my %selected = (
    'checks-off'        => [],
    'checks-on'         => [],
    'color'             => 'auto',
    'debug'             => 0,
    'fail-on'           => [],
    'include-dirs'      => [],
    'jobs'              => default_jobs(),
    'LINTIAN_CFG'       => EMPTY,
    'quiet'             => 0,
    'tags-off'          => [],
    'tags-on'           => [],
    'user-dirs'         => 1,
    'verbose'           => 0,
);

my %getoptions = (
    'allow-root' => \$selected{'allow-root'},
    'cfg=s' => \$selected{LINTIAN_CFG},
    'check|c' => \$selected{check},
    'check-part|C=s' => $selected{'checks-on'},
    'color=s' => \$selected{color},
    'debug|d+' => \$selected{debug},
    'default-display-level' => \&default_display_level,
    'display-experimental|E!' => \$selected{'display-experimental'},
    'display-level|L=s' => \&record_display_level,
    'display-info|I' => \&display_infotags,
    'display-source=s' => \&record_display_source,
    'dont-check-part|X=s' => $selected{'checks-off'},
    'exp-output:s' => \$experimental_output_opts,
    'fail-on=s' => $selected{'fail-on'},
    'ftp-master-rejects|F' => \$selected{'ftp-master-rejects'},
    'help|h:s' => \&show_help,
    'hide-overrides' => sub { $selected{'show-overrides'} = 0; },
    'hyperlinks=s' => \$selected{hyperlinks},
    'ignore-lintian-env' => \$selected{'ignore-lintian-env'},
    'include-dir=s' => $selected{'include-dirs'},
    'info|i' => \$selected{info},
    'jobs|j=i' => \$selected{jobs},
    'keep-lab' => \$selected{'keep-lab'},
    'no-cfg' => \$selected{'no-cfg'},
    'no-override|o' => \$selected{'no-override'},
    'no-tag-display-limit' => sub { $selected{'tag-display-limit'} = 0; },
    'packages-from-file=s' => \$selected{'packages-from-file'},
    'pedantic' => \&display_pedantictags,
    'perf-debug' => \$selected{'perf-debug'},
    'perf-output=s' => \$selected{'perf-output'},
    'print-version' => \&print_version,
    'profile=s' => \$selected{profile},
    'quiet|q' => $selected{quiet},
    'show-overrides' => \$selected{'show-overrides'},
    'status-log=s' => \$selected{'status-log'},
    'suppress-tags=s' => $selected{'tags-off'},
    'suppress-tags-from-file=s' => \&record_suppress_tags_from_file,
    'tag-display-limit=i' => \$selected{'tag-display-limit'},
    'tags|T=s' => $selected{'tags-on'},
    'tags-from-file=s' => \&record_check_tags_from_file,
    'user-dirs!' => \$selected{'user-dirs'},
    'verbose|v' => \$selected{verbose},
    'version|V' => \&version,
);

Getopt::Long::Configure('default', 'bundling',
    'no_getopt_compat','no_auto_abbrev','permute');

Getopt::Long::GetOptions(%getoptions)
  or die "error parsing options\n";

# only absolute paths
my @RESTRICTED_CONFIG_DIRS;

if ($selected{'user-dirs'}) {

    my $data_home;
    $data_home = data_home('lintian')
      if exists $ENV{HOME} || exists $ENV{'XDG_CONFIG_HOME'};

    # make path absolute
    if (length $data_home && $data_home !~ m{^/}) {
        my $cwd = getcwd();
        $data_home = "$cwd/$data_home";
    }

    my $legacy_user_data;
    $legacy_user_data = "$ENV{HOME}/.lintian"
      if exists $ENV{HOME};

    @RESTRICTED_CONFIG_DIRS = grep { -d }
      grep { length } ($data_home, $legacy_user_data, '/etc/lintian');
}

# only absolute paths
my @CONFIG_DIRS = grep { -d }
  grep { length }
  map { realpath($_) } ($ENV{LINTIAN_BASE}, @{$selected{'include-dirs'}});

my @HELPER_DIRS = grep { -d } map { "$_/helpers" } @CONFIG_DIRS;

$ENV{LINTIAN_HELPER_DIRS} = join(COLON, @HELPER_DIRS);

# needed for tar
$ENV{LC_ALL} = 'C';
$ENV{TZ} = EMPTY;

# PATH may be unset in some environments; use sane default
$ENV{PATH} //= '/bin:/usr/bin';

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

my @ENV_VARS = (
    # LINTIAN_CFG  - handled manually
    qw(
      TMPDIR
      ));

my @CLOSE_AT_END;
my $OUTPUT = Lintian::Output::Standard->new;
my @display_level;
my %display_source;
my $received_signal;
my $exit_code = 0;
my $STATUS_FD;

$0 = join(SPACE, $0, @ARGV);

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

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

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

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

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

@{$selected{'fail-on'}} = split(/,/, join(COMMA, @{$selected{'fail-on'}}));
my @unknown_fail_on
  = grep {!/^(?:error|warning|info|pedantic|experimental|override|none)$/ }
  @{$selected{'fail-on'}};
die "Unrecognized fail-on argument: @unknown_fail_on\n"
  if @unknown_fail_on;

if (any { $_ eq 'none' } @{$selected{'fail-on'}}) {
    if (@{$selected{'fail-on'}} > 1) {
        die
"Cannot combine 'none' with other conditions: @{$selected{'fail-on'}}\n";
    } else {
        @{$selected{'fail-on'}} = [];
    }
}

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

if ($selected{'no-cfg'}) {
    $selected{LINTIAN_CFG} = EMPTY;
} else {
    $selected{LINTIAN_CFG} ||= _find_cfg_file();

    parse_config_file($selected{LINTIAN_CFG});
}

if (defined $experimental_output_opts) {
    my %output = map { split(/=/) } split(/,/, $experimental_output_opts);
    for (keys %output) {
        if ($_ eq 'format') {
            if ($output{$_} eq 'colons') {
                require Lintian::Output::ColonSeparated;
                $OUTPUT= Lintian::Output::ColonSeparated->new;
            } elsif ($output{$_} eq 'letterqualifier') {
                require Lintian::Output::LetterQualifier;
                $OUTPUT= Lintian::Output::LetterQualifier->new;
            } elsif ($output{$_} eq 'html') {
                require Lintian::Output::HTML;
                $OUTPUT = Lintian::Output::HTML->new;
            } elsif ($output{$_} eq 'xml') {
                require Lintian::Output::XML;
                $OUTPUT = Lintian::Output::XML->new;
            } elsif ($output{$_} eq 'json') {
                require Lintian::Output::JSON;
                $OUTPUT = Lintian::Output::JSON->new;
            } elsif ($output{$_} eq 'fullewi') {
                require Lintian::Output::FullEWI;
                $OUTPUT = Lintian::Output::FullEWI->new;
            } elsif ($output{$_} eq 'universal') {
                require Lintian::Output::Universal;
                $OUTPUT = Lintian::Output::Universal->new;
            }
        }
    }
}

die "The color value must be one of never, always, auto or html.\n"
  unless (any { $selected{color} eq $_ } qw(never always auto html));

if ($selected{color} eq 'never') {
    $selected{hyperlinks} //= 'off';
} else {
    $selected{hyperlinks} //= 'on';
}
die "The hyperlink value must be on or off\n"
  unless $selected{hyperlinks} =~ /^(?:on|off)$/;

$selected{verbose} = -1
  if $selected{quiet};

if ($selected{verbose} || !-t STDOUT) {
    $selected{'tag-display-limit'} //= 0;
} else {
    $selected{'tag-display-limit'} //= 4;
}

if ($selected{debug}) {
    $selected{verbose} = 1;
    $ENV{LINTIAN_DEBUG} = $selected{debug};
    $SIG{__DIE__} = sub { Carp::confess(@_) };
}

$OUTPUT->verbosity_level($selected{verbose});
$OUTPUT->debug($selected{debug});

$OUTPUT->color($selected{color});
$OUTPUT->tty_hyperlinks($hyperlinks_capable&& $selected{hyperlinks} eq 'on');
$OUTPUT->tag_display_limit($selected{'tag-display-limit'});
$OUTPUT->showdescription($selected{info});

$OUTPUT->perf_debug($selected{'perf-debug'});
if (defined(my $perf_log = $selected{'perf-output'})) {
    my $fd = open_file_or_fd($perf_log, '>');
    $OUTPUT->perf_log_fd($fd);

    push(@CLOSE_AT_END, [$fd, $perf_log]);
}

if (defined(my $status_log = $selected{'status-log'})) {
    $STATUS_FD = open_file_or_fd($status_log, '>');
    $STATUS_FD->autoflush;

    push(@CLOSE_AT_END, [$STATUS_FD, $status_log]);
} else {
    open($STATUS_FD, '>', '/dev/null');
}

# some environment variables can be set from the config file
my $envlc = List::Compare->new([keys %config], \@ENV_VARS);
my @from_file = $envlc->get_intersection;

my @already = grep { defined $ENV{$_} } @from_file;
warn 'The environment overrides these settings in the configuration file: '
  . join(SPACE, @already)
  . NEWLINE
  if @already;

my @not_yet = grep { !defined $ENV{$_} } @from_file;
$OUTPUT->debug_msg(1,
    'Setting environment variables from configuration file: '
      . join(SPACE, @not_yet))
  if @not_yet;
$ENV{$_} = $config{$_} for @not_yet;

# check for arguments
if ($#ARGV == -1
    && !$selected{'packages-from-file'}) {
    my $ok = 0;
    # 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;
    }
    show_help() unless $ok;
}

if ($selected{debug}) {
    # Lintian::Output is now available
    $OUTPUT->debug_msg(
        1,
        "Lintian v$ENV{LINTIAN_VERSION}",
        "Lintian root directory: $ENV{LINTIAN_BASE}",
        "Configuration file: $selected{LINTIAN_CFG}",
        'UTF-8: ✓ (☃)',
        $OUTPUT->delimiter,
    );
}

if (defined $selected{LINTIAN_PROFILE}) {
    warn
"Warning: Please use 'profile' in config file; LINTIAN_PROFILE is obsolete.\n";
    $selected{profile} //= $selected{LINTIAN_PROFILE};
    delete $selected{LINTIAN_PROFILE};
}

my $PROFILE = Lintian::Profile->new;

# dies on error
$PROFILE->load($selected{profile}, \@CONFIG_DIRS,
    { 'restricted-search-dirs' => \@RESTRICTED_CONFIG_DIRS });
$OUTPUT->v_msg('Using profile ' . $PROFILE->name . '.');

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

$selected{'display-source'} = [keys %display_source];

# 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.

@{$selected{'checks-on'}} = split(/,/, join(COMMA, @{$selected{'checks-on'}}));
@{$selected{'checks-off'}}
  = split(/,/, join(COMMA, @{$selected{'checks-off'}}));

@{$selected{'tags-on'}} = split(/,/, join(COMMA, @{$selected{'tags-on'}}));
@{$selected{'tags-off'}} = split(/,/, join(COMMA, @{$selected{'tags-off'}}));

if (@{$selected{'checks-on'}} || @{$selected{'tags-on'}}) {

    $PROFILE->disable_tag($_) for $PROFILE->enabled_tags;

    if (@{$selected{'tags-on'}}) {
        $selected{'display-experimental'} = 1;

        # discard @display_level and geteverything
        @display_level = ();
        display_infotags();
        display_pedantictags();
        display_classificationtags();
        $PROFILE->enable_tag($_) for @{$selected{'tags-on'}};

    } else {
        for my $c (@{$selected{'checks-on'}}) {
            if ($c eq 'all') {
                my @all
                  = map {$PROFILE->get_checkinfo($_)}$PROFILE->known_checks;
                my @tags = map { $_->tags } @all;
                $PROFILE->enable_tag($_) for @tags;
                next;
            }
            my $cs = $PROFILE->get_checkinfo($c);
            die "Unrecognized check script (via -C): $c\n"
              unless $cs;
            $PROFILE->enable_tag($_) for $cs->tags;
        }
    }

} elsif (@{$selected{'checks-off'}}) {
    # we are disabling checks
    for my $c (@{$selected{'checks-off'}}) {
        my $cs = $PROFILE->get_checkinfo($c);
        die "Unrecognized check script (via -X): $c\n" unless $cs;
        $PROFILE->disable_tag($_) for $cs->tags;
    }
}

# ignore --suppress-tags when used with --tags.
if (@{$selected{'tags-off'}} && !@{$selected{'tags-on'}}) {
    $PROFILE->disable_tag($_) for @{$selected{'tags-off'}};
}

# initialize display level settings; dies on error
$PROFILE->display(@{$_}) for @display_level;

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

my @subjects;
push(@subjects, @ARGV);

if ($selected{'packages-from-file'}){
    my $fd = open_file_or_fd($selected{'packages-from-file'}, '<');

    while (my $line = <$fd>) {
        chomp $line;

        next
          if $line =~ /^\s*$/;

        push(@subjects, $line);
    }

    # close unless it is STDIN (else we will see a lot of warnings
    # about STDIN being reopened as "output only")
    close($fd)
      unless fileno($fd) == fileno(STDIN);
}

my $pool = Lintian::Pool->new;

for my $path (@subjects) {
    die "$path is not a file\n" unless -f $path;

    # in ubuntu, automatic dbgsym packages end with .ddeb
    die
"bad package file name $path (neither .deb, .udeb, .ddeb, .changes, .dsc or .buildinfo file)\n"
      unless $path =~ m/\.(?:[u|d]?deb|dsc|changes|buildinfo)$/;

    my $absolute = Cwd::abs_path($path);
    die "Cannot resolve $path: $!"
      unless $absolute;

    eval {
        # create a new group
        my $group = Lintian::Group->new;
        $group->pooldir($pool->basedir);
        $group->init_from_file($absolute);

        $pool->add_group($group);
    };
    if ($@) {
        print STDERR "Skipping $path: $@";
        $exit_code = 1;
    }
}

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

$pool->process($PROFILE, \$exit_code, \%selected, $STATUS_FD, $OUTPUT);

retrigger_signal()
  if $received_signal;

exit $exit_code;

sub guess_version {
    my ($lintian_base) = @_;

    my $guess = version_from_git($lintian_base);
    $guess ||= version_from_changelog($lintian_base);

    return $guess
      if length $guess;

    die 'Unable to determine the version automatically!?';
}

=item version_from_git

=cut

sub version_from_git {
    my ($source_path) = @_;

    my $git_path = "$source_path/.git";

    return EMPTY
      unless -d $git_path;

    my $guess = safe_qx('git', "--git-dir=$git_path", 'describe');
    chomp $guess;

    return ($guess // EMPTY);
}

sub print_version {
    say $ENV{LINTIAN_VERSION};
    exit;
}

sub version {
    say "Lintian v$ENV{LINTIAN_VERSION}";
    exit;
}

sub record_check_tags_from_file {
    my ($selected, $name) = @_;

    open(my $file, '<', $name);
    my @activate;
    for my $line (<$file>) {
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        next unless $line;
        next if $line =~ /^\#/;
        push(@activate, split(/\s*,\s*/, $line));
    }
    close $file;

    push(@{$selected{'tags-on'}}, @activate);
    return;
}

sub record_suppress_tags {
    my ($selected, $line) = @_;

    my @suppress = split(/\s*,\s*/, $line);
    push(@{$selected{'tags-off'}}, @suppress);

    return;
}

sub record_suppress_tags_from_file {
    my ($selected, $name) = @_;

    my @suppress;
    open(my $file, '<', $name);
    for my $line (<$file>) {
        chomp $line;
        $line =~ s/^\s+//;
        # Remove trailing white-space/comments
        $line =~ s/(\#.*+|\s+)$//;
        next unless $line;
        push(@suppress, split(/\s*,\s*/, $line));
    }
    close $file;

    push(@{$selected{'tags-off'}}, @suppress);

    return;
}

sub record_display_level {
    my ($selected, $level) = @_;

    my $op;
    if ($level =~ s/^([+=-])//) {
        $op = $1;
    }

    my $rel;
    if ($level =~ s/^([<>]=?|=)//) {
        $rel = $1;
    }
    my $severity = $level;
    $op //= '=';
    $rel //= '=';
    push(@display_level, [$op, $rel, $severity]);

    return;
}

sub display_infotags {
    push(@display_level, ['+', '>=', 'info']);
    return;
}

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

sub display_classificationtags {
    push(@display_level, ['+', '=', 'classification']);
    return;
}

sub default_display_level {
    push(@display_level,['=', '>=', 'warning'],);
    return;
}

sub record_display_source {
    $display_source{$_[1]} = 1;
    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 appearances of
#    --display-level/--display-info
sub cfg_display_level {
    my ($var, $val) = @_;

    if ($var eq 'display-info' || $var eq 'pedantic'){
        die "$var and display-level may not both appear in the config file.\n"
          if $config{'display-level'};

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

        # 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 && !$config{'__conf-display-opts'};

        $config{'__conf-display-opts'} = 1;
        display_infotags() if $var eq 'display-info';
        display_pedantictags() if $var eq 'pedantic';

    } elsif ($var eq 'display-level'){
        for my $other (qw(pedantic display-info)) {
            die
"$other and display-level may not both appear in the config file.\n"
              if $config{$other};
        }

        return if @display_level;

        # trim both ends
        $val =~ s/^\s+|\s+$//g;

        for 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 ($selected{verbose}) unless
#   already set.
sub cfg_verbosity {
    my ($var, $val) = @_;

    if (   ($var eq 'verbose' && exists $config{quiet})
        || ($var eq 'quiet' && exists $config{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 $selected{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';
    $selected{verbose} = $val;

    return;
}

# Process overrides option in the cfg files
sub cfg_override {
    my ($var, $val) = @_;

    return
      if defined $selected{'no-override'};

    # This option is inverted in the config file
    $selected{'no-override'} = !$val;

    return;
}

sub _find_cfg_file {
    return $ENV{LINTIAN_CFG}
      if length $ENV{LINTIAN_CFG} && -f $ENV{LINTIAN_CFG};

    if ($selected{'user-dirs'}) {
        my $rcfile;
        {
            # File::BaseDir spews 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} //= '/nonexistent';
            require File::BaseDir;
            File::BaseDir->import(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}
          || exists $ENV{XDG_CONFIG_HOME};

        return $rcfile
          if length $rcfile && -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 length $rcfile && $rcfile ne EMPTY;
    }

    # none found
    return EMPTY;
}

sub parse_config_file {
    my ($config_file) = @_;

    return
      unless length $config_file;

    # for keys appearing multiple times, now uses the last value
    my $object = Config::Tiny->read($config_file, 'utf8');
    my $error = $object->errstr;
    die "syntax error in configuration file $config_file: " . $error . NEWLINE
      if length $error;

    # used elsewhere to check for values already set
    %config = %{$object->{_} // {}};

    # Options that can appear in the config file
    my %destination = (
        'color'                => \$selected{color},
        'hyperlinks'           => \$selected{hyperlinks},
        'display-experimental' => \$selected{'display-experimental'},
        'display-info'         => \&cfg_display_level,
        'display-level'        => \&cfg_display_level,
        'info'                 => \$selected{info},
        'jobs'                 => \$selected{jobs},
        'LINTIAN_PROFILE'      => \$selected{LINTIAN_PROFILE},
        'pedantic'             => \&cfg_display_level,
        'profile'              => \$selected{profile},
        'quiet'                => \&cfg_verbosity,
        'override'             => \&cfg_override,
        'show-overrides'       => \$selected{'show-overrides'},
        'suppress-tags'        => \&record_suppress_tags,
        'suppress-tags-from-file' => \&record_suppress_tags_from_file,
        'tag-display-limit'    => \$selected{'tag-display-limit'},
        'verbose'              => \&cfg_verbosity,
    );

    # substitute some special variables
    s{\$HOME/}{$ENV{HOME}/}g for values %config;
    s{\~/}{$ENV{HOME}/}g for values %config;

    # Translate boolean strings to "0" or "1"; ignore
    # errors as not all values are (intended to be)
    # booleans.
    my $booleanlc
      = List::Compare->new([keys %config], [qw(jobs tag-display-limit)]);
    eval { $config{$_} = parse_boolean($config{$_}); }
      for $booleanlc->get_Lonly;

    # check keys against known settings
    my $knownlc
      = List::Compare->new([keys %config], [keys %destination, @ENV_VARS]);
    my @unknown = $knownlc->get_Lonly;
    die "Unknown setting in $config_file: " . join(SPACE, @unknown) . NEWLINE
      if @unknown;

    # get settings from configuration file
    my @names = grep { defined $destination{$_} } keys %config;

    my @scalars = grep { ref $destination{$_} eq 'SCALAR' } @names;
    my @undefined = grep { !defined ${$destination{$_}} } @scalars;

    ${$destination{$_}} = $config{$_} for @undefined;

    my @coderefs = grep { ref $destination{$_} eq 'CODE' } @names;
    $destination{$_}->($_, $config{$_}) for @coderefs;

    return;
}

=item parse_boolean (STR)

Attempt to parse STR as a boolean and return its value.
If STR is not a valid/recognised boolean, the sub will
invoke croak.

The following values recognised (string checks are not
case sensitive):

=over 4

=item The integer 0 is considered false

=item Any non-zero integer is considered true

=item "true", "y" and "yes" are considered true

=item "false", "n" and "no" are considered false

=back

=cut

sub parse_boolean {
    my ($str) = @_;

    return $str == 0 ? 0 : 1
      if $str =~ /^-?\d++$/;

    $str = lc $str;

    return 1
      if $str eq 'true' || $str =~ m/^y(?:es)?$/;

    return 0
      if $str eq 'false' || $str =~ m/^no?$/;

    croak "\"$str\" is not a valid boolean value";
}

sub _find_changes {
    my $contents = path('debian/changelog')->slurp;
    my $changelog = Lintian::Inspect::Changelog->new;
    $changelog->parse($contents);
    my @entries = @{$changelog->entries};
    my $last = @entries ? $entries[0] : undef;
    my ($source, $version);
    my $changes;
    my @archs;
    my @dirs = ('..', '../build-area', '/var/cache/pbuilder/result');

    unshift(@dirs, $ENV{DEBRELEASE_DEBS_DIR})
      if exists $ENV{DEBRELEASE_DEBS_DIR};

    if (not $last) {
        my @errors = @{$changelog->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 1;
    }
    $version = $last->Version;
    $source = $last->Source;
    unless (defined $version && 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 1;
    }
    # remove the epoch
    $version =~ s/^\d+://;
    if (exists $ENV{DEB_BUILD_ARCH}) {
        push(@archs, $ENV{DEB_BUILD_ARCH});
    } else {
        my $arch = safe_qx('dpkg', '--print-architecture');
        chomp $arch;
        push(@archs, $arch) if length $arch;
    }
    push @archs, $ENV{DEB_HOST_ARCH} if exists $ENV{DEB_HOST_ARCH};
    # 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);
    for my $dir (@dirs) {
        for 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";
    for 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;
}

=item open_file_or_fd

=cut

# open_file_or_fd(TO_OPEN, MODE)
#
# Open a given file or FD based on TO_OPEN and MODE and returns the
# open handle.  Will croak / throw a trappable error on failure.
#
# MODE can be one of "<" (read) or ">" (write).
#
# TO_OPEN is one of:
#  * "-", alias of "&0" or "&1" depending on MODE
#  * "&N", reads/writes to the file descriptor numbered N
#          based on MODE.
#  * "+FILE" (MODE eq '>' only), open FILE in append mode
#  * "FILE", open FILE in read or write depending on MODE.
#            Note that this will truncate the file if MODE
#            is ">".
sub open_file_or_fd {
    my ($to_open, $mode) = @_;

    my $fd;
    # autodie trips this for some reasons (possibly fixed
    # in v2.26)
    no autodie qw(open);
    if ($mode eq '<') {
        if ($to_open eq '-' || $to_open eq '&0') {
            $fd = \*STDIN;
        } elsif ($to_open =~ m/^\&\d+$/) {
            open($fd, '<&=', substr($to_open, 1))
              or die "fdopen $to_open for reading: $!\n";
        } else {
            open($fd, '<', $to_open)
              or die "open $to_open for reading: $!\n";
        }

    } elsif ($mode eq '>') {
        if ($to_open eq '-' || $to_open eq '&1') {
            $fd = \*STDOUT;
        } elsif ($to_open =~ m/^\&\d+$/) {
            open($fd, '>&=', substr($to_open, 1))
              or die "fdopen $to_open for writing: $!\n";
        } else {
            $mode = ">$mode" if $to_open =~ s/^\+//;
            open($fd, $mode, $to_open)
              or die "open $to_open for write/append ($mode): $!\n";
        }

    } else {
        croak "Invalid mode \"$mode\" for open_file_or_fd";
    }

    return $fd;
}

=item default_jobs

=cut

sub default_jobs {

    my $cpus = safe_qx('nproc');

    return 2
      unless $cpus =~ m/^\d+$/;

    # could be 2x
    return $cpus + 1;
}

sub END {

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

    # Prevent LAB->close, $unpacker->kill_jobs etc. from affecting
    # the exit code.
    local ($!, $?, $@);

    my %already_closed;

    for my $to_close (@CLOSE_AT_END) {

        my ($fd, $filename) = @{$to_close};
        my $fno = fileno($fd);

        # Already closed?  Can happen with e.g.
        #   --perf-output '&1' --status-log '&1'
        next
          unless defined $fno;

        next
          if $fno > -1 && $already_closed{$fno}++;

        eval {close $fd;};
        if (my $err = $@) {
            # Don't use L::Output here as it might be (partly) cleaned
            # up.
            print STDERR "warning: closing ${filename} failed: $err\n";
        }
    }
}

sub _die_in_signal_handler {
    die "N: Interrupted.\n";
}

sub retrigger_signal {
    # Re-kill ourselves with the same signal to ensure that the exit
    # code reflects that we died by a signal.
    local $SIG{$received_signal} = \&_die_in_signal_handler;
    $OUTPUT->debug_msg(2, "Retriggering signal SIG${received_signal}");
    return kill($received_signal, $$);
}

sub interrupted {
    $received_signal = $_[0];
    $SIG{$received_signal} = 'DEFAULT';
    print {$STATUS_FD} "ack-signal SIG${received_signal}\n";
    return _die_in_signal_handler();
}

sub show_help {
    my (undef, $value) = @_;

    say "Lintian v$ENV{LINTIAN_VERSION}";
    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
    -T X, --tags X            only run checks needed for requested tags
    --tags-from-file X        like --tags, but read list from file
    -X X, --dont-check-part X don\'t check certain aspects
General options:
    -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
Behavior options:
    --color never/always/auto disable, enable, or enable color for TTY
    --hyperlinks on/off       hyperlinks for TTY (when supported)
    --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 error,warning,info,pedantic,experimental,override
                              define condition for exit status 2 (default: error)
    -i, --info                give detailed info about tags
    -I, --display-info        display "I:" tags (normally suppressed)
    -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 overridden
    --hide-overrides          do not output tags that have been overridden (default)
    --suppress-tags T,...     don\'t show the specified tags
    --suppress-tags-from-file X don\'t show the tags listed in file X
EOT-EOT-EOT
    if ($value eq 'extended' || $value eq 'all') {
        # Not a special option per se, but most people will probably
        # not need it
        print <<"EOT-EOT-EOT";
    --tag-display-limit X     Specify "tag per package" display limit
    --no-tag-display-limit    Disable "tag per package" display limit
                              (equivalent to --tag-display-limit=0)
EOT-EOT-EOT
    }

    print <<"EOT-EOT-EOT";
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
    --[no-]user-dirs          whether to use files from user directories (*)
EOT-EOT-EOT

    if ($value eq 'extended' || $value eq 'all') {
        print <<"EOT-EOT-EOT";
Developer/Special usage options:
    --allow-root              suppress lintian\'s warning when run as root
    -d, --debug               turn Lintian\'s debug messages on (repeatable)
    --keep-lab                keep lab after run
    --packages-from-file  X   process the packages in a file (if "-" use stdin)
    --perf-debug              turn on performance debugging
    --perf-output X           send performance logging to file (or fd w. \&X)
    --status-log X            send status logging to file (or fd w. \&X) [internal use only]
EOT-EOT-EOT
    }

    print <<"EOT-EOT-EOT";

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

    unless ($value eq 'extended' || $value eq 'all') {
        print <<"EOT-EOT-EOT";

Note that some options have been omitted, use "--help=extended" to see them
all.
EOT-EOT-EOT
    }

    exit;
}

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