#!/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_files data_home);
use Getopt::Long ();
use List::Compare;
use List::MoreUtils qw(any none first_value);
use Path::Tiny;
use POSIX qw(:sys_wait_h);
use Unicode::UTF8 qw(valid_utf8 decode_utf8);

use Lintian::Deb822::Parser qw(parse_dpkg_control_string);
use Lintian::Inspect::Changelog;
use Lintian::IPC::Run3 qw(safe_qx);
use Lintian::Output::EWI;
use Lintian::Pool;
use Lintian::Profile;
use Lintian::Version qw(guess_version);

use constant EMPTY => q{};
use constant SPACE => q{ };
use constant COMMA => q{,};
use constant COLON => q{:};
use constant SLASH => 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)');

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

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;

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

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

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

$ENV{LINTIAN_VERSION} = $LINTIAN_VERSION // guess_version($ENV{LINTIAN_BASE});
die 'Unable to determine the version automatically!?'
  unless length $ENV{LINTIAN_VERSION};

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

my @getoptions = qw(
  allow-root
  cfg=s
  check|c
  check-part|C=s@
  color=s
  debug|d+
  default-display-level
  display-experimental|E!
  display-level|L=s@
  display-info|I
  display-source=s@
  dont-check-part|X=s@
  exp-output:s
  fail-on=s@
  ftp-master-rejects|F
  help|h
  hide-overrides
  hyperlinks=s
  ignore-lintian-env
  include-dir=s@
  info|i
  jobs|j=i
  keep-lab
  no-cfg
  no-override|o
  no-tag-display-limit
  packages-from-file=s
  pedantic
  perf-debug
  perf-output=s
  print-version
  profile=s
  quiet|q
  show-overrides
  status-log=s
  suppress-tags=s@
  suppress-tags-from-file=s
  tag-display-limit=i
  tags|T=s@
  tags-from-file=s
  user-dirs!
  verbose|v
  version|V
);

my %command_line;

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

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

my @basenames = map { path($_)->basename } @ARGV;
$0 = join(SPACE, "$FindBin::RealBin/$FindBin::RealScript", @basenames);

if (exists $command_line{'version'}) {
    say "Lintian v$ENV{LINTIAN_VERSION}";
    exit;
}

if (exists $command_line{'print-version'}) {
    say $ENV{LINTIAN_VERSION};
    exit;
}

show_help()
  if exists $command_line{help};

$command_line{'show-overrides'} = 0
  if exists $command_line{'hide-overrides'};

$command_line{'tag-display-limit'} = 0
  if exists $command_line{'no-tag-display-limit'};

my $xdg_config_file;
my $dot_config_file;

my $xdg_data_home;
my $dot_data_home;

unless ($command_line{'no-user-dirs'}) {

    if (length $ENV{HOME} || length $ENV{XDG_CONFIG_HOME}) {

        $xdg_config_file = config_files('lintian/lintianrc');
        $xdg_data_home = data_home('lintian');
    }

    if (length $ENV{HOME}) {

        $dot_config_file = "$ENV{HOME}/.lintianrc";
        $dot_data_home = "$ENV{HOME}/.lintian";
    }

    # make path absolute for use elsewhere
    $xdg_data_home = getcwd() . SLASH . $xdg_data_home
      if length $xdg_data_home && $xdg_data_home !~ m{^/};
}

my $LINTIAN_CFG = $command_line{cfg} // EMPTY;

$LINTIAN_CFG ||= $ENV{LINTIAN_CFG}
  if length $ENV{LINTIAN_CFG} && -f $ENV{LINTIAN_CFG};

$LINTIAN_CFG ||= first_value { length $_ && -f $_ }
($xdg_config_file, $dot_config_file, '/etc/lintianrc');

# only absolute paths, for use elsewhere
my @RESTRICTED_CONFIG_DIRS
  = grep {length $_ && -d $_ }($xdg_data_home, $dot_data_home, '/etc/lintian');

$LINTIAN_CFG = EMPTY
  if $command_line{'no-cfg'};

my %config;

# some environment variables can be set from the config file
my @ENV_FROM_CONFIG = qw(
  TMPDIR
);

if (length $LINTIAN_CFG) {

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

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

    my @allowed = qw(
      color
      display-experimental
      display-info
      display-level
      hyperlinks
      info
      jobs
      LINTIAN_PROFILE
      override
      pedantic
      profile
      quiet
      show-overrides
      suppress-tags
      suppress-tags-from-file
      tag-display-limit
      TMPDIR
      verbose
    );

    my $knownlc
      = List::Compare->new([keys %config], [@allowed, @ENV_FROM_CONFIG]);
    my @unknown = $knownlc->get_Lonly;
    die "Unknown setting in $LINTIAN_CFG: " . join(SPACE, @unknown) . NEWLINE
      if @unknown;
}

# substitute home directory
s{\$HOME/}{$ENV{HOME}/}g for values %config;
s{\~/}{$ENV{HOME}/}g for values %config;

# option inverted in config file
$config{'no-override'} = !$config{'no-override'}
  if exists $config{'no-override'};

my @GETOPT_ARRAYS = qw(
  display-level
  suppress-tags
);

# convert some strings to array references
for my $name (@GETOPT_ARRAYS) {
    if (exists $config{$name}) {
        $config{$name} = [$config{$name}];
    } else {
        $config{$name} = [];
    }
}

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

# our defaults
my %selected = (
    'check-part'        => [],
    'color'             => 'auto',
    'debug'             => 0,
    'display-level'     => [],
    'display-source'    => [],
    'dont-check-part'   => [],
    'fail-on'           => [],
    'include-dir'       => [],
    'jobs'              => default_jobs(),
    'tags'              => [],
    'suppress-tags'     => [],
    'user-dirs'         => 1,
    'verbose'           => 0,
);

$selected{$_} = $config{$_} for keys %config;

my @MUTUAL_OPTIONS = (
    [qw(verbose quiet)],
    [qw(default-display-level display-level display-info pedantic)],
);

# for precedence of command line
for my $set (@MUTUAL_OPTIONS) {

    if (any { defined $command_line{$_} } @{$set}) {
        my @scalars = grep { ref $selected{$_} eq 'SCALAR' } @{$set};
        delete $selected{$_} for @scalars;

        my @arrays = grep { ref $selected{$_} eq 'ARRAY' } @{$set};
        $selected{$_} = [] for @arrays;
    }
}

$selected{$_} = $command_line{$_} for keys %command_line;

@{$selected{'display-level'}}
  = split(/\s*,\s*/, join(COMMA, @{$selected{'display-level'}}));

my @display_level;

push(@display_level,['=', '>=', 'warning'])
  if $selected{'default-display-level'};

push(@display_level, ['+', '>=', 'info'])
  if $selected{'display-info'};

push(@display_level, ['+', '=', 'pedantic'])
  if $selected{'pedantic'};

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

for my $level (@{$selected{'display-level'}}) {

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

    my $relation;
    if ($level =~ s/^([<>]=?|=)//) {
        $relation = $1;
    }

    my $severity = $level;
    $operator //= '=';
    $relation //= '=';

    push(@display_level, [$operator, $relation, $severity]);
}

@{$selected{'display-source'}}
  = split(/\s*,\s*/, join(COMMA, @{$selected{'display-source'}}));

@{$selected{'check-part'}}
  = split(/\s*,\s*/, join(COMMA, @{$selected{'check-part'}}));
@{$selected{'dont-check-part'}}
  = split(/\s*,\s*/, join(COMMA, @{$selected{'dont-check-part'}}));

@{$selected{tags}} = split(/\s*,\s*/, join(COMMA, @{$selected{tags}}));
@{$selected{'suppress-tags'}}
  = split(/\s*,\s*/, join(COMMA, @{$selected{'suppress-tags'}}));

if (length $selected{'tags-from-file'}) {

    open(my $file, '<', $selected{'tags-from-file'});
    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}}, @activate);
}

