#!/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 Getopt::Long;

# }}}

# {{{ Application Variables


### LIST OF MAGIC VARIABLES
#
# List of variables that has a scope greater than this file in one
# way or another.
#
# $LINTIAN_ROOT
#  - must be "our" as it is used by Checker and Lab
#  - it is set after opt parsing and left at that; this allows it
#    to be trivially removed once Checker and Lab have been fixed.
#
# LINTIAN_{ARCH,ARCHIVEDIR,AREA,DIST,LAB,ROOT}
#  - These must be exported as environment variables as unpack/*
#    depend on it.
#
# Please do not introduce any new magical variables, Thank You!
#
### END LIST OF MAGIC VARIABLES

our $LINTIAN_ROOT;

my @MUST_EXPORT = (qw(
    LINTIAN_ARCH
    LINTIAN_ARCHIVEDIR
    LINTIAN_AREA
    LINTIAN_DIST
    LINTIAN_LAB
    LINTIAN_ROOT
));
# LINTIAN_DEBUG, but that is handled separately

# 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.
my @ENV_VARS = (
# LINTIAN_CFG  - handled manually
# LINTIAN_ROOT - handled manually
qw(
    LINTIAN_ARCH
    LINTIAN_ARCHIVEDIR
    LINTIAN_AREA
    LINTIAN_DIST
    LINTIAN_PROFILE
    LINTIAN_LAB
));


### "Normal" application variables

# Version number - Is replaced during build with sed, see d/rules
my $LINTIAN_VERSION = '<VERSION>';	#External Version number
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 = 'a';		# 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 $packages_file = 0;		#string for the -p option

my $no_conf = 0;                #flag for --no-cfg
my %opt;                        #hash of some flags from cmd or cfg
my %conf_opt;                   #names of options set in the cfg file
my $no_profile = 0;             #whether a profile should be loaded

# The profile search path except LINTIAN_ROOT/profiles
#  which will be added later (we dont know LINTIAN_ROOT
#  at this point)
my @prof_inc = (
    "$ENV{HOME}/.lintian/profiles",
    '/etc/lintian/profiles'
);

my $experimental_output_opts = undef;

my @certainties = qw(wild-guess possible certain);
my @display_level;
my %display_source = ();
my %suppress_tags = ();

my $pool;

my $action;
my $checks;
my $check_tags;
my $dont_check;
my $unpack_info;
my $cwd;
my $exit_code = 0;
my $LAB;

my %collection_info;
my %enabled_checks;
my %check_abbrev;
my %unpack_infos;
my %check_info;

# }}}

# {{{ Setup Code

#turn off file buffering
$| = 1;

# 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
    --display-source X        restrict displayed tags by source
    -E, --display-experimental display "X:" tags (normally suppressed)
    --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:
    --arch ARCH               scan packages with architecture ARCH
    --area AREA               scan packages in this archive area (e.g. main)
    --archivedir ARCHIVEDIR   location of Debian archive to scan for packages
    --cfg CONFIGFILE          read CONFIGFILE for configuration
    --no-cfg CONFIGFILE       do not read any CONFIGFILE
    --dist DIST               scan packages in this distribution (e.g. sid)
    --lab LABDIR              use LABDIR as permanent laboratory
    --root ROOTDIR            use ROOTDIR instead of /usr/share/lintian
Package selection options:
    -a, --all                 process all packages in distribution
    -b, --binary              process only binary packages
    -p X, --packages-file X   process all files in file (special syntax!)
    --packages-from-file  X   process the packages in a file (if "-" use stdin)
    -s, --source              process only source packages
    --udeb                    process only udeb packages
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]";
}

# 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('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]";
    $no_profile = 1;
}

# 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]";
    $no_profile = 1;
}

# Record Parts requested for checking
# Options: --tags-from-file
sub record_check_tags_from_file {
    my ($option, $name) = @_;
    open(my $file, '<', $name)
	or die("failed to open $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;
    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;
    }
}

# 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)
	or die("failed to open $name: $!");
    for my $line (<$file>) {
	$line =~ s/^\s+//;
	$line =~ s/\s+$//;
	next unless $line;
	next if $line eq '';
	record_suppress_tags($option, $line);
    }
    close $file;
}

# 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('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]";
}


# Process for -U|--unpack-info flag
sub record_unpack_info {
    if ($unpack_info) {
	die('multiple -U or --unpack-info options not allowed');
    }
    $unpack_info = "$_[1]";
}

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

# 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 (grep { $severity eq $_ } @certainties) {
	    $certainty = $severity;
	    undef $severity;
	}
    }
    push(@display_level, [ $op, $rel, $severity, $certainty ]);
}

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

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

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

# Process deprecated flags
sub deprecated{
    print STDERR "warning: $_[0] is deprecated and may be removed\n";
    print STDERR "in a future Lintian release.\n";
}

# 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'){
	die "display-info and display-level may not both appear in the config file.\n"
	    if $conf_opt{'display-level'};

	return unless $val; # case "display-info=no"
	push @display_level, [ '+', '>=', 'wishlist' ] unless @display_level;
    } elsif ($var eq 'display-level'){
	die "display-info and display-level may not both appear in the config file.\n"
	    if $conf_opt{'display-info'};

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

}

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

# 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' => \$opt{'pedantic'},
	       'display-level|L=s' => \&record_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' => \&record_unpack_info,
	       'checksums|md5sums|m' => \&deprecated,
	       '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'},
	       'archivedir=s' => \$opt{'LINTIAN_ARCHIVEDIR'},
	       'dist=s' => \$opt{'LINTIAN_DIST'},
	       'area=s' => \$opt{'LINTIAN_AREA'},
	       'section=s' => \$opt{'LINTIAN_AREA'},
	       'arch=s' => \$opt{'LINTIAN_ARCH'},
	       'profile=s' => \$opt{'LINTIAN_PROFILE'},
	       'root=s' => \$opt{'LINTIAN_ROOT'},

	       # ------------------ package selection options
	       'all|a' => \$check_everything,
	       'binary|b' => \&record_pkgmode,
	       'source|s' => \&record_pkgmode,
	       'udeb' => \&record_pkgmode,
	       'packages-file|p=s' => \$packages_file,
	       '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'},
	       'pedantic'             => \$opt{'pedantic'},
	       'quiet'                => \&cfg_verbosity,
	       'no-override'          => \$opt{'no-override'},
	       'show-overrides'       => \$opt{'show-overrides'},
	       'verbose'              => \&cfg_verbosity,
    );

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

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

# determine LINTIAN_ROOT if it was not set with --root.
$opt{'LINTIAN_ROOT'} = $ENV{'LINTIAN_ROOT'} unless (defined($opt{'LINTIAN_ROOT'}));
if (defined $opt{'LINTIAN_ROOT'}) {
    unless ($opt{'LINTIAN_ROOT'} =~ m,^/,) {
	require Cwd;
	my $cwd = Cwd::getcwd();
	$opt{'LINTIAN_ROOT'} = "$cwd/$opt{'LINTIAN_ROOT'}";
    }
} else {
    $opt{'LINTIAN_ROOT'} = '/usr/share/lintian';
}

## Update our MAGIC $LINTIAN_ROOT for the first and last time!
$LINTIAN_ROOT = $opt{'LINTIAN_ROOT'};

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

if ($packages_file && $opt{'packages-from-file'}) {
    die "The options -p and --packages-from-file cannot be used together.\n"
}

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

# check for arguments
if ($action =~ /^(?:check|unpack|remove)$/ and $#ARGV == -1 and not $check_everything and not $packages_file and not $opt{'packages-from-file'}) {
    syntax();
}

die "Cannot use profile together wtih --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;

# }}}

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

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

# 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 ($opt{'LINTIAN_CFG'}) {
    } elsif (exists $ENV{'LINTIAN_CFG'} &&
	     -f ($opt{'LINTIAN_CFG'} = $ENV{'LINTIAN_CFG'})) {
    } elsif (-f ($opt{'LINTIAN_CFG'} = $LINTIAN_ROOT . '/lintianrc')) {
    } elsif (exists $ENV{'HOME'} &&
	     -f ($opt{'LINTIAN_CFG'} = $ENV{'HOME'} . '/.lintianrc')) {
    } elsif (-f ($opt{'LINTIAN_CFG'} = '/etc/lintianrc')) {
    } else {
	$opt{'LINTIAN_CFG'} = '';
    }
} else {
    $opt{'LINTIAN_CFG'} = '';
}

# read configuration file
if ($opt{'LINTIAN_CFG'}) {
    open(CFG, '<', $opt{'LINTIAN_CFG'})
	or die("cannot open configuration file $opt{'LINTIAN_CFG'} for reading: $!");
    while (<CFG>) {
	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) {
	    $var = "LINTIAN_$var";
	    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;
		if ($val =~ m/^y(?:es)?|true$/oi){
		    $val = 1;
		} elsif ($val =~ m/^no?|false$/oi){
		    $val = 0;
		}
		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(CFG);
}

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

# LINTIAN_ARCH must have a value.
unless (defined $opt{'LINTIAN_ARCH'}) {
    if ($opt{'LINTIAN_DIST'}) {
	chop($opt{'LINTIAN_ARCH'}=`dpkg --print-architecture`);
    } else {
	$opt{'LINTIAN_ARCH'} = 'any';
    }
}

# export current settings for our helper scripts
foreach my $var (@MUST_EXPORT) {
    if ($opt{$var}) {
	$ENV{$var} = $opt{$var};
    } else {
	$ENV{$var} ='';
	$opt{$var} = ''; # Avoids some undef warnings later
    }
}

# If we are running the test suite we should ignore
# user/system profiles.
if ($ENV{'LINTIAN_INTERNAL_TESTSUITE'}){
    @prof_inc = ();
}

if ($debug) {
    $opt{'verbose'} = 1;
    $ENV{'LINTIAN_DEBUG'} = $debug;
} else {
    # Ensure verbose has a defined value
    $opt{'verbose'} = 0 unless defined $opt{'verbose'};
}

# Use our custom-generated locale for programs we call, if it's available.  We
# first look in the Lintian root and then in /var/lib/lintian, which is the
# standard location for the install-time-generated locale.
if (-d "$LINTIAN_ROOT/locale/en_US.UTF-8") {
    $ENV{LOCPATH} = "$LINTIAN_ROOT/locale";
} elsif (-d '/var/lib/lintian/locale/en_US.UTF-8') {
    $ENV{LOCPATH} = '/var/lib/lintian/locale';
}

# }}}

# {{{ Loading lintian's own libraries (now LINTIAN_ROOT is known)
unshift @INC, "$opt{'LINTIAN_ROOT'}/lib";

require Lab;

require Util;
require Read_pkglists;
import Read_pkglists qw(read_bin_list read_src_list);

import Util;

require Checker;
require Lintian::Collect;
require Lintian::DepMap::Properties;
require Lintian::Data;
require Lintian::Output;
import Lintian::Output qw(:messages);
require Lintian::Command::Simple;
require Lintian::Command;
import Lintian::Command qw(spawn reap);
require Lintian::Internal::FrontendUtil;
import Lintian::Internal::FrontendUtil;
require Lintian::ProcessablePool;
require Lintian::Profile;
require Lintian::Tag::Info;
require Lintian::Tags;
import Lintian::Tags qw(tag);

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 = new Lintian::Output::ColonSeparated;
	    } elsif ($opts{$_} eq 'letterqualifier') {
		require Lintian::Output::LetterQualifier;
		$Lintian::Output::GLOBAL = new Lintian::Output::LetterQualifier;
	    } elsif ($opts{$_} eq 'xml') {
		require Lintian::Output::XML;
		$Lintian::Output::GLOBAL = new Lintian::Output::XML;
	    }
	}
	no strict 'refs';
	${"Tags::$_"} = $opts{$_};
    }
}


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

# Print Debug banner, now that we're finished determining
# the values and have Lintian::Output available
debug_msg(1,
	  $BANNER,
	  "Lintian root directory: $opt{'LINTIAN_ROOT'}",
	  "Configuration file: $opt{'LINTIAN_CFG'}",
	  "Laboratory: $opt{'LINTIAN_LAB'}",
	  "Archive directory: $opt{'LINTIAN_ARCHIVEDIR'}",
	  "Distribution: $opt{'LINTIAN_DIST'}",
	  "Architecture: $opt{'LINTIAN_ARCH'}",
	  delimiter(),
    );

our $TAGS = Lintian::Tags->new;
$TAGS->show_experimental($opt{'display-experimental'});
$TAGS->show_pedantic($opt{'pedantic'});
$TAGS->show_overrides($opt{'show-overrides'});
$TAGS->sources(keys %display_source) if %display_source;
$TAGS->only(split(/,/, $check_tags)) if defined $check_tags;
$TAGS->suppress(keys %suppress_tags) if %suppress_tags;

if ($no_profile) {
    # No profile if we have been given explicit list
    $opt{'LINTIAN_PROFILE'} = '';
    # if tags are listed explicitly (--tags) then show them even if
    # they are pedantic/experimental etc.  However, for --check-part
    # people explictly have to pass the relevant options.
    if ($check_tags) {
	$TAGS->show_experimental(1);
	$TAGS->show_pedantic(1);
	# discard whatever is in @display_level and request
	# everything
	@display_level = ();
	display_infotags();
    }
} else {
    unless ($opt{'LINTIAN_PROFILE'}){
	# Time to ask dpkg-vendor for a vendor name
	$opt{'LINTIAN_PROFILE'} = find_default_profile(@prof_inc, "$opt{'LINTIAN_ROOT'}/profiles");
    }
}

if ($opt{'LINTIAN_PROFILE'}) {
    my $profile = Lintian::Profile->new($opt{'LINTIAN_PROFILE'},
					[@prof_inc, "$opt{'LINTIAN_ROOT'}/profiles"]);
    my @ptags = $profile->tags;
    my @non_overridable = $profile->non_overridable_tags;
    my $severities = $profile->severity_changes;
    v_msg('Using profile ' . $profile->name . '.');
    $TAGS->only(@ptags) if @ptags;
    $TAGS->non_overridable_tags(@non_overridable) if @non_overridable;
    while ( my ($tagname, $severity) = each(%$severities) ){
	my $tag = Lintian::Tag::Info->new($tagname);
	$tag->set_severity($severity);
    }
}

# 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 = Lab->new( $opt{'LINTIAN_LAB'} );

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

    $LAB->setup_static()
	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->delete_static()
	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");
}

# sanity check:
fail('lintian lab has not been set up correctly (perhaps you forgot to run lintian --setup-lab?)')
    unless $LAB->is_lab();

#XXX: There has to be a cleaner way to do this
#  Update the ENV var as well
$ENV{'LINTIAN_LAB'} = $opt{'LINTIAN_LAB'} = $LAB->{dir};


# }}}

# {{{ Compile list of files to process

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

# Store contents of the packages files in these if needed
my ($src_info, $bin_info, $udeb_info);


while (my $arg = shift) {
    # file?
    if (-f $arg) {
	if ($arg =~ m/\.(?:u?deb|dsc|changes)$/o){
	    $pool->add_file($arg);
	} else {
	    fail("bad package file name $arg (neither .deb, .udeb, .changes or .dsc file)");
	}
    } else {
	# parameter is a package name--so look it up
	# search the distribution first, then the lab
	# special case: search only in lab if action is `remove'

	my $search;
	if ($action eq 'remove') {
	    # search only in lab--see below
	    $search = 'lab';
	} else {
	    # search in dist, then in lab
	    $search = 'dist or lab';

	    my $found = 0;

	    if (($pkg_mode eq 'b') or ($pkg_mode eq 'a')) {
		$bin_info = read_bin_list("$opt{'LINTIAN_LAB'}/info/binary-packages") unless $bin_info;
		if ($bin_info->{$arg}) {
		    $pool->add_file("$opt{'LINTIAN_ARCHIVEDIR'}/" . $bin_info->{$arg}->{'file'});
		    $found = 1;
		}
	    }
	    if (($pkg_mode eq 'u') or ($pkg_mode eq 'a')) {
		$udeb_info = read_bin_list("$opt{'LINTIAN_LAB'}/info/udeb-packages") unless $udeb_info;
		if ($udeb_info->{$arg}) {
		    $pool->add_file("$opt{'LINTIAN_ARCHIVEDIR'}/" . $udeb_info->{$arg}->{'file'});
		    $found = 1;
		}
	    }
	    if (($pkg_mode eq 's') or ($pkg_mode eq 'a')) {
		$src_info = read_src_list("$opt{'LINTIAN_LAB'}/info/source-packages") unless $src_info;

		if ($src_info->{$arg}) {
		    $pool->add_file("$opt{'LINTIAN_ARCHIVEDIR'}/" . $src_info->{$arg}->{'file'});
		    $found = 1;
		}
	    }

	    next if $found;
	}

	# nothing found so far, so search the lab

	my $b = "$opt{'LINTIAN_LAB'}/binary/$arg";
	my $s = "$opt{'LINTIAN_LAB'}/source/$arg";
	my $u = "$opt{'LINTIAN_LAB'}/udeb/$arg";

	if ($pkg_mode eq 'b') {
	    unless (-d $b) {
		warn "error: cannot find binary package $arg in $search (skipping)\n";
		$exit_code = 2;
		next;
	    }
	} elsif ($pkg_mode eq 's') {
	    unless (-d $s) {
		warning("cannot find source package $arg in $search (skipping)");
		$exit_code = 2;
		next;
	    }
	} elsif ($pkg_mode eq 'u') {
	    unless (-d $u) {
		warning("cannot find udeb package $arg in $search (skipping)");
		$exit_code = 2;
		next;
	    }
	} else {
	    # $pkg_mode eq 'a'
	    unless (-d $b or -d $s or -d $u) {
		warning("cannot find binary, udeb or source package $arg in $search (skipping)");
		$exit_code = 2;
		next;
	    }
	}

	# FIXME: Use Lab to find the deb/dsc instead?
	if (($pkg_mode eq 'b') or (($pkg_mode eq 'a') and (-d $b))) {
	    $pool->add_file("$b/deb");
	}
	if (($pkg_mode eq 's') or (($pkg_mode eq 'a') and (-d $s))) {
	    $pool->add_file("$s/dsc");
	}
	if (($pkg_mode eq 'u') or (($pkg_mode eq 'a') and (-d $u))) {
	    $pool->add_file("$u/deb");
	}
    }
}

if ($check_everything) {
    # make sure package info is available
    $src_info  = read_src_list("$opt{'LINTIAN_LAB'}/info/source-packages") unless $src_info;
    $bin_info  = read_bin_list("$opt{'LINTIAN_LAB'}/info/binary-packages") unless $bin_info;
    $udeb_info = read_bin_list("$opt{'LINTIAN_LAB'}/info/udeb-packages") unless $udeb_info;

    debug_msg(2, "pkg_mode = $pkg_mode");

    if (($pkg_mode eq 'a') or ($pkg_mode eq 's')) {
	for my $arg (sort keys %$src_info) {
	    debug_msg(1, "doing stuff with $opt{'LINTIAN_ARCHIVEDIR'}/" . $src_info->{$arg}->{'file'});
	    $pool->add_file("$opt{'LINTIAN_ARCHIVEDIR'}/" . $src_info->{$arg}->{'file'});
	}
    }
    if (($pkg_mode eq 'a') or ($pkg_mode eq 'b')) {
	for my $arg (sort keys %$bin_info) {
	    debug_msg(1, "doing stuff with $opt{'LINTIAN_ARCHIVEDIR'}/" . $bin_info->{$arg}->{'file'});
	    $pool->add_file("$opt{'LINTIAN_ARCHIVEDIR'}/" . $bin_info->{$arg}->{'file'});
	}
    }
    if (($pkg_mode eq 'a') or ($pkg_mode eq 'u')) {
	for my $arg (sort keys %$udeb_info) {
	    debug_msg(1, "doing stuff with $opt{'LINTIAN_ARCHIVEDIR'}/" . $udeb_info->{$arg}->{'file'});
	    $pool->add_file("$opt{'LINTIAN_ARCHIVEDIR'}/" . $udeb_info->{$arg}->{'file'});
	}
    }
} elsif ($packages_file) {
    # process all packages listed in packages file?
    print STDERR "warning: --packages-file is deprecated and may be removed in a later release.\n";
    print STDERR "  - consider using --packages-from-file (one pkg per line)\n";
    open(my $pkgin, '<', $packages_file) or fail("Reading $packages_file: $!");
    while (my $line = <$pkgin>) {
	chomp($line);
	my ($t, undef, undef, $file) = split(/\s+/, $line, 4);
	unless (defined $file && length $t == 1) {
	    print STDERR "Syntax error in packages-file at line $.\n";
	    print STDERR " - perhaps you meant to use \"--packages-from-file $packages_file\"\n";
	    exit 1;
	}
	$pool->add_file($file);
    }
    close($pkgin);
} elsif ($opt{'packages-from-file'}){
    my $fd;
    if ($opt{'packages-from-file'} eq '-') {
	$fd = \*STDIN;
    } else {
	open $fd, '<', $opt{'packages-from-file'} or die "opening $opt{'packages-from-file'}: $!";
    }
    while (my $file = <$fd>) {
	chomp($file);
	$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 '-';
}

# undef these as they are not needed any more and they give a cheap
# extra 5+ MB of RAM back on lintian.d.o.
undef $src_info;
undef $bin_info;
undef $udeb_info;

# }}}

# {{{ 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 $proc ($group->get_processables()){
	    my $lpkg;
	    my $pkg_name = $proc->pkg_name();
	    my $pkg_ver  = $proc->pkg_version();
	    my $pkg_type = $proc->pkg_type();
	    my $pkg_path = $proc->pkg_path();
	    my $pkg_arch = $proc->pkg_arch();
	    eval{
		$lpkg = $LAB->get_lab_package($pkg_name, $pkg_ver, $pkg_arch,
					      $pkg_type, $pkg_path);
	    };
	    if(!defined($lpkg)){
		my $err = '.';
		$err = ": $@" if(defined($@));
		warning("skipping $action of $pkg_type package ${pkg_name}$err");
		$exit_code = 2;
		next;
	    }
	    $TAGS->file_start($pkg_path, $pkg_name, $pkg_ver,
			      $pkg_arch, $pkg_type);
	    debug_msg(1, 'Removing package in lab ...');
	    unless($lpkg->delete_lab_entry()){
		warning("cannot remove entry for $pkg_name: $!");
		$exit_code = 2;
	    }
	}
    }
    $TAGS->file_end();
    exit $exit_code;
}
# }}}

# {{{ Load information about collector scripts
load_collections(\%collection_info, "$opt{'LINTIAN_ROOT'}/collection");
# }}}

# {{{ Now we're ready to load info about checks & tags

# load information about checker scripts
load_checks(\%check_info, $TAGS, "$opt{'LINTIAN_ROOT'}/checks");

# }}}

# {{{ determine which checks have been requested
if ($action eq 'check') {
    # create check_abbrev hash
    for my $c (keys %check_info) {
	$check_abbrev{$check_info{$c}->{'abbrev'}} = $c;
    }

    if ($check_tags) {
	foreach my $t (split(/,/, $check_tags)) {
	    my $info = Lintian::Tag::Info->new($t);

	    fail("unknown tag specified: $t") unless defined($info);
	    my $script = $info->script;
	    next if $script eq 'lintian';
	    if ($check_info{$script}) {
		$enabled_checks{$script} = 1;
	    } else {
		# should never happen
		fail("no info for script $script");
	    }
	}
    } else {
	my %dont_check = map { $_ => 1 } (split m/,/, ($dont_check || ''));
	$checks or ($checks = join(',',keys %check_info));
	for my $c (split(/,/,$checks)) {
	    if ($check_info{$c}) {
		if ($dont_check{$c}
		    || ($check_info{$c}->{'abbrev'}
			&& $dont_check{$check_info{$c}->{'abbrev'}})) {
		    #user requested not to run this check
		} elsif ($check_info{$c}->{'requested-tags'} == 0) {
		    #no need to run this check, no tags will be issued
		} else {
		    $enabled_checks{$c} = 1;
		}
	    } elsif (exists $check_abbrev{$c}) {
		#abbrevs only used when -C is given, so we don't need %dont_check
		$enabled_checks{$check_abbrev{$c}} = 1;
	    } else {
		fail("unknown check specified: $c");
	    }
	}
    }

    # determine which info is needed by the checks
    for my $c (keys %enabled_checks) {
	for my $i (keys %collection_info) {
	    # required by $c ?
	    if ($check_info{$c}->{$i}) {
		$unpack_infos{$i} = 1;
	    }
	}
    }
}

# }}}

# {{{ determine which info is needed by the collection scripts
if ($action eq 'unpack') {
    # With --unpack we want all of it
    for my $c (keys %collection_info) {
	$unpack_infos{$c} = 1;
    }
} else {
    my @needed = keys %unpack_infos;
    my %added = ();
    unless ($opt{'no-override'}) {
	push @needed, 'override-file';
    }
    while ( my $c = pop @needed ) {
	next if $added{$c};
	$added{$c} = 1;
	$unpack_infos{$c} = 1;
	if (exists $collection_info{$c}{'needs-info'}) {
	    push @needed, @{$collection_info{$c}{'needs-info'}};
	}
    }
    if ($unpack_info) {
	# Add collections specifically requested by the user (--unpack-info)
	for my $i (split(/,/,$unpack_info)) {
	    unless ($collection_info{$i}) {
		fail("unknown info specified: $i");
	    }
	    $unpack_infos{$i} = 1;
	}
    }
}
# }}}

# {{{ Create the dependency tree and populate it with checks and collections

# All required checks and collections have been calculated at this point.
# We are just adding this information to a map now that will generate the
# execution order.

my $map = Lintian::DepMap::Properties->new();
my $collmap = Lintian::DepMap::Properties->new();

for my $c (keys %unpack_infos) {
    # Add the collections with their dependency information
    $map->add('coll-' . $c, {'type' => 'collection', 'name' => $c});
    $collmap->add('coll-' . $c, {'type' => 'collection', 'name' => $c});
    if (exists $collection_info{$c}{'needs-info'}) {
	$map->addp('coll-' . $c, 'coll-', @{$collection_info{$c}{'needs-info'}});
	$collmap->addp('coll-' . $c, 'coll-', @{$collection_info{$c}{'needs-info'}});
    }
}

for my $c (keys %enabled_checks) {
    # Add the checks with their dependency information
    $map->add('check-' . $c, {'type' => 'check', 'name' => $c});
    if (exists $check_info{$c}{'needs-info'}) {
	$map->addp('check-' . $c, 'coll-', @{$check_info{$c}{'needs-info'}});
    }
}
# }}}

# {{{ Okay, now really processing the packages in one huge loop
debug_msg(1,
	  "Selected action: $action",
	  sprintf('Requested data to collect: %s', join(',',sort keys %unpack_infos)),
	  sprintf('Selected checks: %s', join(',',sort keys %enabled_checks)),
    );


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

# Now action is always either "check" or "unpack"
# these two variables are used by process_package
#  and need to persist between invocations.
my %running_jobs;
my %overrides;

foreach my $gname (sort $pool->get_group_names()) {
    my $group = $pool->get_group($gname);
    unpack_group($group);
    if ($action eq 'check'){
	process_group($group);
	clear_group_cache($group);
    }
}

$TAGS->file_end();

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('Some overrides were ignored, since the tags were marked "non-overridable".');
    if ($opt{'verbose'}) {
	v_msg('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 - %running_jobs will usually be empty here
# 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.
while (my ($coll, undef) = Lintian::Command::Simple::wait(\%running_jobs)) {
    delete $running_jobs{$coll};
}
%running_jobs = ();

exit $exit_code;

# {{{ Some subroutines

#  Check to make sure there are packages to check.
sub set_value {
    my ($f,$target,$field,$source,$required) = @_;
    if ($required and not defined($source->{$field})) {
	fail("description file $f does not define required tag $field");
    }
    $target->{$field} = $source->{$field};
    delete $source->{$field};
}


# Given a ref to %collection_info and the path to the collection
# directory, this will load all the collection information into
# %collection_info.
sub load_collections{
    my ($cinfo, $dirname) = @_;
    opendir(my $dir, $dirname)
	or fail("cannot read directory $dirname");

    for my $f (readdir($dir)) {
	next if $f =~ /^\./;
	next unless $f =~ /\.desc$/;

	debug_msg(2, "Reading collector description file $f ...");
	my @secs = read_dpkg_control("$dirname/$f");
	my $script;
	($#secs+1 == 1)
	    or fail("syntax error in description file $f: too many sections");

	($script = $secs[0]->{'collector-script'})
	    or fail("error in description file $f: `Collector-Script:' not defined");

	delete $secs[0]->{'collector-script'};
	$cinfo->{$script}->{'script'} = $script;
	my $p = $cinfo->{$script};

	set_value($f, $p,'type',$secs[0],1);
	# convert Type:
	my %type;
	for (split(/\s*,\s*/o,$p->{'type'})) {
	    if ($_ eq 'binary' || $_ eq 'source' || $_ eq 'udeb'
		|| $_ eq 'changes') {
		$type{$_} = 1;
	    } else {
		fail("unknown type $_ specified in description file $f");
	    }
	}
	$p->{'type'} = \%type;

	set_value($f,$p,'version',$secs[0],1);
	set_value($f,$p,'auto-remove',$secs[0],0);

	if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
	    for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
		push @{$p->{'needs-info'}}, $_;
	    }
	    delete $secs[0]->{'needs-info'};
	}

	# ignore Info: and other fields for now
	delete $secs[0]->{'info'};
	delete $secs[0]->{'author'};

	for (keys %{$secs[0]}) {
	    warning("unused tag $_ in description file $f");
	}

	debug_msg(2, map( { "$_: $p->{$_}" if defined($p->{$_}) } sort keys %$p ));
    }

    closedir($dir);
}

# Given a ref to %check_info, $TAGS  and the path to the checks
# directory, this will load all the information about checks into
# %check_info.
sub load_checks{
    my ($cinfo, $tags, $dirname) = @_;
    opendir(my $dir, $dirname)
	or fail("cannot read directory $dirname");

    for my $f (readdir($dir)) {
	next if $f =~ /^\./;
	next unless $f =~ /\.desc$/;
	debug_msg(2, "Reading checker description file $f ...");

	my @secs = read_dpkg_control("$dirname/$f");
	my $script;
	($script = $secs[0]->{'check-script'})
	    or fail("error in description file $f: `Check-Script:' not defined");

	# ignore check `lintian' (this check is a special case and contains the
	# tag info for the lintian frontend--this script here)
	next if $script eq 'lintian';

	delete $secs[0]->{'check-script'};
	$cinfo->{$script}->{'script'} = $script;
	my $p = $cinfo->{$script};

	set_value($f,$p,'type',$secs[0],1);
	my %type;
	# convert Type:
	for (split(/\s*,\s*/o,$p->{'type'})) {
	    if ($_ eq 'binary' || $_ eq 'source' || $_ eq 'udeb'
		|| $_ eq 'changes') {
		$type{$_} = 1;
	    } else {
		fail("unknown type $_ specified in description file $f");
	    }
	}
	$p->{'type'} = \%type;

	set_value($f,$p,'abbrev',$secs[0],1);

	if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
	    for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
		push @{$p->{'needs-info'}}, $_;
		$p->{$_} = 1;
	    }
	    delete $secs[0]->{'needs-info'};
	}

	# ignore Info: and other fields for now...
	delete $secs[0]->{'info'};
	delete $secs[0]->{'standards-version'};
	delete $secs[0]->{'author'};

	for (keys %{$secs[0]}) {
	    warning("unused tag $_ in description file $f");
	}

	debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));

	shift(@secs);
	$p->{'requested-tags'} = 0;
	foreach my $tag (@secs) {
	    $p->{'requested-tags'}++ if $tags->displayed($tag->{'tag'});
	}
    }
    closedir($dir);
}


# Removes all collections with "Auto-Remove: yes"; takes a Lab::Package
#  - depends on global variables %collection_info and $opt{'LINTIAN_ROOT'}
sub auto_clean_package {
    my ($lpkg) = @_;
    my $pkg_name = $lpkg->pkg_name();
    my $pkg_type = $lpkg->pkg_type();
    my $base = $lpkg->base_dir();
    for my $coll (keys %collection_info) {
	my $ci = $collection_info{$coll};
	if (defined($ci->{'auto-remove'}) && $ci->{'auto-remove'} eq 'yes') {
	    next unless (-f "$base/.${coll}-$ci->{'version'}");
	    my $script = "$opt{'LINTIAN_ROOT'}/collection/$ci->{'script'}";
	    debug_msg(1, "Auto removing: $ci->{'script'} ...");
	    unless (Lintian::Command::Simple::rundir($base, $script, $pkg_name, "remove-${pkg_type}") == 0) {
		warning("removing collect info $coll about package $pkg_name failed",
			"skipping cleanup of $pkg_type package $pkg_name");
		return 0;
	    }
	    unlink("$base/.${coll}-$ci->{'version'}")
		or fail("failed to remove status file of collect info $coll about package $pkg_name");
	}
    }
    return 1;
}

sub post_pkg_process_overrides{
    my ($pkg_path) = @_;
    # report unused overrides
    if (not $opt{'no-override'}) {
	my $overrides = $TAGS->overrides($pkg_path);

	for my $tag (sort keys %$overrides) {
	    next if $TAGS->suppressed($tag);

	    # Did we run the check script containing the tag?
	    my $taginfo = Lintian::Tag::Info->new($tag);
	    if (defined $taginfo) {
		next unless $enabled_checks{$taginfo->script};
	    }

	    for my $extra (sort keys %{$overrides->{$tag}}) {
		next if $overrides->{$tag}{$extra};
		tag( 'unused-override', $tag, $extra );
	    }
	}
    }

    # Report override statistics.
    if (not $opt{'no-override'} and not $opt{'show-overrides'}) {
	my $stats = $TAGS->statistics($pkg_path);
	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;
    }
}

sub unpack_group {
    my ($group) = @_;
  PROC:
    foreach my $proc ($group->get_processables()){
	my $pkg_name = $proc->pkg_name();
	my $pkg_type = $proc->pkg_type();
	my $pkg_path = $proc->pkg_path();
	my $pkg_ver  = $proc->pkg_version();
	my $pkg_arch = $proc->pkg_arch();
	my $lpkg;
	my $base;
	my $info;
	eval{
	    $lpkg = $LAB->get_lab_package($pkg_name, $pkg_ver, $pkg_arch,
					  $pkg_type, $pkg_path);
	};
	if(!defined($lpkg)){
	    my $err = '.';
	    $err = ": $@" if(defined($@));
	    warning("skipping $action of $pkg_type package ${pkg_name}$err");
	    $exit_code = 2;
	    $group->remove_processable($proc);
	    next;
	}
	# determine base directory
	$base = $lpkg->base_dir();
	debug_msg(1, "Unpacking $pkg_name $pkg_ver [$pkg_arch] ($pkg_type) in $base");

	# Ensure it has been unpacked
	unless ($lpkg->create_entry()){
	    warning("could not create the package entry in the lab: $!",
		    "skipping $action of $pkg_type package $pkg_name");
	    $exit_code = 2;
	    $group->remove_processable($proc);
	    next;
	}
	# Kill pending jobs, if any
	Lintian::Command::Simple::kill(\%running_jobs);
	%running_jobs = ();
	$collmap->initialise();
	while ($collmap->pending) {
	    foreach my $req ($collmap->selectable) {
		my $ri = $collmap->getProp($req);
		my $coll = $ri->{'name'};
		my $ci = $collection_info{$coll};

		# current type?
		unless (exists $ci->{'type'}{$pkg_type}) {
		    $collmap->satisfy($req);
		    next;
		}

		# check if it has been run previously
		if ($lpkg->_is_coll_finished($coll, $ci->{'version'})) {
		    $collmap->satisfy($req);
		    next;
		}
		# Not run before (or out of date)
		$lpkg->_clear_coll_status($coll);

		# collect info
		$collmap->select($req);
		unless ($lpkg->remove_status_file()) {
		    warning("cannot remove status file $pkg_name: $!");
		}
		debug_msg(1, "Collecting info: $coll ...");
		my $script = "$opt{'LINTIAN_ROOT'}/collection/$ci->{'script'}";
		my $cmd = Lintian::Command::Simple->new();
		unless ($cmd->background_dir($base, $script, $pkg_name, $pkg_type) > 0) {
		    warning("collect info $coll about package $pkg_name failed",
			    "skipping $action of $pkg_type package $pkg_name");
		    $exit_code = 2;
		    $group->remove_processable($proc);
		    next PROC;
		}
		$running_jobs{$coll} = $cmd;
	    }
	    # wait until a job finishes to run its branches, if any, or skip
	    # this package if any of the jobs failed.
	    debug_msg(1, "Reaping done jobs ... unpack $pkg_name $pkg_ver [$pkg_arch] ($pkg_type)");

	    while (my ($coll, $cmd) = Lintian::Command::Simple::wait(\%running_jobs)) {
		delete $running_jobs{$coll};
		if ($cmd->status() == 0) {
		    my $ci = $collection_info{$coll};
		    $lpkg->_mark_coll_finished($coll, $ci->{'version'})
			or fail("cannot mark $coll for complete: $!");
		    debug_msg(1, "Collection script $coll done");
		} else {
		    warning("collect info $coll about package $pkg_name failed");
		    warning("skipping $action of $pkg_type package $pkg_name");
		    $exit_code = 2;
		    $group->remove_processable($proc);
		    next PROC;
		}

		$collmap->satisfy('coll-' . $coll);
	    }
	    debug_msg(1, "Reap done jobs ... unpack $pkg_name $pkg_ver [$pkg_arch] ($pkg_type)");
	}

	if ($action eq 'check') {
	    # We only need this if we are checking the package later
	    $proc->lab_pkg($lpkg);
	} else {
	    # else we are done - not sure if it makes any sense if we are unpacking
	    # but this is the old behaviour, so we stick with it.
	    if (!$keep_lab) {
		auto_clean_package($lpkg) or $exit_code = 2;
	    }

	    # All successful, make sure to record it so we do not recheck the same package
	    # in a later run (mostly for archive-wide checks).
	    if ($lpkg->update_status_file($LINTIAN_VERSION) < 1) {
		warning("could not create status file for package $pkg_name: $!");
	    }
	}
    }
    return 1;
}

sub process_group {
    my ($group) = @_;
  PROC:
    foreach my $proc ($group->get_processables()){
	my $pkg_name = $proc->pkg_name();
	my $pkg_ver  = $proc->pkg_version();
	my $pkg_type = $proc->pkg_type();
	my $pkg_path = $proc->pkg_path();
	my $pkg_arch = $proc->pkg_arch();
	my $lpkg = $proc->lab_pkg();
	my $info = $proc->info();
	my $base = $lpkg->base_dir();

	$TAGS->file_start($pkg_path, $pkg_name, $pkg_ver, $pkg_arch, $pkg_type);
	$collmap->initialise();
	$map->initialise();
	# put the check map into a state where all collections has been run
	#  - this may seem redundant, but it allowed re-use of existing
	#    code to skip checks that are irrevalant for the type of pkg.
	while ($collmap->pending){
	    foreach my $req ($collmap->selectable){
		$collmap->satisfy($req);
		$map->satisfy($req);
	    }
	}

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

	# chdir to base directory
	unless (chdir($base)) {
	    warning("could not chdir into directory $base: $!",
		    "skipping $action of $pkg_type package $pkg_name");
	    $exit_code = 2;
	    next;
	}

	unless ($opt{'no-override'}) {
	    if ($collmap->done('coll-override-file')) {
		debug_msg(1, 'Override file collected, loading it ...');
		$TAGS->file_overrides("$base/override")
		    if (-f "$base/override");
	    }
	}
	while ($map->pending) {
	    foreach my $req (sort $map->selectable) {
		my $ri = $map->getProp($req);
		my $check = $ri->{'name'};
		my $ci = $check_info{$check};

		# current type?
		unless (exists $ci->{'type'}{$pkg_type}) {
		    $map->satisfy($req);
		    next;
		}

		debug_msg(1, "Running check: $check ...");
		my $returnvalue = Checker::runcheck($pkg_name, $pkg_type, $info, $check, $proc, $group);
		# Set exit_code correctly if there was not yet an exit code
		$exit_code = $returnvalue unless $exit_code;

		if ($returnvalue == 2) {
		    warning("skipping $action of $pkg_type package $pkg_name");
		    $exit_code = 2;
		    next PROC;
		}
		$map->satisfy($req);
	    }
	}
	# chdir to lintian root directory (to unlock $base so it can be removed below)
	unless (chdir($opt{'LINTIAN_ROOT'})) {
	    warning("could not chdir into directory $opt{'LINTIAN_ROOT'}: $!",
		    "skipping $action of $pkg_type package $pkg_name");
	    $exit_code = 2;
	    next;
	}

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

	if (!$keep_lab) {
	    auto_clean_package($lpkg) or $exit_code = 2;
	}

	# All successful, make sure to record it so we do not recheck the same package
	# in a later run (mostly for archive-wide checks).
	if ($lpkg->update_status_file($LINTIAN_VERSION) < 1) {
	    warning("could not create status file for package $pkg_name: $!");
	}

    } # end foreach my $proc ($group->get_processable())

    return 1;
}


# cleans the cache of all elements in this group - this avoids
# memory being hogged by packages/groups that have been checked
# and will not be checked again.
sub clear_group_cache {
    my ($group) = @_;
    foreach my $proc ($group->get_processables()){
	$proc->clear_cache;
    }
    return 1;
}

# }}}

# {{{ Exit handler.

sub END {
    # Prevent Lab::delete from affecting the exit code.
    local $?;

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

    # Kill any remaining jobs.
    if(%running_jobs) {
	Lintian::Command::Simple::kill(\%running_jobs);
	%running_jobs = ();
    }

    $LAB->delete() if $LAB and not $keep_lab;
}

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

# }}}

# Local Variables:
# indent-tabs-mode: t
# cperl-indent-level: 4
# End:
# vim: sw=4 ts=8 noet fdm=marker
