[SCM] Debian package checker branch, master, updated. 2.3.4-50-g7610c46
The following commit has been merged in the master branch:
commit a55da02dc7e877511d76e6a4a994510da529b3db
Author: Raphael Geissert <atomo64@gmail.com>
Date: Thu Sep 17 11:38:54 2009 -0500
Run the collection scripts based on their dependencies instead of the order.
This introduces Lintian::DepMap, a simple dependencies map/tree creator and
solver. This is the base for further work on parallelising the execution
of collection and check scripts.
Lintian::DepMap itself is intended to become a standalone general-pourpose
simple solver.
diff --git a/collection/ar-info.desc b/collection/ar-info.desc
index 1fed4fa..45c1d7b 100644
--- a/collection/ar-info.desc
+++ b/collection/ar-info.desc
@@ -4,4 +4,3 @@ Info: This script runs the "ar t" command over all .a files of package.
Type: binary
Needs-Info: unpacked
Version: 1
-Order: 1
diff --git a/collection/changelog-file.desc b/collection/changelog-file.desc
index 4caae66..caa6950 100644
--- a/collection/changelog-file.desc
+++ b/collection/changelog-file.desc
@@ -5,5 +5,4 @@ Info: This script copies the <tt>changelog</tt> file and
directory.
Type: binary
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/copyright-file.desc b/collection/copyright-file.desc
index 785266c..e0ae131 100644
--- a/collection/copyright-file.desc
+++ b/collection/copyright-file.desc
@@ -4,5 +4,4 @@ Info: This script copies the "copyright" file of a package into the
lintian directory.
Type: binary
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/debfiles.desc b/collection/debfiles.desc
index 9c374bb..18c7e92 100644
--- a/collection/debfiles.desc
+++ b/collection/debfiles.desc
@@ -4,5 +4,4 @@ Info: This script collects files shipped in the source of the
package.
Type: source
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/debian-readme.desc b/collection/debian-readme.desc
index 5b17a83..d792c75 100644
--- a/collection/debian-readme.desc
+++ b/collection/debian-readme.desc
@@ -3,5 +3,4 @@ Author: Richard Braakman <dark@xs4all.nl>
Info: This script copies the 'README.Debian' file of a package into the lintian directory.
Type: binary
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/diffstat.desc b/collection/diffstat.desc
index 992b0db..a714306 100644
--- a/collection/diffstat.desc
+++ b/collection/diffstat.desc
@@ -4,4 +4,3 @@ Info: This script extracts the Debian diff of a source package, and runs
diffstat on it, leaving the result in the diffstat output file
Type: source
Version: 1
-Order: 1
diff --git a/collection/doc-base-files.desc b/collection/doc-base-files.desc
index 5d687af..ee4652d 100644
--- a/collection/doc-base-files.desc
+++ b/collection/doc-base-files.desc
@@ -4,5 +4,4 @@ Info: This script copies the contents of /usr/share/doc-base into the
lintian doc-base/ directory.
Type: binary
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/file-info.desc b/collection/file-info.desc
index b82f33e..ca6f615 100644
--- a/collection/file-info.desc
+++ b/collection/file-info.desc
@@ -3,5 +3,4 @@ Author: Richard Braakman <dark@xs4all.nl>
Info: This script runs the "file" command over all files of any kind of package.
Type: binary, udeb, source
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/init.d.desc b/collection/init.d.desc
index 85ea0ee..de7e7d3 100644
--- a/collection/init.d.desc
+++ b/collection/init.d.desc
@@ -4,5 +4,4 @@ Info: This script copies the "etc/init.d" directory into the lintian
directory.
Type: binary
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/md5sums.desc b/collection/md5sums.desc
index 3e1b11d..2697eb6 100644
--- a/collection/md5sums.desc
+++ b/collection/md5sums.desc
@@ -3,5 +3,4 @@ Author: Richard Braakman <dark@xs4all.nl>
Info: This script runs the "md5sums" over all files in a binary package.
Type: binary, udeb
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/menu-files.desc b/collection/menu-files.desc
index 92495b6..cce2451 100644
--- a/collection/menu-files.desc
+++ b/collection/menu-files.desc
@@ -3,5 +3,4 @@ Author: Richard Braakman <dark@xs4all.nl>
Info: This script copies the contents of /usr/lib/menu into the lintian menu/ directory.
Type: binary
Version: 2
-Order: 1
Needs-Info: unpacked
diff --git a/collection/objdump-info.desc b/collection/objdump-info.desc
index d52ec36..f3af27a 100644
--- a/collection/objdump-info.desc
+++ b/collection/objdump-info.desc
@@ -4,5 +4,4 @@ Info: This script runs "objdump" over all binaries and object files of a
binary package.
Type: binary, udeb
Version: 1
-Order: 2
Needs-Info: file-info, unpacked
diff --git a/collection/override-file.desc b/collection/override-file.desc
index 0a2cc54..b1414f4 100644
--- a/collection/override-file.desc
+++ b/collection/override-file.desc
@@ -4,5 +4,4 @@ Info: This script copies the "override" file of a package into the lintian
directory.
Type: binary, udeb, source
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/scripts.desc b/collection/scripts.desc
index 1e577a0..2ea8d3b 100644
--- a/collection/scripts.desc
+++ b/collection/scripts.desc
@@ -7,5 +7,4 @@ Info: This script scans a binary package for scripts that start with #! and
because linux only looks at the first word when executing a script.
Type: binary, udeb
Version: 1
-Order: 1
Needs-Info: unpacked
diff --git a/collection/source-control-file.desc b/collection/source-control-file.desc
index ab05fe9..9260a55 100644
--- a/collection/source-control-file.desc
+++ b/collection/source-control-file.desc
@@ -3,5 +3,4 @@ Author: Frank Lichtenheld <djpig@debian.org>
Info: Collects information about binary packages from debian/control in source packages
Type: source
Version: 1
-Order: 2
Needs-Info: debfiles
diff --git a/collection/strings.desc b/collection/strings.desc
index 60640ec..3d2dcfc 100644
--- a/collection/strings.desc
+++ b/collection/strings.desc
@@ -4,5 +4,4 @@ Info: This script runs the "strings" command over all files of a binary
package.
Type: binary, udeb
Version: 1
-Order: 2
Needs-Info: unpacked, file-info
diff --git a/collection/unpacked.desc b/collection/unpacked.desc
index ff3074a..871abb7 100644
--- a/collection/unpacked.desc
+++ b/collection/unpacked.desc
@@ -3,5 +3,4 @@ Author: Raphael Geissert <atomo64@gmail.com>
Info: This script unpacks the package under the unpacked/ directory
Type: binary, udeb, source
Version: 1
-Order: 0
Auto-Remove: yes
diff --git a/frontend/lintian b/frontend/lintian
index 28700ca..70bcfae 100755
--- a/frontend/lintian
+++ b/frontend/lintian
@@ -900,29 +900,29 @@ for my $f (readdir COLLDIR) {
set_value($f, $p,'type',$secs[0],1);
# convert Type:
- my ($b,$s,$u,$c) = ( "", "", "", "" );;
+ my %type;
for (split(/\s*,\s*/o,$p->{'type'})) {
if ($_ eq 'binary') {
- $b = 'b';
+ $type{'b'} = 1;
} elsif ($_ eq 'source') {
- $s = 's';
+ $type{'s'} = 1;
} elsif ($_ eq 'udeb') {
- $u = 'u';
+ $type{'u'} = 1;
} elsif ($_ eq 'changes') {
- $c = 'c';
+ $type{'c'} = 1;
} else {
fail("unknown type $_ specified in description file $f");
}
}
- $p->{'type'} = "$s$b$u$c";
+ $p->{'type'} = \%type;
- set_value($f,$p,'order',$secs[0],1);
+ 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);
if (exists $secs[0]->{'needs-info'} && defined $secs[0]->{'needs-info'}) {
for (split(/\s*,\s*/o,$secs[0]->{'needs-info'})) {
- $p->{$_} = 1;
+ push @{$p->{'needs-info'}}, $_;
}
delete $secs[0]->{'needs-info'};
}
@@ -966,22 +966,22 @@ for my $f (readdir CHECKDIR) {
my $p = $check_info{$script};
set_value($f,$p,'type',$secs[0],1);
+ my %type;
# convert Type:
- my ($b,$s,$u,$c) = ( "", "", "", "" );
for (split(/\s*,\s*/o,$p->{'type'})) {
if ($_ eq 'binary') {
- $b = 'b';
+ $type{'b'} = 1;
} elsif ($_ eq 'source') {
- $s = 's';
+ $type{'s'} = 1;
} elsif ($_ eq 'udeb') {
- $u = 'u';
+ $type{'u'} = 1;
} elsif ($_ eq 'changes') {
- $c = 'c';
+ $type{'c'} = 1;
} else {
fail("unknown type $_ specified in description file $f");
}
}
- $p->{'type'} = "$s$b$u$c";
+ $p->{'type'} = \%type;
set_value($f,$p,'abbrev',$secs[0],1);
@@ -1084,13 +1084,15 @@ if ($action eq 'check') {
# }}}
+require Lintian::DepMap;
+
+my $coll_map = Lintian::DepMap->new();
+
# {{{ determine which info is needed by the collection scripts
for my $c (keys %unpack_infos) {
- for my $i (keys %collection_info) {
- # required by $c ?
- if ($collection_info{$c}->{$i}) {
- $unpack_infos{$i} = 1;
- }
+ $coll_map->add($c);
+ if (exists $collection_info{$c}{'needs-info'}) {
+ $coll_map->add($c, @{$collection_info{$c}{'needs-info'}});
}
}
# }}}
@@ -1144,19 +1146,20 @@ if ($check_everything) {
# }}}
# {{{ Some silent exit
-unless ($schedule->count) {
+my $count = $schedule->count;
+unless ($count) {
v_msg("No packages selected.");
exit 0;
}
# }}}
# {{{ Okay, now really processing the packages in one huge loop
-$unpack_infos{ "override-file" } = 1 unless $no_override;
-v_msg(sprintf("Processing %d packages...", $schedule->count));
+$coll_map->add('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 keys %unpack_infos)),
+ sprintf("Requested data to collect: %s", join(',',sort $coll_map->known)),
sprintf("Selected checks: %s", join(',',sort keys %checks)),
);
@@ -1174,6 +1177,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();
# Kill pending jobs, if any
Lintian::Command::kill(@pending_jobs);
@@ -1263,26 +1267,32 @@ foreach my $pkg_info ($schedule->get_all) {
}
if (($action eq 'unpack') or ($action eq 'check')) { # collect info
- my $current_order = -1;
- for my $coll (sort by_collection_order keys %unpack_infos) {
- my $ci = $collection_info{$coll};
- my %run_opts = ('description' => $coll);
+ while ($coll_map->pending) {
+ for my $coll ($coll_map->selectable) {
+ my $ci = $collection_info{$coll};
+ my %run_opts = ('description' => $coll);
+
+ # current type?
+ unless (exists $ci->{'type'}{$type}) {
+ $coll_map->satisfy($coll);
+ next;
+ }
- # current type?
- next unless ($ci->{'type'} =~ m/$type/);
-
- # If a file named .SCRIPT-VERSION already exists, we've already
- # collected this information and we can skip it. Otherwise,
- # remove any .SCRIPT-* files (which are old version information).
- next if (-f "$base/.${coll}-$ci->{'version'}");
- opendir(BASE, $base)
- or fail("cannot read directory $base: $!");
- for my $file (readdir BASE) {
- if ($file =~ /^\.\Q$coll-/) {
- unlink("$base/$file");
+ # 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;
}
- }
- closedir(BASE);
+ 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)) {
@@ -1292,38 +1302,27 @@ foreach my $pkg_info ($schedule->get_all) {
next PACKAGE;
}
- $current_order = $ci->{'order'} if ($current_order == -1);
- if ($current_order != $ci->{'order'}) {
- debug_msg(1, "Waiting for jobs from order $current_order ...");
- unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
- warning("skipping $action of $long_type package $pkg");
+ # 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;
}
- undef @pending_jobs;
- $current_order = $ci->{'order'};
+ push @pending_jobs, \%run_opts;
}
-
- # collect info
- remove_status_file($base);
- debug_msg(1, "Collecting info: $coll ...");
- my $script = "$LINTIAN_ROOT/collection/$ci->{'script'}";
- unless (spawn(\%run_opts, [ $script, $pkg, $long_type, '&' ])) {
- warning("collect info $coll about package $pkg failed",
- "skipping $action of $long_type package $pkg");
+ # 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)) {
+ warning("skipping $action of $long_type package $pkg");
$exit_code = 2;
next PACKAGE;
}
- push @pending_jobs, \%run_opts;
- }
-
- # wait until all the jobs finish and skip this package if any of them
- # failed.
- debug_msg(1, "Waiting for jobs from order $current_order ...");
- unless (reap_collect_jobs($pkg, $base, @pending_jobs)) {
- warning("skipping $action of $long_type package $pkg");
- $exit_code = 2;
- next PACKAGE;
}
undef @pending_jobs;
}
@@ -1340,7 +1339,7 @@ foreach my $pkg_info ($schedule->get_all) {
my $ci = $check_info{$check};
# current type?
- next unless ($ci->{'type'} =~ m/$type/);
+ next unless (exists $ci->{'type'}{$type});
# chdir to base directory
unless (chdir($base)) {
@@ -1542,16 +1541,27 @@ sub unpack_pkg {
}
# Given a list of jobs corresponding to collect scripts, reap each of the
-# jobs. For each successful job, record that it was successful by creating
-# the corresponding version marker file in the lab. For each unsuccessful
+# jobs without blocking. For each successful job, record that it was
+# successful by creating the corresponding version marker file in the lab and
+# marking it as done in the dependencies map. For each unsuccessful
# job, warn that it was unsuccessful.
#
# Takes the current package, base directory, and the list of pending jobs.
-# Return true if all jobs were successful, false otherwise.
+# Return true if all done jobs were successful, false otherwise.
sub reap_collect_jobs {
- my ($pkg, $base, @pending_jobs) = @_;
- my $status = reap(@pending_jobs);
- for my $job (@pending_jobs) {
+ my ($pkg, $base, $pending_jobs, $coll_map) = @_;
+ my $status = 1;
+ my $_pending_jobs = [];
+
+ while (my $job = pop @{pending_jobs}) {
+
+ if (!Lintian::Command::done($job)) {
+ push @{$_pending_jobs}, $job;
+ next;
+ }
+
+ $status &&= reap($job);
+
my $coll = $job->{'description'};
if ($job->{success}) {
my $ci = $collection_info{$coll};
@@ -1560,10 +1570,18 @@ sub reap_collect_jobs {
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");
}
+
+ $coll_map->satisfy($coll);
+ # break here to give some time for other jobs to finish
+ # while we try to start another job
+ last;
}
+
+ @{$pending_jobs} = (@{$pending_jobs}, @{$_pending_jobs});
return $status;
}
@@ -1681,10 +1699,6 @@ sub read_file {
return $t;
}
-# sort collection list by `order'
-sub by_collection_order {
- $collection_info{$a}->{'order'} <=> $collection_info{$b}->{'order'};
-}
# }}}
# {{{ Exit handler.
diff --git a/lib/Lintian/Command.pm b/lib/Lintian/Command.pm
index 05fb3ad..84d695d 100644
--- a/lib/Lintian/Command.pm
+++ b/lib/Lintian/Command.pm
@@ -310,6 +310,29 @@ sub kill {
return $status;
}
+=head2 C<done($opts)>
+
+Check if a process and its childs are done. This is useful when one wants to
+know whether reap() can be called without blocking waiting for the process.
+It takes a single hash reference as returned by spawn.
+
+=cut
+
+sub done {
+ my $opts = shift;
+
+ eval { $opts->{'harness'}->pump_nb; };
+
+ return 0 unless($@);
+
+ if ($@ =~ m/process ended prematurely/) {
+ return 1;
+ } else {
+ require Util;
+ Util::fail("Unknown failure when trying to pump_nb: $@");
+ }
+}
+
1;
__END__
diff --git a/lib/Lintian/DepMap.pm b/lib/Lintian/DepMap.pm
new file mode 100644
index 0000000..6ab2aff
--- /dev/null
+++ b/lib/Lintian/DepMap.pm
@@ -0,0 +1,534 @@
+# 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::DepMap;
+
+use strict;
+use warnings;
+use Util ();
+
+my ($nodes, $selected, $known, $unknown, $map);
+my ($satisfied_nodes);
+
+=head1 NAME
+
+Lintian::DepMap - Dependencies map/tree creator
+
+=head1 SYNOPSIS
+
+ use Lintian::DepMap;
+
+ my $map = Lintian::DepMap->new();
+
+ # know about A:
+ $map->add('A');
+ # B depends on A:
+ $map->add('B', 'A');
+
+ # prints 'A':
+ print $map->selectable();
+
+ # indicate we are working on 'A' (optional):
+ $map->select('A');
+ # do 'A' ... work work work
+
+ # we are done with A:
+ $map->satisfy('A');
+ # prints 'B':
+ print $map->selectable();
+
+
+=head1 DESCRIPTION
+
+Lintian::DepMap is a simple dependencies map/tree creator and "resolver".
+It works by creating a tree based on the indicated dependencies and destroying
+it to resolve it.
+
+
+Note: in the below documentation a C<node> means a node name; no internal
+reference is ever returned and therefore never accepted as a parameter.
+
+=over 4
+
+=item new()
+
+Creates a new Lintian::DepMap object and returns a reference to it.
+
+=cut
+
+sub new {
+ my ($class, $pkg) = @_;
+ my $self = {};
+ bless($self, $class);
+ return $self;
+}
+
+=item initialise()
+
+Ensure, by reconstructing if necessary, the map's status is the initial.
+That is, partially or fully resolved maps can be restored to its original
+state by calling this method.
+
+This can be useful when the same map will be used multiple times.
+
+E.g.
+
+ $map->add('A');
+ $map->satisfy('A');
+ # prints nothing
+ print $map->selectable();
+ $map->initialise();
+ print $map->selectable();
+
+=cut
+#'
+sub initialise {
+ my $self = shift;
+
+ delete $self->{'selected'};
+
+ while (my ($parent, $childs) = each %{$self->{'satisfied_nodes'}}) {
+ if (@{$childs}) {
+ for my $child (@{$childs}) {
+ $self->add($child, $parent);
+ }
+ }
+ $self->add($parent);
+ }
+ delete $self->{'satisfied_nodes'};
+
+ return 1;
+}
+
+=item add(node[, dependency[, dependency[, ...]]])
+
+Adds the given C<node> to the map marking any second or more parameter as its
+dependencies. E.g.
+
+ # A has no dependency:
+ $map->add('A');
+ # B depends on A:
+ $map->add('B', 'A');
+
+=cut
+
+sub add {
+ my $self = shift;
+ my ($node, @parents) = @_;
+ my $parents = 0;
+
+ if (exists($self->{'unknown'}{$node}) && defined($self->{'unknown'}{$node})) {
+ $self->{'known'}{$node} = $self->{'unknown'}{$node};
+ delete $self->{'unknown'}{$node};
+ }
+ $self->{'known'}{$node}++;
+
+ $self->{'nodes'}{$node}->{'branches'} = {}
+ unless(exists($self->{'nodes'}{$node}->{'branches'}));
+ $self->{'nodes'}{$node}->{'parents'} = {}
+ unless(exists($self->{'nodes'}{$node}->{'parents'}));
+
+ while (my $parent = pop @parents) {
+ $parents = 1;
+
+ if (exists($self->{'known'}{$parent})) {
+ $self->{'known'}{$parent}++;
+ } else {
+ $self->{'unknown'}{$parent}++;
+ }
+
+ $self->{'nodes'}{$parent}->{'branches'}->{$node} = $self->{'nodes'}{$node};
+ $self->{'nodes'}{$node}->{'parents'}->{$parent} = $self->{'nodes'}{$parent};
+ }
+ unless ($parents || scalar %{$self->{'nodes'}{$node}->{'parents'}}) {
+ $self->{'map'}{$node} = $self->{'nodes'}{$node};
+ } elsif (exists $self->{'map'}{$node}) {
+ delete $self->{'map'}{$node};
+ } else { 1; }
+}
+
+=item satisfy(node)
+
+Indicates that the given C<node> has been satisfied/done.
+
+The given C<node> is no longer marked as being selected, if it was;
+all of its branches that have no other parent are now selectable()
+and all the references to C<node> are deleted except the one from
+the known() list.
+
+E.g.
+
+ # A has no dependencies:
+ $map->add('A');
+ # B depends on A:
+ $map->add('B', 'A');
+ # we work on A, and we are done:
+ $map->satisfy('A');
+ # B is now available:
+ $map->selectable('B');
+
+B<Note>: shall the requested node not exist this method die()s.
+
+=cut
+
+sub satisfy {
+ my $self = shift;
+ my $node = shift;
+
+ if (grep {$_ eq $node} $self->missing()) {
+ Util::fail("Attempted to mark node '$node' as satisfied but it is not ".
+ "reachable, perhaps you forgot to add() it first?");
+ }
+ if (not exists($self->{'nodes'}{$node})) {
+ Util::fail("Attempted to mark node '$node' as satisfied but it is not ".
+ "reachable, perhaps you forgot to satisfy() its dependencies first?");
+ }
+ return 0 unless (exists($self->{'map'}{$node}));
+
+ delete $self->{'selected'}{$node}
+ if exists($self->{'selected'}{$node});
+
+ $self->{'satisfied_nodes'}{$node} = [ keys %{$self->{'nodes'}{$node}{'branches'}} ];
+
+ for my $branch (keys %{$self->{'nodes'}{$node}->{'branches'}}) {
+ delete $self->{'nodes'}{$branch}->{'parents'}->{$node};
+ delete $self->{'nodes'}{$node}->{'branches'}->{$branch};
+ unless (scalar keys %{$self->{'nodes'}{$branch}->{'parents'}}) {
+ $self->{'map'}{$branch} = $self->{'nodes'}{$branch};
+ }
+ }
+
+ delete $self->{'map'}{$node};
+ delete $self->{'nodes'}{$node};
+}
+
+=item unlink(node[, 'soft'])
+
+Removes all references to the given C<node> except for the entry in the
+known() table.
+
+B<IMPORTANT>: since all references are deleted it is possible that a node
+that depended on C<node> may become available even when it was not expected
+to. To avoid this behaviour, the C<soft> option can be passed, which
+will make its branches unreachable.
+
+B<IMPORTANT>: this operation can B<not> be reversed by the means of
+initialise(). Re-adding a 'soft'ly removed node does not correct the
+references of the branches of the old node to the new node.
+
+E.g.
+
+ $map->add('A');
+ # Prints A
+ print $map->selectable();
+ # we later notice we don't want A
+ $map->unlink('A');
+ # Prints nothing
+ print $map->selectable();
+
+B<Note>: shall the requested node not exist this method die()s.
+
+=cut
+
+sub unlink {
+ my $self = shift;
+ my $node = shift;
+ my $soft = shift;
+
+ $soft = (defined($soft) && $soft eq 'soft');
+
+ if (not exists($self->{'nodes'}{$node})) {
+ Util::fail("Attempted to unlink node '$node' but it can not be found".
+ ", perhaps it has already been satisfied?");
+ }
+
+ delete $self->{'map'}{$node}
+ if (exists($self->{'map'}{$node}));
+
+ delete $self->{'selected'}{$node}
+ if (exists($self->{'selected'}{$node}));
+
+ unless ($soft) {
+ for my $parent (keys %{$self->{'nodes'}{$node}->{'parents'}}) {
+ delete $self->{'nodes'}{$parent}{'branches'}{$node}
+ if exists $self->{'nodes'}{$parent}{'branches'}{$node};
+ delete $self->{'nodes'}{$node}{'parents'}{$parent};
+ }
+
+ for my $branch (keys %{$self->{'nodes'}{$node}->{'branches'}}) {
+ delete $self->{'nodes'}{$branch}{'parents'}{$node};
+ delete $self->{'nodes'}{$node}{'branches'}{$branch};
+ }
+ }
+
+ delete $self->{'nodes'}{$node};
+
+ return 1;
+}
+
+=item select(node)
+
+Marks the given C<node> as selected to indicate that whatever it represents
+is being worked on. Note: this operation is not atomic.
+
+E.g.
+
+ $map->add('A');
+ $map->add('B', 'A');
+ while($map->pending()) {
+ for my $node ($map->selectable()) {
+ $map->select($node);
+ # work work work
+ $map->satisfy($node);
+ }
+ }
+
+=cut
+
+sub select {
+ my $self = shift;
+ my $node = shift;
+
+ if (not exists($self->{'map'}{$node})) {
+ Util::fail("Attempted to mark node '$node' as selected but it is not ".
+ "known, perhaps its parents are not yet satisfied?");
+ }
+ return 0 if (exists($self->{'selected'}{$node}));
+
+ $self->{'selected'}{$node} = $self->{'nodes'}{$node};
+
+ return 1;
+}
+
+=item selectable([node])
+
+If a C<node> is specified returns TRUE if it can be select()ed.
+
+B<Note>: already select()ed nodes can not be re-selected,
+i.e. if the given C<node> has already been selected this function will
+return FALSE; or any selected item will be omitted from the returned array,
+in case no C<node> is specified.
+
+=cut
+
+sub selectable {
+ my $self = shift;
+ my $node = shift;
+
+ return (exists $self->{'map'}{$node} and not exists $self->{'selected'}{$node})
+ if (defined($node));
+ return grep {not exists $self->{'selected'}{$_}} keys %{$self->{'map'}};
+}
+
+=item selected([node])
+
+If a C<node> is specified returns TRUE if it is has been selected,
+FALSE otherwise.
+
+If no C<node> is specified it returns an array with the name of all the
+nodes that have been select()ed but not yet satisfied.
+
+E.g.
+
+ # We are going to work on A
+ $map->select('A');
+ # Returns true
+ $map->selected('A');
+ # Prints A
+ print $map->selected();
+
+=cut
+
+sub selected {
+ my $self = shift;
+ my $node = shift;
+
+ return exists $self->{'selected'}{$node}
+ if (defined($node));
+ return keys %{$self->{'selected'}};
+}
+
+=item selectAll()
+
+select()s all the selectable() nodes.
+
+=cut
+
+sub selectAll {
+ my $self = shift;
+
+ for my $node ($self->selectable()) {
+ $self->select($node);
+ }
+}
+
+=item parents(node)
+
+Return an array with the name of the parent nodes for the given C<node>.
+
+E.g.
+
+ $map->add('A');
+ $map->add('B', 'A');
+ # Prints 'A'
+ print $map->parents('B');
+
+B<Note>: shall the requested node not exist this method die()s.
+
+=cut
+
+sub parents {
+ my $self = shift;
+ my $node = shift;
+
+ if (not exists($self->{'nodes'}{$node})) {
+ Util::fail("Attempted to get the parents of node '$node' but it is not".
+ "known, perhaps you forgot to add() it first?");
+ }
+
+ return keys %{$self->{'nodes'}{$node}{'parents'}};
+}
+
+=item pending()
+
+Return the number of nodes that can or have already been selected. E.g.
+
+ $map->add('B', 'A');
+ # prints 1:
+ print $map->pending();
+ $map->select('A');
+ # prints 1:
+ print $map->pending();
+ $map->satisfy('A');
+ # prints 1 ('B' is now available):
+ print $map->pending();
+
+=cut
+
+sub pending {
+ my $self = shift;
+
+ return (scalar keys %{$self->{'map'}});
+}
+
+=item known()
+
+Return an array containing the names of nodes that were added. E.g.
+
+ $map->add('B', 'A');
+ # prints 'B':
+ print $map->known();
+ $map->add('A');
+ # prints 'A' and 'B':
+ print $map->known();
+
+=cut
+
+sub known {
+ my $self = shift;
+
+ return keys %{$self->{'known'}};
+}
+
+=item missing()
+
+Return an array containing the names of nodes that were not added but that
+another node depended on it. E.g.
+
+ $map->add('B', 'A');
+ # prints 'A':
+ print $map->missing();
+ $map->add('A');
+ # prints nothing:
+ print $map->missing();
+ # this also works; A depends on 'Z':
+ $map->add('A', 'Z');
+ # but now this prints 'Z':
+ print $map->missing();
+
+=cut
+
+sub missing {
+ my $self = shift;
+
+ return keys %{$self->{'unknown'}};
+}
+
+=item circular(['deep'])
+
+Returns an array of nodes that have a circular dependency.
+
+E.g.
+
+ $map->add('A', 'B');
+ $map->add('B', 'A');
+ # Prints A and B
+ print $map->circular();
+
+B<Note>: since recursive/deep circular dependencies detection is a bit
+more resource expensive it is not the default.
+
+ $map->add('A', 'B');
+ $map->add('B', 'C');
+ $map->add('C', 'A');
+ # No deep/recursive scanning is performed, prints nothing
+ print $map->circular();
+ # deep scan, prints 'A, B, C'
+ print $map->circular('deep');
+
+=cut
+
+sub circular {
+ my $self = shift;
+ my $deep = shift;
+ my @circ;
+
+ $deep = (defined($deep) && $deep eq 'deep');
+
+ if ($deep) {
+ my @nodes;
+ my ($prev_satisfied, $prev_selected) = ($self->{'satisfied_nodes'}, $self->{'selected'});
+ while(@nodes = $self->selectable()) {
+ for my $node (@nodes) {
+ $self->satisfy($node);
+ }
+ }
+ # there should be no nodes left:
+ @circ = keys %{$self->{'nodes'}};
+
+ $self->{'satisfied_nodes'} = $prev_satisfied;
+ $self->{'selected'} = $prev_selected;
+ $self->initialise();
+ } else {
+ for my $node (keys %{$self->{'nodes'}}) {
+ push @circ, grep $self->{'nodes'}{$node}->{'parents'}->{$_},
+ keys %{$self->{'nodes'}{$node}->{'branches'}};
+ }
+ }
+
+ return @circ;
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Raphael Geissert <atomo64@gmail.com> for Lintian.
+
+=cut
diff --git a/t/scripts/Lintian/DepMap/01add-select-satisfy.t b/t/scripts/Lintian/DepMap/01add-select-satisfy.t
new file mode 100644
index 0000000..0508632
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/01add-select-satisfy.t
@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 24;
+
+BEGIN { use_ok('Lintian::DepMap'); }
+
+my $map;
+
+ok(eval { $map = Lintian::DepMap->new(); }, 'Create');
+
+is_deeply([ $map->selectable() ], [], 'Empty, nothing is selectable');
+is_deeply([ $map->selected() ], [], 'Empty, nothing has been selected');
+ok($map->pending() eq 0, 'Empty, nothing is pending');
+is_deeply([ $map->known() ], [], 'Empty, nothing is known');
+is_deeply([ $map->missing() ], [], 'Empty, nothing is missing');
+
+ok(eval { $map->add('A'); }, 'Add A');
+is_deeply([ $map->selectable() ], ['A'], 'A is selectable');
+ok($map->pending() eq 1, 'A is pending');
+is_deeply([ $map->known() ], ['A'], 'A added, it is known');
+is_deeply([ $map->missing() ], [], 'A added, it is not missing');
+
+ok(eval { $map->select('A'); }, 'Select A');
+is_deeply([ $map->selectable() ], [], 'A selected, nothing is selectable');
+ok($map->selected('A'), 'A selected, A has been selected');
+ok($map->pending() eq 1, 'A selected, A is still pending');
+is_deeply([ $map->known() ], ['A'], 'A selected, it is known');
+is_deeply([ $map->missing() ], [], 'A selected, nothing is missing');
+
+ok(eval { $map->satisfy('A'); }, 'Satisfy A');
+is_deeply([ $map->selectable() ], [], 'A satisfied, nothing is selectable');
+is_deeply([ $map->selected() ], [], 'A satisfied, nothing is selected');
+ok($map->pending() eq 0, 'A satisfied, nothing is pending');
+is_deeply([ $map->known() ], ['A'], 'A satisfied, it is known');
+is_deeply([ $map->missing() ], [], 'A satisfied, nothing is missing');
diff --git a/t/scripts/Lintian/DepMap/03pending.t b/t/scripts/Lintian/DepMap/03pending.t
new file mode 100644
index 0000000..65e7e14
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/03pending.t
@@ -0,0 +1,24 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+use Test::More tests => 5;
+
+use Lintian::DepMap;
+
+my $map = Lintian::DepMap->new();
+
+$map->add('A');
+is($map->pending(), 1, 'A added, one pending');
+
+$map->add('B');
+is($map->pending(), 2, 'B added, two pending');
+
+$map->select('A');
+is($map->pending(), 2, 'A selected, two pending');
+
+$map->satisfy('B');
+is($map->pending(), 1, 'B satisfied, one pending');
+
+$map->satisfy('A');
+is($map->pending(), 0, 'A satisfied, zero pending');
diff --git a/t/scripts/Lintian/DepMap/04satisfiability.t b/t/scripts/Lintian/DepMap/04satisfiability.t
new file mode 100644
index 0000000..5fe70c7
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/04satisfiability.t
@@ -0,0 +1,18 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 4;
+
+use Lintian::DepMap;
+
+my $obj = Lintian::DepMap->new();
+
+ok($obj->add('A', 'B'), "Nodes can be added in any order");
+
+eval {$obj->satisfy('Z')};
+isnt($@, '', "Nodes that were not added can not be satisfied");
+
+eval {$obj->satisfy('B')};
+isnt($@, '', "Nodes that were not added and are missing() can not be satisfied");
+
+ok(!$obj->satisfy('A'), "Nodes can not be satisfied if they still have dependencies");
diff --git a/t/scripts/Lintian/DepMap/05multi-add.t b/t/scripts/Lintian/DepMap/05multi-add.t
new file mode 100644
index 0000000..07287ce
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/05multi-add.t
@@ -0,0 +1,27 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+use Test::More tests => 4;
+
+use Lintian::DepMap;
+
+my $map = Lintian::DepMap->new();
+
+$map->add('A');
+$map->add('B');
+$map->add('C');
+$map->add('D');
+$map->add('D', 'A');
+$map->add('D', 'B', 'C');
+
+is_deeply([$map->selectable()], ['A', 'C', 'B'], 'D has dependencies, not selectable');
+
+$map->satisfy('A');
+is_deeply([$map->selectable()], ['C', 'B'], 'A satisfied, B and C selectable');
+
+$map->satisfy('B');
+is_deeply([$map->selectable()], ['C'], 'B satisfied, C selectable');
+
+$map->satisfy('C');
+is_deeply([$map->selectable()], ['D'], 'C satisfied, D now selectable');
diff --git a/t/scripts/Lintian/DepMap/06parents.t b/t/scripts/Lintian/DepMap/06parents.t
new file mode 100644
index 0000000..7f4c962
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/06parents.t
@@ -0,0 +1,16 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+use Test::More tests => 2;
+
+use Lintian::DepMap;
+
+my $map = Lintian::DepMap->new();
+
+$map->add('A');
+$map->add('B', 'A');
+
+my @parents;
+ok(eval {@parents = $map->parents('B'); }, "Get B's parents");
+is_deeply(\@parents, ['A'], "B's parent is A");
diff --git a/t/scripts/Lintian/DepMap/08initialise.t b/t/scripts/Lintian/DepMap/08initialise.t
new file mode 100644
index 0000000..36221e6
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/08initialise.t
@@ -0,0 +1,38 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 7;
+
+use Lintian::DepMap;
+
+my $obj = Lintian::DepMap->new();
+
+ok($obj->initialise(), "Map can be initialised");
+
+$obj->add('A');
+$obj->select('A');
+$obj->initialise();
+is(join(', ', $obj->selectable()), 'A',
+ "A is selectable once again after being selected");
+
+$obj->satisfy('A');
+$obj->initialise();
+is(join(', ', $obj->selectable()), 'A',
+ "A is selectable once again after being satisfied");
+
+$obj->add('B');
+$obj->satisfy('B');
+$obj->initialise();
+is(join(', ', $obj->selectable()), 'A, B',
+ "A and B are selectable once again after being satisfied");
+
+$obj->add('B', 'A');
+$obj->satisfy('A');
+$obj->initialise();
+is(join(', ', $obj->parents('B')), 'A',
+ "A is parent of B");
+
+$obj->add('Z', 'X');
+$obj->initialise();
+is(join(', ', $obj->missing()), 'X', "X is unknown");
+is(join(', ', sort($obj->known())), 'A, B, Z', "X is not known");
diff --git a/t/scripts/Lintian/DepMap/08initialise2.t b/t/scripts/Lintian/DepMap/08initialise2.t
new file mode 100644
index 0000000..be1caba
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/08initialise2.t
@@ -0,0 +1,21 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 2;
+
+use Lintian::DepMap;
+
+my $obj = Lintian::DepMap->new();
+
+$obj->initialise();
+
+$obj->add('A');
+$obj->add('B', 'A');
+$obj->satisfy('A');
+$obj->initialise();
+is(join(', ', $obj->selectable()), 'A',
+ "Only A is selectable after reinitialising");
+
+$obj->satisfy('A');
+is(join(', ', $obj->selectable()), 'B',
+ "B is selectable after A has been satisfied");
diff --git a/t/scripts/Lintian/DepMap/09unlink.t b/t/scripts/Lintian/DepMap/09unlink.t
new file mode 100644
index 0000000..68eacda
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/09unlink.t
@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 15;
+
+use Lintian::DepMap;
+
+my $map;
+
+$map = Lintian::DepMap->new();
+
+$map->add('A');
+ok(eval {$map->unlink('A')}, 'Unlink A');
+is_deeply([$map->selectable()], [], 'A unlinked, not selectable');
+is($map->pending(), 0, 'A unlinked, nothing pending');
+
+$map->add('B', 'A');
+is_deeply([$map->selectable()], [], 'A unlinked, B added but not selectable');
+is($map->pending(), 0, 'A unlinked, B added but not pending');
+
+$map->add('A');
+is_deeply([$map->selectable()], ['A'], 'A re-added, selectable');
+is($map->pending(), 1, 'A re-added, pending');
+
+$map->satisfy('A');
+is_deeply([$map->selectable()], ['B'], 'A satisfied, B is now selectable');
+
+# re-add A for the following tests
+$map->add('A');
+
+ok(eval {$map->unlink('B')}, 'Unlink B');
+is_deeply([$map->selectable()], ['A'], 'B unlinked, A selectable');
+is($map->pending(), 1, 'B unlinked, pending');
+
+$map->satisfy('A');
+is_deeply([$map->selectable()], [], 'A satisfied, nothing selectable');
+is($map->pending(), 0, 'A satisfied, nothing pending');
+
+$map->add('A', 'B');
+$map->add('B');
+
+$map->unlink('B', 'soft');
+ok(!$map->satisfy('A'), "A can't be satisfied because it depends on the soft-unlinked B");
+
+TODO: {
+ local $TODO = 'When re-adding B there are still references to the old B, and old $B != new $B';
+ $map->add('B');
+ $map->satisfy('B');
+ ok(eval {$map->satisfy('A')}, "B re-added, A can be satisfied");
+}
diff --git a/t/scripts/Lintian/DepMap/10circular.t b/t/scripts/Lintian/DepMap/10circular.t
new file mode 100644
index 0000000..68a3591
--- /dev/null
+++ b/t/scripts/Lintian/DepMap/10circular.t
@@ -0,0 +1,36 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+use Test::More tests => 5;
+
+use Lintian::DepMap;
+
+my $map = Lintian::DepMap->new();
+
+$map->add('A', 'B');
+$map->add('B', 'A');
+
+is(join(', ', sort($map->circular())), 'A, B', 'A and B cause a circular dependency');
+
+$map->add('C');
+
+is(join(', ', sort($map->circular())), 'A, B', 'A and B cause a circular dependency (2nd)');
+
+$map = Lintian::DepMap->new();
+$map->add('A', 'B');
+$map->add('B', 'C');
+$map->add('C', 'A');
+
+is(join(', ', sort($map->circular('deep'))), 'A, B, C', 'A, B and C cause a deep circular dependency');
+
+TODO: {
+ local $TODO = 'When C is unlinked, A and B are not reconsidered to be added to {"map"}';
+
+ # We break the circular dependency:
+ $map->unlink('C');
+ is(join(', ', $map->circular('deep')), '', 'Deep circular dependency is now broken (w/o C)');
+
+ $map->add('C');
+ is(join(', ', $map->circular('deep')), '', 'C re-added, circular dependency still broken');
+}
\ No newline at end of file
--
Debian package checker
Reply to: