[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index] [Thread Index]

[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: