[SCM] Debian package checker branch, master, updated. 2.5.0-rc2-122-g12888e8
The following commit has been merged in the master branch:
commit addf1234f3814254dec1914660e0b9893edae325
Merge: 8fda039784df5169d4b834c173be58392f0e0ca6 6a61ae81c7218a4468e33fee7b68ad77ad1e96fe
Author: Niels Thykier <niels@thykier.net>
Date: Sun Jan 16 12:51:37 2011 +0100
Merge branch 'master' into infra-513663
diff --combined frontend/lintian
index dd0c46b,bbbd1de..f2936b8
--- a/frontend/lintian
+++ b/frontend/lintian
@@@ -25,7 -25,6 +25,7 @@@
use strict;
use Getopt::Long;
+use Cwd;
# }}}
# {{{ Global Variables
@@@ -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
@@@ -88,7 -88,7 +88,7 @@@ my $exit_code = 0
my $LAB;
my %collection_info;
-my %checks;
+my %enabled_checks;
my %check_abbrev;
my %unpack_infos;
my %check_info;
@@@ -97,6 -97,7 +97,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;
@@@ -385,6 -386,7 +385,6 @@@ my %opthash = ( # ------------------
"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,
@@@ -426,7 -428,7 +426,7 @@@ 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'};
@@@ -482,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 SECTION AREA ARCH);
# read configuration file
if ($LINTIAN_CFG) {
open(CFG, '<', $LINTIAN_CFG)
@@@ -544,6 -546,28 +544,6 @@@ if (defined $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';
@@@ -581,9 -605,6 +581,9 @@@ require Read_pkglists
import Util;
+require Checker;
+require Lintian::Collect;
+require Lintian::DepMap::Properties;
require Lintian::Data;
require Lintian::Schedule;
require Lintian::Output;
@@@ -638,6 -659,7 +638,6 @@@ debug_msg(1
"Laboratory: $LINTIAN_LAB",
"Archive directory: $LINTIAN_ARCHIVEDIR",
"Distribution: $LINTIAN_DIST",
- "Default unpack level: $LINTIAN_UNPACK_LEVEL",
"Architecture: $LINTIAN_ARCH",
delimiter(),
);
@@@ -842,71 -864,182 +842,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");
}
+} 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.");
+ 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);
@@@ -915,7 -1048,7 +915,7 @@@
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");
@@@ -933,11 -1066,11 +933,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");
}
@@@ -945,7 -1078,7 +945,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}) {
@@@ -957,57 -1090,29 +957,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'}});
@@@ -1015,12 -1120,76 +1015,12 @@@
}
# }}}
-# {{{ 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));
debug_msg(1,
"Selected action: $action",
- "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)),
);
@@@ -1028,34 -1197,8 +1028,34 @@@
scalar($map->missing()) == 0
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 = ".";
+ $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;
@@@ -1063,22 -1206,9 +1063,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 = ".";
+ $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();
@@@ -1088,173 -1218,246 +1088,173 @@@
%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",
+ "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;
+ 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};
- # 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};
-
- # 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 ...");
+
+ 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");
+ 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;
- }
+ # If that node allowed us to start on another, then we
+ # leave this loop.
+ last unless ($map->selectable());
+ }
- 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 ...");
+ $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 );
}
}
+ }
- # 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;
}
}
@@@ -1266,13 -1469,24 +1266,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") {
- 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'} ...");
@@@ -1289,9 -1503,31 +1289,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();
@@@ -1320,173 -1556,133 +1320,183 @@@ if ($action eq 'check' and not $no_over
# }}}
+
+ # Wait for any remaining jobs - %running_jobs will usually be empty here
+ # unless we had an issue examining the last package. We patiently wait
+ # for them here; if the user cannot be bothered to wait, he/she can send
+ # us a signal and the END handler will kill any remaining jobs.
+ while (my ($coll, undef) = Lintian::Command::Simple::wait(\%running_jobs)) {
+ delete $running_jobs{$coll};
+ }
+ %running_jobs = ();
+
exit $exit_code;
# {{{ Some subroutines
-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;
-}
-
-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'});
+ closedir($dir);
}
-# 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'});
}
# -------------------------------
@@@ -1552,6 -1748,12 +1562,12 @@@ sub END
$SIG{'INT'} = 'DEFAULT';
$SIG{'QUIT'} = 'DEFAULT';
+ # Kill any remaining jobs.
+ if(%running_jobs) {
+ Lintian::Command::Simple::kill(\%running_jobs);
+ %running_jobs = ();
+ }
+
$LAB->delete() if $LAB and not $keep_lab;
}
--
Debian package checker
Reply to: