[SCM] Debian package checker branch, infra-513663, updated. 2.4.3-220-gd774378
The following commit has been merged in the infra-513663 branch:
commit d774378912b91430dd8f6c41a0659f9fcd1c8219
Merge: 57dc2849c83a5b8b4b5253498512021c0d069f61 03cb2d4ab8b4bd8882fe1898940e7a3785c84f83
Author: Niels Thykier <niels@thykier.net>
Date: Wed Jan 26 13:28:07 2011 +0100
Merge branch 'master' into infra-513663
Conflicts:
frontend/lintian
unpack/unpack-binpkg-l1
unpack/unpack-changes-l1
diff --combined frontend/lintian
index c1d1119,7030066..387685b
--- a/frontend/lintian
+++ b/frontend/lintian
@@@ -25,11 -25,10 +25,11 @@@
use strict;
use Getopt::Long;
+use Cwd;
# }}}
# {{{ Global Variables
- my $LINTIAN_VERSION = "<VERSION>"; #External Version number
+ my $LINTIAN_VERSION = '<VERSION>'; #External Version number
my $BANNER = "Lintian v$LINTIAN_VERSION"; #Version Banner - text form
my $LAB_FORMAT = 10; #Lab format Version Number
#increased whenever incompatible
@@@ -49,6 -48,7 +49,6 @@@ my $lintian_info = 0; #flag for -i|--i
our $display_experimentaltags = 0; #flag for -E|--display-experimental switch
our $display_pedantictags = 0; #flag for --pedantic switch
our $ftpmaster_tags = 0; #flag for -F|--ftp-master-rejects 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
@@@ -57,14 -57,15 +57,14 @@@ my $allow_root = 0; #flag for --allow-
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
+ 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_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;
@@@ -87,7 -88,7 +87,7 @@@ my $exit_code = 0
my $LAB;
my %collection_info;
-my %checks;
+my %enabled_checks;
my %check_abbrev;
my %unpack_infos;
my %check_info;
@@@ -96,6 -97,7 +96,6 @@@
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;
@@@ -214,10 -216,10 +214,10 @@@ sub record_action
# 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");
+ 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");
+ die('both -C or --check-part and -X or --dont-check-part options not allowed');
}
if ($action) {
die("too many actions specified: $_[0]");
@@@ -230,13 -232,13 +230,13 @@@
# 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");
+ die('multiple -T or --tags options not allowed');
}
if ($checks) {
- die("both -T or --tags and -C or --check-part options not allowed");
+ 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");
+ die('both -T or --tags and -X or --dont-check-part options not allowed');
}
if ($action) {
die("too many actions specified: $_[0]");
@@@ -282,7 -284,7 +282,7 @@@ sub record_suppress_tags_from_file
$line =~ s/^\s+//;
$line =~ s/\s+$//;
next unless $line;
- next if $line =~ /^\#/;
+ next if $line eq '';
record_suppress_tags($option, $line);
}
close $file;
@@@ -292,10 -294,10 +292,10 @@@
# 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");
+ 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");
+ die('both -C or --check-part and -X or --dont-check-part options not allowed');
}
if ($action) {
die("too many actions specified: $_[0]");
@@@ -308,7 -310,7 +308,7 @@@
# Process for -U|--unpack-info flag
sub record_unpack_info {
if ($unpack_info) {
- die("multiple -U or --unpack-info options not allowed");
+ die('multiple -U or --unpack-info options not allowed');
}
$unpack_info = "$_[1]";
}
@@@ -355,66 -357,67 +355,67 @@@ sub record_display_source
# 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,
+ '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,
+ 'help|h' => \&syntax,
+ 'version|V' => \&banner,
+ 'print-version' => \&banner,
- "verbose|v" => \$verbose,
- "debug|d" => \@debug, # Count the -d flags
- "quiet|q" => \$quiet,
+ '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,
- "suppress-tags=s" => \&record_suppress_tags,
- "suppress-tags-from-file=s" => \&record_suppress_tags_from_file,
- "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,
+ '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,
+ 'suppress-tags=s' => \&record_suppress_tags,
+ 'suppress-tags-from-file=s' => \&record_suppress_tags_from_file,
- '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,
+ '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,
+ '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,
+ 'exp-output:s' => \$experimental_output_opts,
);
# init commandline parser
@@@ -425,10 -428,10 +426,10 @@@ GetOptions(%opthash
or die("error parsing options\n");
# determine current working directory--we'll need this later
-chop($cwd = `pwd`);
+$cwd = Cwd::getcwd();
# determine LINTIAN_ROOT if it was not set with --root.
-$LINTIAN_ROOT = $LINTIAN_ROOT || $ENV{'LINTIAN_ROOT'};
+$LINTIAN_ROOT = $ENV{'LINTIAN_ROOT'} unless (defined($LINTIAN_ROOT));
if (defined $LINTIAN_ROOT) {
unless ($LINTIAN_ROOT =~ m,^/,) {
$LINTIAN_ROOT = "$cwd/$LINTIAN_ROOT";
@@@ -439,14 -442,14 +440,14 @@@
# 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 "warning: options -a or -p cannot 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)$/) {
+ if ($color and $color !~ /^(?:never|always|auto|html)$/) {
die "invalid argument to --color: $color\n";
}
@@@ -454,7 -457,7 +455,7 @@@
$action = 'check' unless $action;
# check for arguments
- if ($action =~ /^(check|unpack|remove)$/ and $#ARGV == -1 and not $check_everything and not $packages_file) {
+ if ($action =~ /^(?:check|unpack|remove)$/ and $#ARGV == -1 and not $check_everything and not $packages_file) {
syntax();
}
@@@ -465,7 -468,7 +466,7 @@@
# 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";
+ print STDERR "warning: the authors of lintian do not recommend running it with root privileges!\n";
}
# search for configuration file if it was not set with --cfg
@@@ -481,7 -484,7 +482,7 @@@ if ($LINTIAN_CFG)
undef $LINTIAN_CFG;
}
-use constant VARS => qw(LAB ARCHIVEDIR DIST UNPACK_LEVEL SECTION AREA ARCH);
+use constant VARS => qw(LAB ARCHIVEDIR DIST AREA ARCH);
# read configuration file
if ($LINTIAN_CFG) {
open(CFG, '<', $LINTIAN_CFG)
@@@ -531,6 -534,40 +532,6 @@@ unless (defined $LINTIAN_ARCH)
}
}
-# 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)) {
- print STDERR "warning: --unpack-level is deprecated, ignoring.\n";
- # specified through command line
-} elsif (defined($LINTIAN_UNPACK_LEVEL)) {
- # specified via configuration file or env variable
- print STDERR "warning: LINTIAN_UNPACK_LEVEL is deprecated, ignoring.\n";
-}
-
-# 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)) {
- 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';
@@@ -538,8 -575,8 +539,8 @@@
if ($$var) {
$ENV{$var} = $$var;
} else {
- $ENV{$var} = "";
- $$var = "";
+ $ENV{$var} ='';
+ $$var = '';
}
}
@@@ -568,9 -605,6 +569,9 @@@ require Read_pkglists
import Util;
+require Checker;
+require Lintian::Collect;
+require Lintian::DepMap::Properties;
require Lintian::Data;
require Lintian::Schedule;
require Lintian::Output;
@@@ -625,6 -659,7 +626,6 @@@ debug_msg(1
"Laboratory: $LINTIAN_LAB",
"Archive directory: $LINTIAN_ARCHIVEDIR",
"Distribution: $LINTIAN_DIST",
- "Default unpack level: $LINTIAN_UNPACK_LEVEL",
"Architecture: $LINTIAN_ARCH",
delimiter(),
);
@@@ -670,11 -705,11 +671,11 @@@ $LAB = new Lab( $LINTIAN_LAB, $LINTIAN_
# Process -S option
if ($action eq 'setup-lab') {
if ($#ARGV+1 > 0) {
- warning("ignoring additional command line arguments");
+ warning('ignoring additional command line arguments');
}
$LAB->setup_static()
- or fail("There was an error while setting up the static lab.");
+ or fail('There was an error while setting up the static lab.');
exit 0;
@@@ -682,11 -717,11 +683,11 @@@
# Process -R option
} elsif ($action eq 'remove-lab') {
if ($#ARGV+1 > 0) {
- warning("ignoring additional command line arguments");
+ warning('ignoring additional command line arguments');
}
$LAB->delete_static()
- or fail("There was an error while removing the static lab.");
+ or fail('There was an error while removing the static lab.');
exit 0;
@@@ -698,7 -733,7 +699,7 @@@
}
# sanity check:
- fail("lintian lab has not been set up correctly (perhaps you forgot to run lintian --setup-lab?)")
+ 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
@@@ -829,71 -864,182 +830,71 @@@ while (my $arg = shift)
}
}
-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 defined($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 %type;
- for (split(/\s*,\s*/o,$p->{'type'})) {
- if ($_ eq 'binary') {
- $type{'b'} = 1;
- } elsif ($_ eq 'source') {
- $type{'s'} = 1;
- } elsif ($_ eq 'udeb') {
- $type{'u'} = 1;
- } elsif ($_ eq 'changes') {
- $type{'c'} = 1;
- } else {
- fail("unknown type $_ specified in description file $f");
- }
- }
- $p->{'type'} = \%type;
+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);
- set_value($f,$p,'version',$secs[0],1);
- set_value($f,$p,'auto-remove',$secs[0],0);
+ debug_msg(2, "pkg_mode = $pkg_mode");
- if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
- for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
- push @{$p->{'needs-info'}}, $_;
+ 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}});
}
- 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(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);
- my %type;
- # convert Type:
- for (split(/\s*,\s*/o,$p->{'type'})) {
- if ($_ eq 'binary') {
- $type{'b'} = 1;
- } elsif ($_ eq 'source') {
- $type{'s'} = 1;
- } elsif ($_ eq 'udeb') {
- $type{'u'} = 1;
- } elsif ($_ eq 'changes') {
- $type{'c'} = 1;
- } else {
- fail("unknown type $_ specified in description file $f");
+ 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}});
}
}
- $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;
+ 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}});
}
- 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'});
+ # package list still empty?
+ unless ($schedule->count) {
- warning("no packages found in distribution directory");
++ warning('no packages found in distribution directory');
}
+} elsif ($packages_file) { # process all packages listed in packages file?
+ $schedule->add_pkg_list($packages_file);
}
+# }}}
-closedir(CHECKDIR);
+# {{{ Some silent exit
+my $count = $schedule->count;
+unless ($count) {
- v_msg("No packages selected.");
++ v_msg('No packages selected.');
+ exit $exit_code;
+}
+# }}}
+# {{{ Load information about collector scripts
+load_collections(\%collection_info, "$LINTIAN_ROOT/collection");
# }}}
-# {{{ 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;
- }
-}
+# {{{ Now we're ready to load info about checks & tags
-# create check_abbrev hash
-for my $c (keys %check_info) {
- $check_abbrev{$check_info{$c}->{'abbrev'}} = $c;
-}
+# load information about checker scripts
+load_checks(\%check_info, $TAGS, "$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);
@@@ -902,14 -1048,14 +903,14 @@@
my $script = $info->script;
next if $script eq 'lintian';
if ($check_info{$script}) {
- $checks{$script} = 1;
+ $enabled_checks{$script} = 1;
} else {
# should never happen
fail("no info for script $script");
}
}
} else {
- my %dont_check = map { $_ => 1 } (split m/,/, ($dont_check || ""));
+ 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}) {
@@@ -920,11 -1066,11 +921,11 @@@
} elsif ($check_info{$c}->{'requested-tags'} == 0) {
#no need to run this check, no tags will be issued
} else {
- $checks{$c} = 1;
+ $enabled_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;
+ $enabled_checks{$check_abbrev{$c}} = 1;
} else {
fail("unknown check specified: $c");
}
@@@ -932,7 -1078,7 +933,7 @@@
}
# determine which info is needed by the checks
- for my $c (keys %checks) {
+ for my $c (keys %enabled_checks) {
for my $i (keys %collection_info) {
# required by $c ?
if ($check_info{$c}->{$i}) {
@@@ -944,57 -1090,29 +945,57 @@@
# }}}
-require Lintian::DepMap::Properties;
+# {{{ 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 {
+ for my $c (keys %unpack_infos) {
+ if (exists $collection_info{$c}{'needs-info'}) {
+ map { $unpack_infos{$_} = 1; } @{$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();
-# {{{ determine which info is needed by the collection scripts
-for my $c (keys %unpack_infos) {
- if (exists $collection_info{$c}{'needs-info'}) {
- map { $unpack_infos{$_} = 1; } @{$collection_info{$c}{'needs-info'}};
+unless ($no_override) {
+ # add the override-file collection
+ $map->add('coll-override-file', {'type' => 'collection', 'name' => 'override-file'});
+ if (exists $collection_info{'override-file'}{'needs-info'}) {
+ $map->addp('coll-override-file', 'coll-',
+ @{$collection_info{'override-file'}{'needs-info'}});
}
}
-# }}}
-# {{{ add the collection scripts to the dependencies tree
for my $c (keys %unpack_infos) {
+ # Add the collections with their dependency information
$map->add('coll-' . $c, {'type' => 'collection', 'name' => $c});
if (exists $collection_info{$c}{'needs-info'}) {
$map->addp('coll-' . $c, 'coll-', @{$collection_info{$c}{'needs-info'}});
}
}
-# }}}
-# {{{ add the checks to the dependencies tree
-for my $c (keys %checks) {
+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'}});
@@@ -1002,47 -1120,85 +1003,47 @@@
}
# }}}
-# {{{ make --unpack collect all info
-if ($action eq 'unpack') {
- for my $c (keys %collection_info) {
- $unpack_infos{$c} = 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
-my $count = $schedule->count;
-unless ($count) {
- v_msg('No packages selected.');
- exit 0;
-}
-# }}}
-
# {{{ Okay, now really processing the packages in one huge loop
- v_msg(sprintf("Processing %d packages...", $count));
-unless ($no_override) {
- $map->add('coll-override-file', {'type' => 'collection', 'name' => 'override-file'});
- if (exists $collection_info{'override-file'}{'needs-info'}) {
- $map->addp('coll-override-file', 'coll-',
- @{$collection_info{'override-file'}{'needs-info'}});
- }
-}
+ v_msg(sprintf('Processing %d packages...', $count));
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)),
- "Requested unpack level: $unpack_level",
+ sprintf('Requested data to collect: %s', join(',',sort keys %unpack_infos)),
- sprintf('Selected checks: %s', join(',',sort keys %checks)),
++ 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()));
+ or fail('There are missing nodes on the resolver: '.join(', ', $map->missing()));
-require Checker;
-require Lintian::Collect;
+## REFACTORING NOTES:
+## If we are here $action is one of "check", "unpack" or "remove"
+##
+
+if($action eq 'remove'){
+ # Handle remove here - makes the unpack/check loop simpler.
+ foreach my $pkg_info ($schedule->get_all) {
+ my ($type, $pkg, $ver, $arch, $file) =
+ @$pkg_info{qw(type package version architecture file)};
+ my $lpkg;
+ eval{ $lpkg = $LAB->get_lab_package($pkg, $ver, $type, $file); };
+ if(!defined($lpkg)){
- my $err = ".";
++ my $err = '.';
+ $err = ": $@" if(defined($@));
+ warning("skipping $action of $type package $pkg$err");
+ $exit_code = 2;
+ next;
+ }
+ $TAGS->file_start($file, $pkg, $ver, $arch, $lpkg->pkg_type());
+ unless($lpkg->delete_lab_entry()){
+ $exit_code = 2;
+ }
+ }
+ $TAGS->file_end();
+ exit $exit_code;
+}
+
+# Now action is always either "check" or "unpack"
my %overrides;
my %running_jobs;
@@@ -1050,22 -1206,9 +1051,22 @@@ 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 'c' ? 'changes' :
- ($type eq 's' ? 'source' : 'udeb' )));
+ my $lpkg;
+ my $long_type;
+ my $base;
+ my $info;
+ my $loaded_overrides = 0;
+ eval{ $lpkg = $LAB->get_lab_package($pkg, $ver, $type, $file); };
+ if(!defined($lpkg)){
- my $err = ".";
++ my $err = '.';
+ $err = ": $@" if(defined($@));
+ warning("skipping $action of $type package $pkg$err");
+ $exit_code = 2;
+ next PACKAGE;
+ }
+
+ # The Lab will normalize it.
+ $long_type = $lpkg->pkg_type();
$TAGS->file_start($file, $pkg, $ver, $arch, $long_type);
$map->initialise();
@@@ -1075,173 -1218,246 +1076,172 @@@
%running_jobs = ();
# determine base directory
- my $base = "$LINTIAN_LAB/$long_type/$pkg";
- unless ($base =~ m,^/,) {
- $base = "$cwd/$base";
- }
+ $base = $lpkg->base_dir();
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;
- }
-
- # 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;
- }
+ # Ensure it has been unpacked
+ unless ($lpkg->create_entry()){
- warning("could not create the package entry in the lab",
++ warning('could not create the package entry in the lab',
+ "skipping $action of $long_type package $pkg");
+ $exit_code = 2;
+ next PACKAGE;
}
+ $info = Lintian::Collect->new($pkg, $long_type);
- # 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',
+ # 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;
}
- if (($action eq 'unpack') or ($action eq 'check')) {
- my $info = Lintian::Collect->new($pkg, $long_type);
- my $loaded_overrides = 0;
-
- # 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;
- }
+ while ($map->pending) {
+ foreach my $req (sort sort_coll $map->selectable) {
+ my $ri = $map->getProp($req);
+ if ($ri->{'type'} eq 'collection') {
+ my $coll = $ri->{'name'};
+ my $ci = $collection_info{$coll};
- while ($map->pending) {
- foreach my $req (sort sort_coll $map->selectable) {
- my $ri = $map->getProp($req);
- if ($ri->{'type'} eq 'collection') {
- my $coll = $ri->{'name'};
- my $ci = $collection_info{$coll};
-
- # current type?
- unless (exists $ci->{'type'}{$type}) {
- $map->satisfy($req);
- next;
- }
+ # current type?
+ unless (exists $ci->{'type'}{$type}) {
+ $map->satisfy($req);
+ next;
+ }
- # 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).
- if (-f "$base/.${coll}-$ci->{'version'}") {
- $map->satisfy($req);
- next;
- }
- opendir(BASE, $base)
- or fail("cannot read directory $base: $!");
- for my $file (readdir BASE) {
- if ($file =~ /^\.\Q$coll-/) {
- unlink("$base/$file");
- }
- }
- closedir(BASE);
-
- # collect info
- $map->select($req);
- remove_status_file($base);
- debug_msg(1, "Collecting info: $coll ...");
- my $script = "$LINTIAN_ROOT/collection/$ci->{'script'}";
- my $cmd = Lintian::Command::Simple->new();
- unless ($cmd->background($script, $pkg, $long_type) > 0) {
- warning("collect info $coll about package $pkg failed",
- "skipping $action of $long_type package $pkg");
- $exit_code = 2;
- next PACKAGE;
- }
- $running_jobs{$coll} = $cmd;
- } elsif ($ri->{'type'} eq 'check') {
- # skip check if overrides were not yet loaded
- last unless $loaded_overrides or $no_override;
- my $check = $ri->{'name'};
- my $ci = $check_info{$check};
-
- # current type?
- unless (exists $ci->{'type'}{$type}) {
- $map->satisfy($req);
- next;
+ # 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).
+ if (-f "$base/.${coll}-$ci->{'version'}") {
+ $map->satisfy($req);
+ next;
+ }
+ opendir(BASE, $base)
+ or fail("cannot read directory $base: $!");
+ for my $file (readdir BASE) {
+ if ($file =~ /^\.\Q$coll-/) {
+ unlink("$base/$file");
}
+ }
+ closedir(BASE);
- debug_msg(1, "Running check: $check ...");
- 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;
- }
+ # collect info
+ $map->select($req);
+ $lpkg->remove_status_file();
+ debug_msg(1, "Collecting info: $coll ...");
+ my $script = "$LINTIAN_ROOT/collection/$ci->{'script'}";
+ my $cmd = Lintian::Command::Simple->new();
+ unless ($cmd->background($script, $pkg, $long_type) > 0) {
+ warning("collect info $coll about package $pkg failed",
+ "skipping $action of $long_type package $pkg");
+ $exit_code = 2;
+ next PACKAGE;
+ }
+ $running_jobs{$coll} = $cmd;
+ } elsif ($ri->{'type'} eq 'check') {
+ # skip check if overrides were not yet loaded
+ last unless $loaded_overrides or $no_override;
+ my $check = $ri->{'name'};
+ my $ci = $check_info{$check};
+
+ # current type?
+ unless (exists $ci->{'type'}{$type}) {
$map->satisfy($req);
+ next;
}
- }
- # 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 ...');
-
- while (my ($coll, $cmd) = Lintian::Command::Simple::wait(\%running_jobs)) {
- delete $running_jobs{$coll};
- if ($cmd->status() == 0) {
- 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);
- debug_msg(1, "Collection script $coll done");
- } else {
- warning("collect info $coll about package $pkg failed");
+
+ debug_msg(1, "Running check: $check ...");
+ 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");
$exit_code = 2;
next PACKAGE;
}
+ $map->satisfy($req);
+ }
+ }
+ # 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 ...");
++ debug_msg(1, 'Reaping done jobs ...');
+
+ while (my ($coll, $cmd) = Lintian::Command::Simple::wait(\%running_jobs)) {
+ delete $running_jobs{$coll};
+ if ($cmd->status() == 0) {
+ 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";
++ . 'Timestamp: ' . time . "\n";
+ close(VERSION);
+ debug_msg(1, "Collection script $coll done");
+ } else {
+ warning("collect info $coll about package $pkg failed");
+ warning("skipping $action of $long_type package $pkg");
+ $exit_code = 2;
+ next PACKAGE;
+ }
- $map->satisfy('coll-' . $coll);
+ $map->satisfy('coll-' . $coll);
- # give a chance to other jobs to finish while we
- # process other stuff:
- last;
- }
+ # give a chance to other jobs to finish while we
+ # process other stuff:
+ last;
+ }
- unless ($no_override or $loaded_overrides) {
- if ($map->done('coll-override-file')) {
- debug_msg(1, 'Override file collected, loading it ...');
- $loaded_overrides = 1;
- $TAGS->file_overrides("$base/override")
- if (-f "$base/override");
- }
+ unless ($no_override or $loaded_overrides) {
+ if ($map->done('coll-override-file')) {
- debug_msg(1, "Override file collected, loading it ...");
++ debug_msg(1, 'Override file collected, loading it ...');
+ $loaded_overrides = 1;
+ $TAGS->file_overrides("$base/override")
+ if (-f "$base/override");
}
}
- %running_jobs = ();
-
- if ($action eq 'check') {
- unless ($exit_code) {
- my $stats = $TAGS->statistics($file);
- if ($stats->{types}{E}) {
- $exit_code = 1;
- } elsif ($fail_on_warnings && $stats->{types}{W}) {
- $exit_code = 1;
- }
+ }
+ %running_jobs = ();
+
+ if ($action eq 'check') {
+ unless ($exit_code) {
+ my $stats = $TAGS->statistics($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->overrides($file);
+ # report unused overrides
+ if (not $no_override) {
+ my $overrides = $TAGS->overrides($file);
- for my $tag (sort keys %$overrides) {
- next if $TAGS->suppressed($tag);
+ 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 $checks{$taginfo->script};
- }
+ # 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};
+ for my $extra (sort keys %{$overrides->{$tag}}) {
+ next if $overrides->{$tag}{$extra};
- tag( "unused-override", $tag, $extra );
- tag( 'unused-override', $tag, $extra );
- }
++ tag( 'unused-override', $tag, $extra );
}
}
+ }
- # Report override statistics.
- if (not $no_override and not $show_overrides) {
- my $stats = $TAGS->statistics($file);
- 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;
- }
+ # Report override statistics.
+ if (not $no_override and not $show_overrides) {
+ my $stats = $TAGS->statistics($file);
+ 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;
}
}
@@@ -1253,13 -1469,24 +1253,13 @@@
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;
- }
- }
# if the package's basedir was not removed then run the
# auto-remove: yes collection scripts
- if (-d "$base") {
+ if (!$keep_lab) {
chdir($base);
for my $coll (keys %collection_info) {
my $ci = $collection_info{$coll};
- if (defined($ci->{'auto-remove'}) && $ci->{'auto-remove'} eq "yes") {
+ if (defined($ci->{'auto-remove'}) && $ci->{'auto-remove'} eq 'yes') {
- next if $keep_lab;
next unless (-f "$base/.${coll}-$ci->{'version'}");
my $script = "$LINTIAN_ROOT/collection/$ci->{'script'}";
debug_msg(1, "Auto removing: $ci->{'script'} ...");
@@@ -1276,9 -1503,31 +1276,9 @@@
chdir($LINTIAN_ROOT);
}
- # 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 "Timestamp: $timestamp\n";
- close(STATUS);
- }
+ # All successful, make sure to record it so we do not recheck the same package
+ # in a later run (mostly for archive-wide checks).
+ $lpkg->update_status_file($LINTIAN_VERSION);
}
$TAGS->file_end();
@@@ -1301,7 -1550,7 +1301,7 @@@ if ($action eq 'check' and not $no_over
if ($info) {
push (@output, "$info info");
}
- msg("$total (". join (', ', @output). ")");
+ msg("$total (". join (', ', @output). ')');
}
}
@@@ -1321,169 -1570,119 +1321,169 @@@ exit $exit_code
# {{{ Some subroutines
-sub unpack_pkg {
- my ($type,$base,$file,$cur_level,$new_level) = @_;
+# 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};
+}
- debug_msg(1, sprintf('Current unpack level is %d',$cur_level));
+# 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') {
+ $type{'b'} = 1;
+ } elsif ($_ eq 'source') {
+ $type{'s'} = 1;
+ } elsif ($_ eq 'udeb') {
+ $type{'u'} = 1;
+ } elsif ($_ eq 'changes') {
+ $type{'c'} = 1;
+ } else {
+ fail("unknown type $_ specified in description file $f");
+ }
+ }
+ $p->{'type'} = \%type;
- return $cur_level if $cur_level == $new_level;
+ set_value($f,$p,'version',$secs[0],1);
+ set_value($f,$p,'auto-remove',$secs[0],0);
- # remove .lintian-status file
- remove_status_file($base);
+ 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'};
+ }
- 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;
- }
+ # ignore Info: and other fields for now
+ delete $secs[0]->{'info'};
+ delete $secs[0]->{'author'};
- 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')) {
- Lintian::Command::Simple::run("$LINTIAN_ROOT/unpack/unpack-binpkg-l1", $base, $file) == 0
- or return -1;
- } elsif ($type eq 'c') {
- spawn({}, ["$LINTIAN_ROOT/unpack/unpack-changes-l1", $base, $file])
- or return -1;
- } else {
- Lintian::Command::Simple::run("$LINTIAN_ROOT/unpack/unpack-srcpkg-l1", $base, $file) == 0
- or return -1;
+ for (keys %{$secs[0]}) {
+ warning("unused tag $_ in description file $f");
}
- $cur_level = 1;
- }
- if ($new_level >= 2) {
- warning('Requested no longer existent unpack-level 2, expect errors');
- return $cur_level;
+ debug_msg(2, map( { "$_: $p->{$_}" if defined($p->{$_}) } sort keys %$p ));
}
- return $cur_level;
+ closedir($dir);
}
-sub sort_coll {
- my ($ap, $bp);
- $ap = $map->getProp($a);
- $bp = $map->getProp($b);
- # override-file should be the first script to be run
- return -1 if ($ap->{'name'} eq 'override-file');
- return 1 if ($bp->{'name'} eq 'override-file');
- # sort collection scripts first
- return -1 if ($ap->{'type'} eq 'collection' && $bp->{'type'} ne 'collection');
- return 1 if ($bp->{'type'} eq 'collection' && $ap->{'type'} ne 'collection');
- return ($ap->{'name'} cmp $bp->{'name'});
-}
-
-# 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;
+# 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') {
+ $type{'b'} = 1;
+ } elsif ($_ eq 'source') {
+ $type{'s'} = 1;
+ } elsif ($_ eq 'udeb') {
+ $type{'u'} = 1;
+ } elsif ($_ eq 'changes') {
+ $type{'c'} = 1;
+ } else {
+ fail("unknown type $_ specified in description file $f");
+ }
}
+ $p->{'type'} = \%type;
- if ( ($new_level < 2) and defined ($cur_level) and ($cur_level >= 2) ) {
- # remove .lintian-status file
- remove_status_file($base);
+ set_value($f,$p,'abbrev',$secs[0],1);
- # 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;
+ 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'};
}
- $cur_level = 1;
- }
+ # ignore Info: and other fields for now...
+ delete $secs[0]->{'info'};
+ delete $secs[0]->{'standards-version'};
+ delete $secs[0]->{'author'};
- return $cur_level;
-}
+ for (keys %{$secs[0]}) {
+ warning("unused tag $_ in description file $f");
+ }
-# this function removes a package's base directory in the lab completely
-sub remove_pkg {
- my ($base) = @_;
+ debug_msg(2, map( { "$_: $p->{$_}" } sort keys %$p ));
- debug_msg(1, 'Removing package in lab ...');
- unless (delete_dir($base)) {
- warning("cannot remove directory $base: $!");
- return 0;
+ shift(@secs);
+ $p->{'requested-tags'} = 0;
+ foreach my $tag (@secs) {
+ $p->{'requested-tags'}++ if $tags->displayed($tag->{'tag'});
+ }
}
-
- return 1;
+ closedir($dir);
}
-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;
+sub sort_coll {
+ my ($ap, $bp);
+ $ap = $map->getProp($a);
+ $bp = $map->getProp($b);
+ # override-file should be the first script to be run
+ return -1 if ($ap->{'name'} eq 'override-file');
+ return 1 if ($bp->{'name'} eq 'override-file');
+ # sort collection scripts first
+ return -1 if ($ap->{'type'} eq 'collection' && $bp->{'type'} ne 'collection');
+ return 1 if ($bp->{'type'} eq 'collection' && $ap->{'type'} ne 'collection');
+ return ($ap->{'name'} cmp $bp->{'name'});
}
# -------------------------------
diff --combined unpack/unpack-binpkg-l1
index 245310a,2ee32e6..3eedb00
--- a/unpack/unpack-binpkg-l1
+++ b/unpack/unpack-binpkg-l1
@@@ -24,9 -24,10 +24,10 @@@
# MA 02110-1301, USA.
use strict;
+ use warnings;
use vars qw($verbose);
- ($#ARGV == 1) or die "syntax: unpack-binpkg-l1 <base-dir> <deb-file>";
+ ($#ARGV == 1) or die 'syntax: unpack-binpkg-l1 <base-dir> <deb-file>';
my $base_dir = shift;
my $file = shift;
@@@ -43,9 -44,42 +44,9 @@@ my (@jobs, $job)
# create directory in lab
print "N: Creating directory $base_dir ...\n" if $verbose;
mkdir("$base_dir", 0777) or fail("mkdir $base_dir: $!");
mkdir("$base_dir/fields", 0777) or fail("mkdir $base_dir/fields: $!");
symlink($file,"$base_dir/deb") or fail("symlink: $!");
-# The following calls use knowledge of the .deb format for speed
-
-# (replaces dpkg-deb -e)
-# extract control files' tarball
-spawn({ fail => 'error', out => "$base_dir/control.tar" },
- ['ar', 'p', $file, 'control.tar.gz'],
- '|', ['gzip', '-dc']);
-
-$job = { fail => 'error', err => "$base_dir/control-errors" };
-push @jobs, $job;
-# extract the tarball's contents
-spawn($job,
- ['tar', 'xf', "$base_dir/control.tar", '-C', "$base_dir/control", '&']);
-
-$job = { fail => 'error',
- out => "$base_dir/control-index",
- err => "$base_dir/control-index-errors" };
-push @jobs, $job;
-# create index of control.tar.gz
-spawn($job,
- ['tar', 'tvf', "$base_dir/control.tar"],
- '|', ['sort', '-k', '6'], '&');
-
-reap(@jobs);
-undef @jobs;
-# clean up control.tar
-unlink("$base_dir/control.tar") or fail();
-
-# fix permissions
-spawn({ fail => 'error' },
- ['chmod', '-R', 'u+rX,o-w', "$base_dir/control"]);
-
$job = { fail => 'error',
out => "$base_dir/index",
err => "$base_dir/index-errors" };
@@@ -53,10 -87,10 +54,10 @@@ push @jobs, $job
# (replaces dpkg-deb -c)
# create index file for package
spawn($job,
- ["dpkg-deb", "--fsys-tarfile", $file ],
- '|', ["tar", "tfv", "-"],
- '|', ["sed", "-e", "s/^h/-/"],
- '|', ["sort", "-k", "6"], '&');
+ ['dpkg-deb', '--fsys-tarfile', $file ],
+ '|', ['tar', 'tfv', '-'],
+ '|', ['sed', '-e', 's/^h/-/'],
+ '|', ['sort', '-k', '6'], '&');
$job = { fail => 'error',
out => "$base_dir/index-owner-id",
@@@ -65,12 -99,33 +66,12 @@@ push @jobs, $job
# (replaces dpkg-deb -c)
# create index file for package with owner IDs instead of names
spawn($job,
- ["dpkg-deb", "--fsys-tarfile", $file],
- '|', ["tar", "--numeric-owner", "-tvf", "-"],
- '|', ["sed", "-e", "s/^h/-/"],
- '|', ["sort", "-k", "6"], '&');
+ ['dpkg-deb', '--fsys-tarfile', $file],
+ '|', ['tar', '--numeric-owner', '-tvf', '-'],
+ '|', ['sed', '-e', 's/^h/-/'],
+ '|', ['sort', '-k', '6'], '&');
-# get package control information
-my $data = (read_dpkg_control("$base_dir/control/control"))[0];
-$data->{'source'} or ($data->{'source'} = $data->{'package'});
-
-# create control field files
-for my $field (keys %$data) {
- my $value = $data->{$field};
- # checks/fields will convert colons into slashes
- $field =~ s,/,:,g;
- my $field_file = "$base_dir/fields/$field";
- open(F, '>', $field_file) or fail("cannot open file $field_file for writing: $!");
- print F $value,"\n";
- close(F);
-}
-# create symlink to source package
-$data->{'source'} =~ s/\s*\(.*\)\s*$//;
-# but only create it if it doesn't traverse directories
-if ($data->{'source'} !~ m,/,) {
- symlink("../../source/$data->{'source'}","$base_dir/source")
- or fail("symlink: $!");
-}
reap(@jobs);
undef @jobs;
--
Debian package checker
Reply to: