[SCM] Debian package checker branch, master, updated. 2.3.4-50-g7610c46
The following commit has been merged in the master branch:
commit e951eccb1fa34405b3a3ae2b022669b0cf835a8c
Author: Raphael Geissert <atomo64@gmail.com>
Date: Mon Sep 21 11:33:10 2009 -0500
Run the checks as soon as the info they need is collected
This introduces Lintian::PDepMap which is a layer on top of
Lintian::DepMap to support per-node properties.
diff --git a/frontend/lintian b/frontend/lintian
index 70bcfae..c4d9a55 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -916,7 +916,6 @@ for my $f (readdir COLLDIR) {
}
$p->{'type'} = \%type;
- set_value($f,$p,'unpack-level',$secs[0],1);
set_value($f,$p,'version',$secs[0],1);
set_value($f,$p,'auto-remove',$secs[0],0);
@@ -987,6 +986,7 @@ for my $f (readdir CHECKDIR) {
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'};
@@ -1084,15 +1084,24 @@ if ($action eq 'check') {
# }}}
-require Lintian::DepMap;
+require Lintian::PDepMap;
-my $coll_map = Lintian::DepMap->new();
+my $map = Lintian::PDepMap->new();
# {{{ determine which info is needed by the collection scripts
for my $c (keys %unpack_infos) {
- $coll_map->add($c);
+ $map->add('coll-' . $c, {'type' => 'collection', 'name' => $c});
if (exists $collection_info{$c}{'needs-info'}) {
- $coll_map->add($c, @{$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) {
+ $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'}});
}
}
# }}}
@@ -1154,12 +1163,13 @@ unless ($count) {
# }}}
# {{{ Okay, now really processing the packages in one huge loop
-$coll_map->add('override-file') unless $no_override;
+$map->add('coll-override-file', {'type' => 'collection', 'name' => 'override-file'})
+ unless $no_override;
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 $coll_map->known)),
+ sprintf("Requested data to collect: %s", join(',',sort keys %unpack_infos)),
sprintf("Selected checks: %s", join(',',sort keys %checks)),
);
@@ -1177,7 +1187,7 @@ foreach my $pkg_info ($schedule->get_all) {
($type eq 's' ? 'source' : 'udeb' )));
$TAGS->file_start($file, $pkg, $ver, $arch, $long_type);
- $coll_map->initialise();
+ $map->initialise();
# Kill pending jobs, if any
Lintian::Command::kill(@pending_jobs);
@@ -1266,139 +1276,153 @@ foreach my $pkg_info ($schedule->get_all) {
next PACKAGE;
}
- if (($action eq 'unpack') or ($action eq 'check')) { # collect info
- while ($coll_map->pending) {
- for my $coll ($coll_map->selectable) {
- my $ci = $collection_info{$coll};
- my %run_opts = ('description' => $coll);
+ 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};
+ my %run_opts = ('description' => $coll);
+
+ # current type?
+ unless (exists $ci->{'type'}{$type}) {
+ $map->satisfy($req);
+ next;
+ }
- # current type?
- unless (exists $ci->{'type'}{$type}) {
- $coll_map->satisfy($coll);
- 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);
+
+ # 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 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'}") {
- $coll_map->satisfy($coll);
- next;
- }
- opendir(BASE, $base)
- or fail("cannot read directory $base: $!");
- for my $file (readdir BASE) {
- if ($file =~ /^\.\Q$coll-/) {
- unlink("$base/$file");
+ # collect info
+ $map->select($req);
+ remove_status_file($base);
+ debug_msg(1, "Collecting info: $coll ...");
+ my $script = "$LINTIAN_ROOT/collection/$ci->{'script'}";
+ unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&'])) {
+ warning("collect info $coll about package $pkg failed",
+ "skipping $action of $long_type package $pkg");
+ $exit_code = 2;
+ next PACKAGE;
+ }
+ push @pending_jobs, \%run_opts;
+ } 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;
}
- }
- closedir(BASE);
- # 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;
- }
+ # 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;
+ }
- # collect info
- $coll_map->select($coll);
- remove_status_file($base);
- debug_msg(1, "Collecting info: $coll ...");
- my $script = "$LINTIAN_ROOT/collection/$ci->{'script'}";
- unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&' ])) {
- warning("collect info $coll about package $pkg failed",
- "skipping $action of $long_type package $pkg");
- $exit_code = 2;
- next PACKAGE;
+ 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;
+ }
+ $map->satisfy($req);
}
- push @pending_jobs, \%run_opts;
}
# 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 ...");
- unless (reap_collect_jobs($pkg, $base, \@pending_jobs, $coll_map)) {
+ unless (reap_collect_jobs($pkg, $base, \@pending_jobs, $map)) {
warning("skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
+ 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");
+ }
+ }
}
undef @pending_jobs;
- }
-
- if ($action eq 'check') { # read override file
-
- unless ($no_override) {
- $TAGS->file_overrides("$base/override") if -f "$base/override";
- }
-
- # perform checks
- my $info = Lintian::Collect->new($pkg, $long_type);
- for my $check (sort keys %checks) {
- my $ci = $check_info{$check};
-
- # current type?
- next unless (exists $ci->{'type'}{$type});
- # 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 '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;
+ }
}
- 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;
- }
+ # report unused overrides
+ if (not $no_override) {
+ my $overrides = $TAGS->overrides($file);
- }
- 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;
- }
- }
+ for my $tag (sort keys %$overrides) {
+ next if $TAGS->suppressed($tag);
- # report unused overrides
- if (not $no_override) {
- my $overrides = $TAGS->overrides($file);
+ # Did we run the check script containing the tag?
+ my $taginfo = Lintian::Tag::Info->new($tag);
+ if (defined $taginfo) {
+ next unless $checks{$taginfo->script};
+ }
- for my $tag (sort keys %$overrides) {
- next if $TAGS->suppressed($tag);
+ for my $extra (sort keys %{$overrides->{$tag}}) {
+ next if $overrides->{$tag}{$extra};
- # Did we run the check script containing the tag?
- my $taginfo = Lintian::Tag::Info->new($tag);
- if (defined $taginfo) {
- next unless $checks{$taginfo->script};
+ tag( "unused-override", $tag, $extra );
+ }
}
+ }
- for my $extra (sort keys %{$overrides->{$tag}}) {
- next if $overrides->{$tag}{$extra};
-
- tag( "unused-override", $tag, $extra );
- }
+ # Report override statistics.
+ if (not $no_override and not $show_overrides) {
+ my $stats = $TAGS->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;
- }
}
# chdir to lintian root directory (to unlock $base so it can be removed below)
@@ -1549,7 +1573,7 @@ sub unpack_pkg {
# Takes the current package, base directory, and the list of pending jobs.
# Return true if all done jobs were successful, false otherwise.
sub reap_collect_jobs {
- my ($pkg, $base, $pending_jobs, $coll_map) = @_;
+ my ($pkg, $base, $pending_jobs, $map) = @_;
my $status = 1;
my $_pending_jobs = [];
@@ -1575,7 +1599,7 @@ sub reap_collect_jobs {
warning("collect info $coll about package $pkg failed");
}
- $coll_map->satisfy($coll);
+ $map->satisfy('coll-' . $coll);
# break here to give some time for other jobs to finish
# while we try to start another job
last;
@@ -1585,6 +1609,19 @@ sub reap_collect_jobs {
return $status;
}
+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 {
diff --git a/lib/Lintian/DepMap.pm b/lib/Lintian/DepMap.pm
index 6ab2aff..1cd2466 100644
--- a/lib/Lintian/DepMap.pm
+++ b/lib/Lintian/DepMap.pm
@@ -159,6 +159,17 @@ sub add {
} else { 1; }
}
+sub addp {
+ my ($self,$node,$prefix) = (shift,shift,shift);
+ my @deps;
+
+ while (my $dep = shift) {
+ push @deps, $prefix . $dep;
+ }
+
+ return $self->add($node, @deps);
+}
+
=item satisfy(node)
Indicates that the given C<node> has been satisfied/done.
@@ -214,6 +225,12 @@ sub satisfy {
delete $self->{'nodes'}{$node};
}
+sub done {
+ my $self = shift;
+ my $node = shift;
+ return exists $self->{'satisfied_nodes'}->{$node};
+}
+
=item unlink(node[, 'soft'])
Removes all references to the given C<node> except for the entry in the
diff --git a/lib/Lintian/PDepMap.pm b/lib/Lintian/PDepMap.pm
new file mode 100644
index 0000000..bce7345
--- /dev/null
+++ b/lib/Lintian/PDepMap.pm
@@ -0,0 +1,128 @@
+# Copyright (C) 2009 Raphael Geissert <atomo64@gmail.com>
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::PDepMap;
+
+use strict;
+use warnings;
+use base 'Lintian::DepMap';
+
+my ($properties);
+
+=head1 NAME
+
+Lintian::PDepMap - Dependencies with properties map/tree creator
+
+=head1 SYNOPSIS
+
+ use Lintian::PDepMap;
+
+ my $map = Lintian::DepMap->new();
+
+
+=head1 DESCRIPTION
+
+Lintian::PDepMap is a simple layer between Lintian::DepMap and the
+application allowing nodes to have application-defined properties.
+
+
+=over 4
+
+=item new()
+
+Creates a new Lintian::PDepMap object and returns a reference to it.
+
+=cut
+
+sub new {
+ my ($class, $pkg) = @_;
+ my $self = {};
+ bless($self, $class);
+ return $self;
+}
+
+=item add(node, [dependencies], [ref to property])
+
+Adds a node with possibly one or more dependencies and sets the C<node>'s
+property to the ref, if defined. The property must be a reference (it
+can be to a hash, an array, a function, an object, etc) and must be the
+last argument given to the method.
+
+E.g.
+
+ $map->add('foo', {name => 'John Doe', age => 20});
+
+=cut
+#'
+
+sub add {
+ my $self = shift;
+ my $ref = pop;
+ if (not defined $ref) {
+ # do nothing if not defined
+ } elsif (not ref($ref)) {
+ push @_, $ref;
+ } else {
+ $self->{'properties'}->{$_[0]} = $ref;
+ }
+ return $self->SUPER::add(@_);
+}
+
+sub addp {
+ my $self = shift;
+ my $ref = pop;
+ if (not defined $ref) {
+ # do nothing if not defined
+ } elsif (not ref($ref)) {
+ push @_, $ref;
+ } else {
+ $self->{'properties'}->{$_[0]} = $ref;
+ }
+ return $self->SUPER::addp(@_);
+}
+
+=item getProp(node)
+
+Returns the reference to the given C<node>'s properties.
+
+E.g.
+
+ # prints John Doe
+ print $map->getProp('foo')->{'name'};
+ # changes the value of 'name'
+ $map->getProp('foo')->{'name'} = 'Jane Doe';
+ # prints Jane Doe
+ print $map->getProp('foo')->{'name'};
+
+=cut
+#'
+
+sub getProp {
+ my $self = shift;
+ my $node = shift;
+ return $self->{'properties'}->{$node};
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Raphael Geissert <atomo64@gmail.com> for Lintian.
+
+=cut
diff --git a/t/scripts/Lintian/DepMap/11prefix.t b/t/scripts/Lintian/DepMap/11prefix.t
new file mode 100644
index 0000000..b70ebf1
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/11prefix.t
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+use Test::More tests => 2;
+
+use Lintian::DepMap;
+
+my $map = Lintian::DepMap->new();
+
+$map->add('pA');
+$map->add('pB', 'pA');
+ok( eval {$map->addp('foo', 'p', 'A')}, "Add foo depending on 'p'+'A'");
+
+$map->satisfy('pA');
+
+ok($map->selectable('foo'), "foo is selectable");
diff --git a/t/scripts/Lintian/DepMap/12done.t b/t/scripts/Lintian/DepMap/12done.t
new file mode 100644
index 0000000..3287aae
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/12done.t
@@ -0,0 +1,19 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 4;
+
+use Lintian::DepMap;
+
+my $obj = Lintian::DepMap->new();
+
+$obj->add('A');
+ok(!$obj->done('A'), "A is not done yet");
+ok(!$obj->done('B'), "B is not done yet");
+
+$obj->select('A');
+ok(!$obj->done('A'), "A is still not done");
+
+$obj->satisfy('A');
+ok($obj->done('A'), "A is finally done");
+
diff --git a/t/scripts/Lintian/PDepMap/00construct.t b/t/scripts/Lintian/PDepMap/00construct.t
new file mode 100644
index 0000000..f2c7d9e
--- /dev/null
+++ b/t/scripts/Lintian/PDepMap/00construct.t
@@ -0,0 +1,21 @@
+#!/usr/bin/perl -w
+
+use Test::More qw(no_plan);
+
+BEGIN { use_ok('Lintian::PDepMap'); }
+
+my $map;
+
+ok(eval { $map = Lintian::PDepMap->new(); }, 'Create');
+
+my %prop = (name => 'John Doe', age => 20);
+
+ok($map->add('P1', \%prop), "Add node with properties as a hash");
+
+is_deeply($map->getProp('P1'), \%prop, "Properties are preserved");
+
+ok($map->add('P2', 'P1'), "Nodes can be added without properties");
+
+ok(eval {$map->satisfy('P1');}, "Nodes can be satisfied");
+
+ok($map->addp('foo', 'P', '1', '2', {name => 'test'}), "Nodes can be added with prefix");
--
Debian package checker
Reply to: