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

# {{{ Global Variables
my $LINTIAN_VERSION = "<VERSION>";	#External Version number
my $BANNER = "Lintian v$LINTIAN_VERSION"; #Version Banner - text form
my $LAB_FORMAT = 9;		#Lab format Version Number
				#increased whenever incompatible
				#changes are done to the lab
				#so that all packages are re-unpacked

# 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 $verbose = 0;		#flag for -v|--verbose switch
my $quiet = 0;			#flag for -q|--quiet switch
my @debug;
my $check_everything = 0;	#flag for -a|--all switch
my $lintian_info = 0;		#flag for -i|--info switch
our $display_experimentaltags = 0; #flag for -E|--display-experimental switch
our $display_pedantictags = 0;	#flag for --pedantic switch
my $unpack_level = undef;	#flag for -l|--unpack-level switch
our $no_override = 0;		#flag for -o|--no-override switch
our $show_overrides = 0;	#flag for --show-overrides switch
my $color = 'never';		#flag for --color switch
my $check_checksums = 0;	#flag for -m|--md5sums|--checksums switch
my $allow_root = 0;		#flag for --allow-root switch
my $fail_on_warnings = 0;       #flag for --fail-on-warnings switch
my $keep_lab = 0;		#flag for --keep-lab switch
my $packages_file = 0;		#string for the -p option
our $OPT_LINTIAN_LAB = "";	#string for the --lab option
our $OPT_LINTIAN_ARCHIVEDIR = "";#string for the --archivedir option
our $OPT_LINTIAN_DIST = "";	#string for the --dist option
our $OPT_LINTIAN_ARCH = "";	#string for the --arch option
our $OPT_LINTIAN_AREA = "";	#string for the --area option
# These options can also be used via default or environment variables
our $LINTIAN_CFG = "";		#config file to use
our $LINTIAN_ROOT;		#location of the lintian modules
our $OPT_LINTIAN_SECTION = "";  #old name for OPT_LINTIAN_ARCH

my $experimental_output_opts = undef;

my @severities = qw(wishlist minor normal important serious);
my @certainties = qw(wild-guess possible certain);
my %display_level = ();
my %display_source = ();

my $schedule;

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

my %collection_info;
my %already_scheduled;
my %checks;
my %check_abbrev;
my %unpack_infos;
my %check_info;

# reset configuration variables
our $LINTIAN_LAB = undef;
our $LINTIAN_ARCHIVEDIR = undef;
our $LINTIAN_DIST = undef;
our $LINTIAN_UNPACK_LEVEL = undef;
our $LINTIAN_ARCH = undef;
our $LINTIAN_SECTION = undef;
our $LINTIAN_AREA = undef;
# }}}

# {{{ Setup Code

#turn off file buffering
$| = 1;

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

# }}}

# {{{ 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:
    -S, --setup-lab           set up static lab
    -R, --remove-lab          remove static lab
    -c, --check               check packages (default action)
    -C X, --check-part X      check only certain aspects
    -X X, --dont-check-part X don\'t check certain aspects
    -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
    -r, --remove              remove package from the lab
General options:
    -h, --help                display short help text
    -v, --verbose             verbose messages
    -V, --version             display Lintian version and exit
    --print-version           print unadorned version number and exit
    -d, --debug               turn Lintian\'s debug messages ON
    -q, --quiet               suppress all informational messages
Behaviour options:
    -i, --info                give detailed info about tags
    -I, --display-info        display "I:" tags (normally suppressed)
    -E, --display-experimental display "X:" tags (normally suppressed)
    --pedantic                display "P:" tags (normally suppressed)
    -L, --display-level       display tags with the specified level
    --display-source X        restrict displayed tags by source
    -l X, --unpack-level X    set default unpack level to X
    -o, --no-override         ignore overrides
    --show-overrides          output tags that have been overriden
    --color never/always/auto disable, enable, or enable color for TTY
    -U X, --unpack-info X     specify which info should be collected
    -m, --md5sums, --checksums check checksums when processing a .changes file
    --allow-root              suppress lintian\'s warning when run as root
    --fail-on-warnings        return a non-zero exit status if warnings found
    --keep-lab                keep lab after run, even if temporary
Configuration options:
    --cfg CONFIGFILE          read CONFIGFILE for configuration
    --lab LABDIR              use LABDIR as permanent laboratory
    --archivedir ARCHIVEDIR   location of Debian archive to scan for packages
    --dist DIST               scan packages in this distribution (e.g. sid)
    --area AREA               scan packages in this archive area (e.g. main)
    --arch ARCH               scan packages with architecture ARCH
    --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
    -s, --source              process only source packages
    --udeb                    process only udeb packages
    -p X, --packages-file X   process all files in file (special syntax!)
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]";
}

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

# Record Parts requested for checking
# Options: --tags-from-file
sub record_check_tags_from_file {
    open my $file, '<', $_[1]
	or fail("failed to open $_[1]: $!");
    my $tags =  join(',', map { chomp($_); $_ } <$file>);
    close $file;

    record_check_tags($_[0], $tags);
}


# 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 $level = $_[1];
    if ($level =~ m/^\+(.+)/) {
	set_display_level($1, 1);
    } elsif ($level =~ m/^\-(.+)/) {
	set_display_level($1, 0);
    } elsif ($level =~ m/^\=?(.+)/) {
	reset_display_level();
	set_display_level($1, 1);
    } else {
	die "invalid argument to --display-level: $level\n";
    }
}

# Process -I|--display-info flag
sub display_infotags {
    foreach my $s (@severities) {
	set_display_level($s, 1);
    }
}

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

# Clears current display level information, disabling all severities and
# certainties
sub reset_display_level {
    foreach my $s (@severities) {
	foreach my $c (@certainties) {
	    $display_level{$s}{$c} = 0;
	}
    }
}

sub set_display_level_multi {
    my ($op, $level, $val) = @_;

    my @inc_severities = @severities;
    my @inc_certainties = @certainties;
    my $inc_border = ($op =~ /^[<>]=$/) ? 1 : 0;
    if ($op =~ /^>/) {
	@inc_severities = reverse @inc_severities;
	@inc_certainties = reverse @inc_certainties;
    }
    my $severity = join("|", @severities);
    my $certainty = join("|", @certainties);
    if ($level =~ m/^($severity)$/) {
	foreach my $s (cut_list($level, $inc_border, @inc_severities)) {
	    map { $display_level{$s}{$_} = $val } @certainties;
	}
    } elsif ($level =~ m/^($certainty)$/) {
	foreach my $c (cut_list($level, $inc_border, @inc_certainties)) {
	    map { $display_level{$_}{$c} = $val } @severities;
	}
    } elsif ($level =~ m/^($severity)\/($certainty)$/) {
	foreach my $s (cut_list($1, $inc_border, @inc_severities)) {
	    foreach my $c (cut_list($2, $inc_border, @inc_certainties)) {
		$display_level{$s}{$c} = $val;
	    }
	}
    } else {
	die "invalid argument to --display-level: $level\n";
    }

}

sub cut_list {
    my ($border, $inc_border, @list) = @_;

    my (@newlist, $found);
    foreach (@list) {
	if ($_ eq $border) {
	    push @newlist, $_ if $inc_border;
	    $found = 1;
	    last;
	} else {
	    push @newlist, $_;
	}
    }
    die "internal error: cut_list did not find border $border\n"
	unless $found;
    if (!$inc_border and !@newlist
	and $border eq $list[0]) {
	warn "warning: display level $border specified with > (or <) is empty set, assuming >= (or <=)\n";
	push @newlist, $list[0];
    }

    return @newlist;
}

# Parse input display level to enable (val 1) or disable (val 0) it
# accordingly
sub set_display_level {
    my ($level, $val) = @_;
    if ($level =~ m/^([<>]=?)(.+)/) {
	set_display_level_multi($1, $2, $val);
	return;
    }

    my $severity = join("|", @severities);
    my $certainty = join("|", @certainties);
    if ($level =~ m/^($severity)$/) {
	map { $display_level{$1}{$_} = $val } @certainties;
    } elsif ($level =~ m/^($certainty)$/) {
	map { $display_level{$_}{$1} = $val } @severities;
    } elsif ($level =~ m/^($severity)\/($certainty)$/) {
	$display_level{$1}{$2} = $val;
    } else {
	die "invalid argument to --display-level: $level\n";
    }
}

# 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,
	       "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" => \$verbose,
	       "debug|d" => \@debug, # Count the -d flags
	       "quiet|q" => \$quiet,

	       # ------------------ behaviour options
	       "info|i" => \$lintian_info,
	       "display-info|I" => \&display_infotags,
	       "display-experimental|E" => \$display_experimentaltags,
	       "pedantic" => \$display_pedantictags,
	       "display-level|L=s" => \&record_display_level,
	       "display-source=s" => \&record_display_source,
	       "unpack-level|l=i" => \$unpack_level,
	       "no-override|o" => \$no_override,
	       "show-overrides" => \$show_overrides,
	       "color=s" => \$color,
	       "unpack-info|U=s" => \&record_unpack_info,
	       "checksums|md5sums|m" => \$check_checksums,
	       "allow-root" => \$allow_root,
	       "fail-on-warnings" => \$fail_on_warnings,
	       "keep-lab" => \$keep_lab,
	       # Note: Ubuntu has (and other derivatives might gain) a
	       # -D/--debian option to make lintian behave like in Debian, that
	       # is, to revert distribution-specific changes

	       # ------------------ configuration options
	       "cfg=s" => \$LINTIAN_CFG,
	       "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,
	       "root=s" => \$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,

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

# init display level settings
reset_display_level();
set_display_level_multi('>=', 'important', 1);
set_display_level_multi('>=', 'normal/possible', 1);
set_display_level('minor/certain', 1);

# 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 current working directory--we'll need this later
chop($cwd = `pwd`);

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

# keep-lab implies unpack-level=2 unless explicetly
# given otherwise
if ($keep_lab and not defined $unpack_level) {
    $unpack_level = 2;
}

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

# check permitted values for --color
if ($color and $color !~ /^(never|always|auto|html)$/) {
    die "invalid argument to --color: $color\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) {
    syntax();
}

# }}}

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

# search for configuration file if it was not set with --cfg
# do not search the default locations if it was set.
if ($LINTIAN_CFG) {
} elsif (exists $ENV{'LINTIAN_CFG'} &&
	 -f ($LINTIAN_CFG = $ENV{'LINTIAN_CFG'})) {
} elsif (-f ($LINTIAN_CFG = $LINTIAN_ROOT . '/lintianrc')) {
} elsif (exists $ENV{'HOME'} &&
	 -f ($LINTIAN_CFG = $ENV{'HOME'} . '/.lintianrc')) {
} elsif (-f ($LINTIAN_CFG = '/etc/lintianrc')) {
} else {
    undef $LINTIAN_CFG;
}

use constant VARS => qw(LAB ARCHIVEDIR DIST UNPACK_LEVEL SECTION AREA ARCH);
# read configuration file
if ($LINTIAN_CFG) {
    open(CFG, '<', $LINTIAN_CFG)
	or die("cannot open configuration file $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 (VARS) {
	    no strict 'refs';
	    $var = "LINTIAN_$var";
	    if (m/^\s*$var\s*=\s*(.*\S)\s*$/i) {
		$$var = $1;
		$found = 1;
		last;
	    }
	}
	unless ($found) {
	    die "syntax error in configuration file: $_\n";
	}
    }
    close(CFG);
}

# environment variables overwrite settings in conf file:
foreach (VARS) {
    no strict 'refs';
    my $var = "LINTIAN_$_";
    my $opt_var = "OPT_$var";
    $$var = $ENV{$var} if $ENV{$var};
    $$var = $$opt_var if $$opt_var;
}

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

# LINTIAN_SECTION is deprecated in favour of LINTIAN_AREA
if (defined $LINTIAN_SECTION) {
    print STDERR "warning: LINTIAN_SECTION has been deprecated in favour of LINTIAN_AREA.\n";
    if (defined $LINTIAN_AREA) {
	print STDERR "Using LINTIAN_AREA as both were defined.\n";
    } else {
	print STDERR "Both are currently accepted, but LINTIAN_SECTION may be removed\n";
	print STDERR "in a future Lintian release.\n";
	$LINTIAN_AREA = $LINTIAN_SECTION;
    }
}

# determine requested unpack level
if (defined($unpack_level)) {
    # specified through command line
} elsif (defined($LINTIAN_UNPACK_LEVEL)) {
    # specified via configuration file or env variable
    $unpack_level = $LINTIAN_UNPACK_LEVEL;
} else {
    # determine by action
    if (($action eq 'unpack') or ($action eq 'check')) {
	$unpack_level = 1;
    } else {
	$unpack_level = 0;
    }
}
unless (($unpack_level == 0) or ($unpack_level == 1) or ($unpack_level == 2)) {
    die("bad unpack level $unpack_level specified");
}

$LINTIAN_UNPACK_LEVEL = $unpack_level;

# export current settings for our helper scripts
foreach (('ROOT', 'CFG', VARS)) {
    no strict 'refs';
    my $var = "LINTIAN_$_";
    if ($$var) {
	$ENV{$var} = $$var;
    } else {
	$ENV{$var} = "";
	$$var = "";
    }
}

my $debug = $#debug + 1;
$verbose = 1 if $debug;
$ENV{'LINTIAN_DEBUG'} = $debug;

# }}}

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

require Lab;

require Util;
require Read_pkglists;

import Util;

require Tags;
import Tags;

require Lintian::Data;
require Lintian::Schedule;
require Lintian::Output;
import Lintian::Output qw(:messages);
require Lintian::Command;
import Lintian::Command qw(spawn reap);
require Lintian::Check;
import Lintian::Check qw(check_maintainer);

no warnings 'once';
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->verbose($verbose);
$Lintian::Output::GLOBAL->debug($debug);
$Lintian::Output::GLOBAL->quiet($quiet);
$Lintian::Output::GLOBAL->color($color);
$Lintian::Output::GLOBAL->showdescription($lintian_info);

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

my @l_secs = read_dpkg_control("$LINTIAN_ROOT/checks/lintian.desc");
shift(@l_secs);
map { $_->{'script'} = 'lintian'; Tags::add_tag($_) } @l_secs;

$Tags::show_experimental = $display_experimentaltags;
$Tags::show_pedantic = $display_pedantictags;
$Tags::show_overrides = $show_overrides;
%Tags::display_level = %display_level;
%Tags::display_source = %display_source;
%Tags::only_issue_tags = map { $_ => 1 } (split(/,/, $check_tags))
    if defined $check_tags;
use warnings;

# }}}

# {{{ No clue why this code is here...

use vars qw(%source_info %binary_info %udeb_info); # from the above

# Set up clean-up handlers.
undef $cleanup_filename;
$SIG{'INT'} = \&interrupted;
$SIG{'QUIT'} = \&interrupted;

# }}}

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

$LAB = new Lab( $LINTIAN_LAB, $LINTIAN_DIST );

#######################################
# 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
$LINTIAN_LAB = $LAB->{dir};

# }}}

# {{{ Compile list of files to process

$schedule = new Lintian::Schedule(verbose => $verbose);
# process package/file arguments
while (my $arg = shift) {
    # file?
    if (-f $arg) {
	# $arg contains absolute dir spec?
	unless ($arg =~ m,^/,) {
	    $arg = "$cwd/$arg";
	}

	# .deb file?
	if ($arg =~ /\.deb$/) {
	    $schedule->add_deb('b', $arg)
		or warning("$arg is a zero-byte file, skipping");
	}
	# .udeb file?
	elsif ($arg =~ /\.udeb$/) {
	    $schedule->add_deb('u', $arg)
		or warning("$arg is a zero-byte file, skipping");
	}
	# .dsc file?
	elsif ($arg =~ /\.dsc$/) {
	    $schedule->add_dsc($arg)
		or warning("$arg is a zero-byte file, skipping");
	}
	# .changes file?
	elsif ($arg =~ /\.changes$/) {
	    # get directory and filename part of $arg
	    my ($arg_dir, $arg_name) = $arg =~ m,(.*)/([^/]+)$,;

	    v_msg("Processing changes file $arg_name ...");

	    my ($data) = read_dpkg_control($arg);
	    if (not defined $data) {
		warning("$arg is a zero-byte file, skipping");
		next;
	    }
	    Tags::set_pkg( $arg, $arg_name, "", "", 'binary' );

	    # If we don't have a Format key, something went seriously wrong.
	    # Tag the file and skip remaining processing.
	    if (!$data->{'format'}) {
		tag('malformed-changes-file');
		next;
	    }

	    # Description is mandated by dak, but only makes sense if binary
	    # packages are included.  Don't tag pure source uploads.
	    if (!$data->{'description'} && $data->{'architecture'} ne 'source') {
		tag("no-description-in-changes-file");
	    }

	    # check distribution field
	    if (defined $data->{distribution}) {
		my $ubuntu_dists = Lintian::Data->new ('changelog-file/ubuntu-dists');
		my $ubuntu_regex = join('|', $ubuntu_dists->all);
		my @distributions = split /\s+/o, $data->{distribution};
		for my $distribution (@distributions) {
		    if ($distribution eq 'UNRELEASED') {
			# ignore
		    } elsif ($data->{version} =~ /ubuntu|$ubuntu_regex/
			 or $distribution =~ /$ubuntu_regex/) {
			if ($distribution !~ /^($ubuntu_regex)(-(proposed|updates|backports|security))?$/ ) {
			    tag("bad-ubuntu-distribution-in-changes-file",
				$distribution);
			}
		    } elsif (! (($distribution eq 'oldstable')
				 or ($distribution eq 'stable')
				 or ($distribution eq 'testing')
				 or ($distribution eq 'unstable')
				 or ($distribution eq 'experimental')
				 or ($distribution =~ /^\w+-backports$/)
				 or ($distribution =~ /^\w+-proposed-updates$/)
				 or ($distribution =~ /^\w+-security$/))
			    ) {
			# bad distribution entry
			tag("bad-distribution-in-changes-file",
			    $distribution);
		    }
		}

		if ($#distributions > 0) {
		    tag("multiple-distributions-in-changes-file",
			$data->{'distribution'});
		}
	    }

	    # Urgency is only recommended by Policy.
	    if (!$data->{'urgency'}) {
		tag("no-urgency-in-changes-file");
	    } else {
		my $urgency = lc $data->{'urgency'};
		$urgency =~ s/ .*//;
		unless ($urgency =~ /^(low|medium|high|critical|emergency)$/i) {
		    tag("bad-urgency-in-changes-file", $data->{'urgency'});
		}
	    }

	    # Changed-By is optional in Policy, but if set, must be
	    # syntactically correct.  It's also used by dak.
	    if ($data->{'changed-by'}) {
		check_maintainer($data->{'changed-by'}, 'changed-by');
	    }

	    # process all listed `files:'
	    my %files;

	    my $file_list = $data->{files} || '';
	    for ( split /\n/, $file_list ) {
		chomp;
		s/^\s+//o;
		next if $_ eq '';

		my ($md5sum,$size,$section,$priority,$file) = split(/\s+/o, $_);

		next if ($file =~ m,/,);

		$files{$file}{md5} = $md5sum;
		$files{$file}{size} = $size;

		# check section
		if (($section eq 'non-free') or ($section eq 'contrib')) {
		    tag( "bad-section-in-changes-file", $file, $section );
		}

	    }

	    foreach my $alg (qw(sha1 sha256)) {
		my $list = $data->{"checksums-$alg"} || '';
		for ( split /\n/, $list ) {
		    chomp;
		    s/^\s+//o;
		    next if $_ eq '';

		    my ($checksum,$size,$file) = split(/\s+/o, $_);
		    $files{$file}{$alg} = $checksum;
		    if ($files{$file}{size} != $size) {
			tag( "file-size-mismatch-in-changes-file", $file,
			     "$files{$file}{size} != $size" );
		    }
		}
	    }


	    foreach my $file (keys %files) {
		my $filename = $arg_dir . '/' . $file;

		# check size
		if (not -f $filename) {
		    warning("$file does not exist, exiting");
		    exit 2;
		}
		my $size = -s _;
		if ($size ne $files{$file}{size}) {
		    tag( "file-size-mismatch-in-changes-file", $file,
			 "$files{$file}{size} != $size");
		}

		# check checksums
		if ($check_checksums or $file =~ /\.dsc$/) {
		    foreach my $alg (qw(md5 sha1 sha256)) {
			next unless exists $files{$file}{$alg};

			my $real_checksum = get_file_checksum($alg, $filename);

			if ($real_checksum ne $files{$file}{$alg}) {
			    tag( "checksum-mismatch-in-changes-file", $alg, $file );
			}
		    }
		}

		# process file?
		if ($file =~ /\.dsc$/) {
		    $schedule->add_dsc($filename);
		} elsif ($file =~ /\.deb$/) {
		    $schedule->add_deb('b', $filename);
		} elsif ($file =~ /\.udeb$/) {
		    $schedule->add_deb('u', $filename);
		}
	    }

	    unless ($exit_code) {
		my $stats = Tags::get_stats( $arg );
		if ($stats->{types}{E}) {
		    $exit_code = 1;
		} elsif ($fail_on_warnings && $stats->{types}{W}) {
		    $exit_code = 1;
		}
	    }

	} else {
	    fail("bad package file name $arg (neither .deb, .udeb 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;

	    # read package info
	    read_src_list("$LINTIAN_LAB/info/source-packages", 0);
	    read_bin_list("$LINTIAN_LAB/info/binary-packages", 0);
	    read_udeb_list("$LINTIAN_LAB/info/udeb-packages", 0);

	    if (($pkg_mode eq 'b') or ($pkg_mode eq 'a')) {
		if ($binary_info{$arg}) {
		    $schedule->add_file('b', "$LINTIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
					%{$binary_info{$arg}});
		    $found = 1;
		}
	    }
	    if (($pkg_mode eq 'u') or ($pkg_mode eq 'a')) {
		if ($udeb_info{$arg}) {
		    $schedule->add_file('u', "$LINTIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
					%{$udeb_info{$arg}});
		    $found = 1;
		}
	    }
	    if (($pkg_mode eq 's') or ($pkg_mode eq 'a')) {
		if ($source_info{$arg}) {
		    $schedule->add_file('s', "$LINTIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
					%{$source_info{$arg}});
		    $found = 1;
		}
	    }

	    next if $found;
	}

	# nothing found so far, so search the lab

	my $b = "$LINTIAN_LAB/binary/$arg";
	my $s = "$LINTIAN_LAB/source/$arg";
	my $u = "$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;
	    }
	}

	if (($pkg_mode eq 'b') or (($pkg_mode eq 'a') and (-d $b))) {
	    $schedule->add_file('b', get_bin_info_from_lab($b));
	}
	if (($pkg_mode eq 's') or (($pkg_mode eq 'a') and (-d $s))) {
	    $schedule->add_file('s', get_src_info_from_lab($s));
	}
	if (($pkg_mode eq 'u') or (($pkg_mode eq 'a') and (-d $u))) {
	    $schedule->add_file('u', get_bin_info_from_lab($u));
	}
    }
}

if (not $check_everything and not $packages_file and not $schedule->count) {
    v_msg("No packages selected.");
    exit $exit_code;
}
# }}}

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

# {{{ Load information about collector scripts
opendir(COLLDIR, "$LINTIAN_ROOT/collection")
    or fail("cannot read directory $LINTIAN_ROOT/collection");

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

    debug_msg(2, "Reading collector description file $f ...");
    my @secs = read_dpkg_control("$LINTIAN_ROOT/collection/$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'};
    $collection_info{$script}->{'script'} = $script;
    my $p = $collection_info{$script};

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

    set_value($f,$p,'unpack-level',$secs[0],1);
    set_value($f,$p,'order',$secs[0],1);
    set_value($f,$p,'version',$secs[0],1);

    if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
	for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
	    $p->{$_} = 1;
	}
	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->{$_}" } sort keys %$p ));
}

closedir(COLLDIR);
# }}}

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

# load information about checker scripts
opendir(CHECKDIR, "$LINTIAN_ROOT/checks")
    or fail("cannot read directory $LINTIAN_ROOT/checks");

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

    my @secs = read_dpkg_control("$LINTIAN_ROOT/checks/$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'};
    $check_info{$script}->{'script'} = $script;
    my $p = $check_info{$script};

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

    set_value($f,$p,'unpack-level',$secs[0],1);
    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'})) {
	    $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) {
	$tag->{'script'} = $script;
	Tags::add_tag($tag);
	$p->{'requested-tags'}++ if Tags::display_tag($tag);
    }
}

closedir(CHECKDIR);

# }}}

# {{{ Again some lone code the author just dumped where his cursor just happened to be
if ($unpack_info) {
    # determine which info has been requested
    for my $i (split(/,/,$unpack_info)) {
	unless ($collection_info{$i}) {
	    fail("unknown info specified: $i");
	}
	$unpack_infos{$i} = 1;
    }
}

# create check_abbrev hash
for my $c (keys %check_info) {
    $check_abbrev{$check_info{$c}->{'abbrev'}} = $c;
}

# }}}

# {{{ determine which checks have been requested
if ($action eq 'check') {
    if ($check_tags) {
	foreach my $t (split(/,/, $check_tags)) {
	    my $info = Tags::get_tag_info($t);

	    fail("unknown tag specified: $t") unless defined($info);
	    my $script = $info->{'script'};
	    next if $script eq 'lintian';
	    if ($check_info{$script}) {
		$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 {
		    $checks{$c} = 1;
		}
	    } elsif (exists $check_abbrev{$c}) {
		#abbrevs only used when -C is given, so we don't need %dont_check
		$checks{$check_abbrev{$c}} = 1;
	    } else {
		fail("unknown check specified: $c");
	    }
	}
    }

    # determine which info is needed by the checks
    for my $c (keys %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
for my $c (keys %unpack_infos) {
    for my $i (keys %collection_info) {
	# required by $c ?
	if ($collection_info{$c}->{$i}) {
	    $unpack_infos{$i} = 1;
	}
    }
}
# }}}

# {{{ process all packages in the archive?
if ($check_everything) {
    # make sure package info is available
    read_src_list("$LINTIAN_LAB/info/source-packages", 0);
    read_bin_list("$LINTIAN_LAB/info/binary-packages", 0);
    read_udeb_list("$LINTIAN_LAB/info/udeb-packages", 0);

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

    if (($pkg_mode eq 'a') or ($pkg_mode eq 's')) {
	for my $arg (sort keys %source_info) {
	    debug_msg(1, "doing stuff with $LINTIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}");
	    $schedule->add_file('s', "$LINTIAN_ARCHIVEDIR/$source_info{$arg}->{'file'}",
				%{$source_info{$arg}});
	}
    }
    if (($pkg_mode eq 'a') or ($pkg_mode eq 'b')) {
	for my $arg (sort keys %binary_info) {
	    debug_msg(1, "doing stuff with $LINTIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}");
	    $schedule->add_file('b', "$LINTIAN_ARCHIVEDIR/$binary_info{$arg}->{'file'}",
				%{$binary_info{$arg}});
	}
    }
    if (($pkg_mode eq 'a') or ($pkg_mode eq 'u')) {
	for my $arg (sort keys %udeb_info) {
	    debug_msg(1, "doing stuff with $LINTIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}");
	    $schedule->add_file('u', "$LINTIAN_ARCHIVEDIR/$udeb_info{$arg}->{'file'}",
				%{$udeb_info{$arg}});
	}
    }

    # package list still empty?
    unless ($schedule->count) {
	warning("no packages found in distribution directory");
    }
} elsif ($packages_file) {	# process all packages listed in packages file?
    $schedule->add_pkg_list($packages_file);
}
# }}}

# {{{ Some silent exit
unless ($schedule->count) {
    v_msg("No packages selected.");
    exit 0;
}
# }}}

# {{{ Okay, now really processing the packages in one huge loop
$unpack_infos{ "override-file" } = 1 unless $no_override;
v_msg(sprintf("Processing %d packages...", $schedule->count));
debug_msg(1,
	  "Selected action: $action",
	  "Requested unpack level: $unpack_level",
	  sprintf("Requested data to collect: %s", join(',',keys %unpack_infos)),
	  sprintf("Selected checks: %s", join(',',keys %checks)),
    );

require Checker;
require Lintian::Collect;

my %overrides;
my @pending_jobs;
PACKAGE:
foreach my $pkg_info ($schedule->get_all) {
    my ($type, $pkg, $ver, $arch, $file) =
	@$pkg_info{qw(type package version architecture file)};
    my $long_type = ($type eq 'b' ? 'binary' :
		     ($type eq 's' ? 'source' : 'udeb' ));

    Tags::set_pkg( $file, $pkg, $ver, $arch, $long_type );

    # Kill pending jobs, if any
    Lintian::Command::kill(@pending_jobs);
    undef @pending_jobs;

    # determine base directory
    my $base = "$LINTIAN_LAB/$long_type/$pkg";
    unless ($base =~ m,^/,) {
	$base = "$cwd/$base";
    }
    debug_msg(1, "Base directory in lab: $base");

    my $act_unpack_level = 0;

    # unpacked package up-to-date?
    if (-d $base) {
	my $remove_basedir = 0;

        # there's a base dir, so we assume that at least
        # one level of unpacking has been done
	$act_unpack_level = 1;

	# lintian status file exists?
	unless (-f "$base/.lintian-status") {
	    v_msg("No lintian status file found (removing old directory in lab)");
	    $remove_basedir = 1;
	    goto REMOVE_BASEDIR;
	}

	# read unpack status -- catch any possible errors
	my $data;
	eval { ($data) = read_dpkg_control("$base/.lintian-status"); };
	if ($@) {		# error!
	    v_msg($@);
	    $remove_basedir = 1;
	    goto REMOVE_BASEDIR;
	}

	# compatible lintian version?
	if (not exists $data->{'lab-format'} or ($data->{'lab-format'} < $LAB_FORMAT)) {
	    v_msg("Lab directory was created by incompatible lintian version");
	    $remove_basedir = 1;
	    goto REMOVE_BASEDIR;
	}

	# version up to date?
	if (not exists $data->{'version'} or ($data->{'version'} ne $ver)) {
	    debug_msg(1, "Removing package in lab (newer version exists) ...");
	    $remove_basedir = 1;
	    goto REMOVE_BASEDIR;
	}

	# unpack level defined?
	unless (exists $data->{'unpack-level'}) {
	    warning("cannot determine unpack-level of package");
	    $remove_basedir = 1;
	    goto REMOVE_BASEDIR;
        } else {
            $act_unpack_level = $data->{'unpack-level'};
	}

	# file modified?
	my $timestamp;
	my @stat;
	unless (@stat = stat $file) {
	    warning("cannot stat file $file: $!");
	} else {
	    $timestamp = $stat[9];
	}
	if ((not defined $timestamp) or (not exists $data->{'timestamp'}) or ($data->{'timestamp'} != $timestamp)) {
	    debug_msg(1, "Removing package in lab (package has been changed) ...");
	    $remove_basedir = 1;
	    goto REMOVE_BASEDIR;
	}

    REMOVE_BASEDIR:
	if ($remove_basedir) {
	    v_msg("Removing $pkg");
	    unless (remove_pkg($base)) {
		warning("skipping $action of $long_type package $pkg");
		$exit_code = 2;
		next PACKAGE;
	    }
	    $act_unpack_level = 0;
	}
    }

    # unpack to requested unpack level
    $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,
				   $unpack_level);
    if ($act_unpack_level == -1) {
	warning("could not unpack package to desired level",
		"skipping $action of $long_type package $pkg");
	$exit_code = 2;
	next PACKAGE;
    }

    if (($action eq 'unpack') or ($action eq 'check')) { # collect info
	my $current_order = -1;
	for my $coll (sort by_collection_order keys %unpack_infos) {
	    my $ci = $collection_info{$coll};
	    my %run_opts = ('description' => $coll);

	    # current type?
	    next unless ($ci->{'type'} =~ m/$type/);

	    # If a file named .SCRIPT-VERSION already exists, we've already
	    # collected this information and we can skip it.  Otherwise,
	    # remove any .SCRIPT-* files (which are old version information).
	    next if (-f "$base/.${coll}-$ci->{'version'}");
	    opendir(BASE, $base)
		or fail("cannot read directory $base: $!");
	    for my $file (readdir BASE) {
		if ($file =~ /^\.\Q$coll-/) {
		    unlink("$base/$file");
		}
	    }
	    closedir(BASE);

	    # unpack to desired unpack level (if necessary)
	    $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
	    if ($act_unpack_level == -1) {
		warning("could not unpack package to desired level",
			"skipping $action of $long_type package $pkg");
		$exit_code = 2;
		next PACKAGE;
	    }

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

	    $current_order = $ci->{'order'} if ($current_order == -1);
	    if ($current_order != $ci->{'order'}) {
		debug_msg(1, "Waiting for jobs from order $current_order ...");
		unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
		    warning("skipping $action of $long_type package $pkg");
		    $exit_code = 2;
		    next PACKAGE;
		}
		undef @pending_jobs;
		$current_order = $ci->{'order'};
	    }

	    # collect info
	    remove_status_file($base);
	    debug_msg(1, "Collecting info: $coll ...");
	    my $script = "$LINTIAN_ROOT/collection/$ci->{'script'}";
	    unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&' ])) {
		warning("collect info $coll about package $pkg failed",
			"skipping $action of $long_type package $pkg");
		$exit_code = 2;
		next PACKAGE;
	    }
	    push @pending_jobs, \%run_opts;
	}

	# wait until all the jobs finish and skip this package if any of them
	# failed.
	debug_msg(1, "Waiting for jobs from order $current_order ...");
	unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
	    warning("skipping $action of $long_type package $pkg");
	    $exit_code = 2;
	    next PACKAGE;
	}
	undef @pending_jobs;
    }

    if ($action eq 'check') { 	# read override file

	unless ($no_override) {
	    Tags::add_overrides("$base/override", $pkg, $long_type)
		if (-f "$base/override")
        }

	# perform checks
	my $info = Lintian::Collect->new($pkg, $long_type);
	for my $check (keys %checks) {
	    my $ci = $check_info{$check};

	    # current type?
	    next unless ($ci->{'type'} =~ m/$type/);

	    # unpack to desired unpack level (if necessary)
	    $act_unpack_level = unpack_pkg($type,$base,$file,$act_unpack_level,$ci->{'unpack-level'});
	    if ($act_unpack_level == -1) {
		warning("could not unpack package to desired level",
			"skipping $action of $long_type package $pkg");
		$exit_code = 2;
		next PACKAGE;
	    }

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

	    my $returnvalue = Checker::runcheck($pkg, $long_type, $info, $check);
	    # 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 $long_type package $pkg");
		next PACKAGE;
	    }

	}
	unless ($exit_code) {
	    my $stats = Tags::get_stats( $file );
	    if ($stats->{types}{E}) {
		$exit_code = 1;
	    } elsif ($fail_on_warnings && $stats->{types}{W}) {
		$exit_code = 1;
	    }
	}

	# report unused overrides
	if (not $no_override) {
	    my $overrides = Tags::get_overrides( $file );

	    for my $tag (sort keys %$overrides) {
		my $taginfo = Tags::get_tag_info{$tag};
		if (defined $taginfo) {
		    # Did we run the check script containing the tag?
		    next unless $checks{$taginfo->{'script'}};

		    # If only checking specific tags, is this one of them?
		    next unless (scalar keys %Tags::only_issue_tags == 0)
			or exists $Tags::only_issue_tags{$tag};
		}

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

		    tag( "unused-override", $tag, $extra );
		}
	    }
	}

	# Report override statistics.
	if (not $no_override and not $show_overrides) {
	    my $stats = Tags::get_stats($file);
	    my $short = $file;
	    $short =~ s%.*/%%;
	    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;
        }
    }

    # chdir to lintian root directory (to unlock $base so it can be removed below)
    unless (chdir($LINTIAN_ROOT)) {
	warning("could not chdir into directory $LINTIAN_ROOT: $!",
		"skipping $action of $long_type package $pkg");
	$exit_code = 2;
	next PACKAGE;
    }

    # clean up
    if ($act_unpack_level > $unpack_level) {
	$act_unpack_level = clean_pkg($type,$base,$file,$act_unpack_level,$unpack_level);
	if ($act_unpack_level == -1) {
	    warning("could not clean up laboratory for package $pkg: $!",
		    "skipping clean up");
	    $exit_code = 2;
	    next PACKAGE;
	}
    }

    # create Lintian status file
    if (($act_unpack_level > 0) and (not -f "$base/.lintian-status")) {
	my @stat;
	unless (@stat = stat $file) {
	    warning("cannot stat file $file: $!",
		    "skipping creation of status file");
	    $exit_code = 2;
	    next PACKAGE;
	}
	my $timestamp = $stat[9];

	unless (open(STATUS, '>', "$base/.lintian-status")) {
	    warning("could not create status file $base/.lintian-status for package $pkg: $!");
	    $exit_code = 2;
	    next PACKAGE;
	}

	print STATUS "Lintian-Version: $LINTIAN_VERSION\n";
	print STATUS "Lab-Format: $LAB_FORMAT\n";
	print STATUS "Package: $pkg\n";
	print STATUS "Version: $ver\n";
	print STATUS "Type: $type\n";
	print STATUS "Unpack-Level: $act_unpack_level\n";
	print STATUS "Timestamp: $timestamp\n";
	close(STATUS);
    }
}
Tags::reset_pkg();
if ($action eq 'check' and not $no_override and not $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 $total = ($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("$total (". join (', ', @output). ")");
    }
}

# }}}

exit $exit_code;

# {{{ Some subroutines

sub unpack_pkg {
    my ($type,$base,$file,$cur_level,$new_level) = @_;

    debug_msg(1, sprintf("Current unpack level is %d",$cur_level));

    return $cur_level if $cur_level == $new_level;

    # remove .lintian-status file
    remove_status_file($base);

    if ( ($cur_level == 0) and (-d $base) ) {
       # We were lied to, there's something already there - clean it up first
       remove_pkg($base) or return -1;
    }

    if ( ($new_level >= 1) and
	 (not defined ($cur_level) or ($cur_level < 1)) ) {
	# create new directory
	debug_msg(1, "Unpacking package to level 1 ...");
	if (($type eq 'b') || ($type eq 'u')) {
	    spawn({}, ["$LINTIAN_ROOT/unpack/unpack-binpkg-l1", $base, $file])
		or return -1;
	} else {
	    spawn({}, ["$LINTIAN_ROOT/unpack/unpack-srcpkg-l1", $base, $file])
		or return -1;
	}
	$cur_level = 1;
    }

    if ( ($new_level >= 2) and
	 (not defined ($cur_level) or ($cur_level < 2)) ) {
	# unpack package contents
	debug_msg(1, "Unpacking package to level 2 ...");
	if (($type eq 'b') || ($type eq 'u')) {
	    spawn({}, ["$LINTIAN_ROOT/unpack/unpack-binpkg-l2", $base])
		or return -1;
	} else {
	    debug_msg(1, "$LINTIAN_ROOT/unpack/unpack-srcpkg-l2 $base");
	    spawn({}, ["$LINTIAN_ROOT/unpack/unpack-srcpkg-l2", $base])
		or return -1;
	}
	$cur_level = 2;
    }

    return $cur_level;
}

# Given a list of jobs corresponding to collect scripts, reap each of the
# jobs.  For each successful job, record that it was successful by creating
# the corresponding version marker file in the lab.  For each unsuccessful
# job, warn that it was unsuccessful.
#
# Takes the current package, base directory, and the list of pending jobs.
# Return true if all jobs were successful, false otherwise.
sub reap_collect_jobs {
    my ($pkg, $base, @pending_jobs) = @_;
    my $status = reap(@pending_jobs);
    for my $job (@pending_jobs) {
	my $coll = $job->{'description'};
	if ($job->{success}) {
	    my $ci = $collection_info{$coll};
	    open(VERSION, '>', "$base/.${coll}-$ci->{'version'}")
		or fail("cannot create $base/.${coll}-$ci->{'version'}: $!");
	    print VERSION "Lintian-Version: $LINTIAN_VERSION\n"
		. "Timestamp: " . time . "\n";
	    close(VERSION);
	} else {
	    warning("collect info $coll about package $pkg failed");
	}
    }
    return $status;
}

# TODO: is this the best way to clean dirs in perl?
# no, look at File::Path module
sub clean_pkg {
    my ($type,$base,$file,$cur_level,$new_level) = @_;

    return $cur_level if $cur_level == $new_level;

    if ($new_level < 1) {
	# remove base directory
	remove_pkg($base) or return -1;
	return 0;
    }

    if ( ($new_level < 2) and defined ($cur_level) and ($cur_level >= 2) ) {
	# remove .lintian-status file
	remove_status_file($base);

	# remove unpacked/ directory
	debug_msg(1, "Decreasing unpack level to 1 (removing files) ...");
	if ( -l "$base/unpacked" ) {
	    delete_dir("$base/".readlink("$base/unpacked"))
		or return -1;
	    delete_dir("$base/unpacked") or return -1;
	} else {
	    delete_dir("$base/unpacked") or return -1;
	}

	$cur_level = 1;
    }

    return $cur_level;
}

# this function removes a package's base directory in the lab completely
sub remove_pkg {
    my ($base) = @_;

    debug_msg(1, "Removing package in lab ...");
    unless (delete_dir($base)) {
	warning("cannot remove directory $base: $!");
	return 0;
    }

    return 1;
}

sub remove_status_file {
    my ($base) = @_;

    # status file exists?
    if (not -e "$base/.lintian-status") {
	return 1;
    }

    if (not unlink("$base/.lintian-status")) {
	warning("cannot remove status file $base/.lintian-status: $!");
	return 0;
    }

    return 1;
}

# -------------------------------

# get package name, version, and file name from the lab
sub get_bin_info_from_lab {
    my ($base_dir) = @_;
    my ($pkg,$ver,$arch,$file);

    ($pkg = read_file("$base_dir/fields/package"))
	or fail("cannot read file $base_dir/fields/package: $!");

    ($ver = read_file("$base_dir/fields/version"))
	or fail("cannot read file $base_dir/fields/version: $!");

    ($arch = read_file("$base_dir/fields/architecture"))
	or fail("cannot read file $base_dir/fields/architecture: $!");

    ($file = readlink("$base_dir/deb"))
	or fail("cannot read link $base_dir/deb: $!");

    return ($file, package => $pkg, version => $ver, architecture => $arch);
}

# get package name, version, and file name from the lab
sub get_src_info_from_lab {
    my ($base_dir) = @_;
    my ($pkg,$ver,$file);

    ($pkg = read_file("$base_dir/fields/source"))
	or fail("cannot read file $base_dir/fields/source: $!");

    ($ver = read_file("$base_dir/fields/version"))
	or fail("cannot read file $base_dir/fields/version: $!");

    ($file = readlink("$base_dir/dsc"))
	or fail("cannot read link $base_dir/dsc: $!");

    return ($file, source => $pkg, version => $ver);
}

# -------------------------------

# read first line of a file
sub read_file {
    my $t;

    open(T, '<', $_[0]) or return;
    chop($t = <T>);
    close(T) or return;

    return $t;
}

# sort collection list by `order'
sub by_collection_order {
    $collection_info{$a}->{'order'} <=> $collection_info{$b}->{'order'};
}
# }}}

# {{{ Exit handler.

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

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

    $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