if (length $selected{'suppress-tags-from-file'}) {

    my @suppress;
    open(my $file, '<', $selected{'suppress-tags-from-file'});
    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{'suppress-tags'}}, @suppress);
}

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

my @CLOSE_AT_END;
my $OUTPUT = Lintian::Output::EWI->new;
my $received_signal;
my $exit_code = 0;
my $STATUS_FD;

# root permissions?
# check if effective UID is 0
if ($> == 0 && !$selected{'allow-root'}) {
    warn "warning: running with root privileges is not recommended!\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) {
    warn
"warning: option --packages-from-file cannot be mixed with package parameters!\n";
    warn "(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_FROM_CONFIG) {
# 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};
}

my %output = map { split(/=/) } split(/,/, ($selected{'exp-output'} // EMPTY));
for (keys %output) {
    if ($_ eq 'format') {
        if ($output{$_} eq 'html') {
            require Lintian::Output::HTML;
            $OUTPUT = Lintian::Output::HTML->new;
        } elsif ($output{$_} eq 'json') {
            require Lintian::Output::JSON;
            $OUTPUT = Lintian::Output::JSON->new;
        } elsif ($output{$_} eq 'universal') {
            require Lintian::Output::Universal;
            $OUTPUT = Lintian::Output::Universal->new;
        }
    }
}

my $envlc = List::Compare->new([keys %config], \@ENV_FROM_CONFIG);
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;

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

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($selected{verbose});
$OUTPUT->debug($selected{debug});

$OUTPUT->color(1)
  if $selected{color} eq 'always'
  || ($selected{color} eq 'auto'
    && -t *STDOUT);

$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');
}

# 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: $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 . '.');

# 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 (@{$selected{'check-part'}} || @{$selected{tags}}) {

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

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

        # discard current display level; get everything
        @display_level
          = (['+', '>=', 'pedantic'], ['+', '=', 'classification']);

        $PROFILE->enable_tag($_) for @{$selected{tags}};

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

            $PROFILE->enable_tag($_) for $checkinfo->tags;
        }
    }

} elsif (@{$selected{'dont-check-part'}}) {
    # we are disabling checks
    for my $checkname (@{$selected{'dont-check-part'}}) {
        my $checkinfo = $PROFILE->get_checkinfo($checkname);
        die "Unrecognized check (via -X): $checkname\n"
          unless $checkinfo;

        $PROFILE->disable_tag($_) for $checkinfo->tags;
    }
}

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

# 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 =~ /\.(?:[u|d]?deb|dsc|changes|buildinfo)$/;

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

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

        my $processable = $group->add_processable_from_file($absolute);

        my $parent = path($absolute)->parent->stringify;

        my @files;

        # pull in any additional files
        @files = keys %{$processable->files}
          if $processable->can('files');

        for my $basename (@files) {

            # ignore traversal attempts
            next
              if $basename =~ m{/};

            die "$parent/$basename does not exist, exiting\n"
              unless -f "$parent/$basename";

            # only care about some files; ddeb is ubuntu dbgsym
            next
              unless $basename =~ /\.(?:u|d)?deb$/
              || $basename =~ /\.dsc$/
              || $basename =~ /\.buildinfo$/;

            $group->add_processable_from_file("$parent/$basename");
        }

        $pool->add_group($group);
    };
    if ($@) {
        warn "Skipping $path: $@\n";
        $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;

=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) {
            warn "Cannot parse debian/changelog due to errors:\n";
            for my $error (@errors) {
                warn "$error->[2] (line $error->[1])\n";
            }
        } else {
            warn "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>';
        warn "Cannot determine source and version from debian/changelog:\n";
        warn "Source: $source\n";
        warn "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;
        }
    }

    warn"Cannot find changes file for ${source}/${version}, tried:\n";

    warn "  ${source}_${version}_${_}.changes\n" for @archs;

    warn " in the following dirs:\n";
    warn '  ', 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.
            warn "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 {

    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 this 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
    --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)
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

Some options were omitted. Please check the manual page for the complete list.
EOT-EOT-EOT

    exit;
}

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