The following commit has been merged in the master branch: commit e951eccb1fa34405b3a3ae2b022669b0cf835a8c Author: Raphael Geissert <atom...@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 <atom...@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 <atom...@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 -- To UNSUBSCRIBE, email to debian-lint-maint-requ...@lists.debian.org with a subject of "unsubscribe". Trouble? Contact listmas...@lists.debian.org Archive: http://lists.debian.org/e1nuwqq-0001fa...@alioth.debian.org