openkylin
/
lintian
mirror of https://gitee.com/openkylin/lintian.git
9
0
Fork 0
Code Issues Projects Releases Wiki Activity
lintian/lib/Lintian/Pool.pm

414 lines
10 KiB
Perl
Raw Blame History

# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
# Copyright (C) 2020-2021 Felix Lechner
#
# 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, you can find it on the World Wide
# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
## Represents a pool of processables (Lintian::Processable)
package Lintian::Pool;
use v5.20;
use warnings;
use utf8;
use Const::Fast;
use Cwd qw(getcwd);
use List::SomeUtils qw(any);
use Time::HiRes qw(gettimeofday tv_interval);
use Path::Tiny;
use POSIX qw(:sys_wait_h);
use Proc::ProcessTable;
use Unicode::UTF8 qw(encode_utf8);
use Lintian::Group;
const my $SPACE => q{ };
const my $COMMA => q{,};
const my $SEMICOLON => q{;};
const my $LEFT_PARENS => q{(};
const my $RIGHT_PARENS => q{)};
const my $PLURAL_S => q{s};
const my $ANY_CHILD => -1;
const my $WORLD_WRITABLE_FOLDER => oct(777);
use Moo;
use namespace::clean;
=head1 NAME
Lintian::Pool -- Pool of processables
=head1 SYNOPSIS
use Lintian::Pool;
my $pool = Lintian::Pool->new;
$pool->add_file('foo.changes');
$pool->add_file('bar.dsc');
$pool->add_file('baz.deb');
$pool->add_file('qux.buildinfo');
foreach my $gname ($pool->get_group_names){
my $group = $pool->get_group($gname);
process($gname, $group);
}
=head1 METHODS
=over 4
=item $pool->groups
Returns a hash reference to the list of processable groups that are currently
in the pool. The key is a unique identifier based on name and version.
=item C<savedir>
=cut
has groups => (is => 'rw', default => sub{ {} });
has savedir => (is => 'rw', default => sub{ getcwd; });
# must be absolute; frontend/lintian depends on it
has basedir => (
is => 'rw',
default => sub {
my $absolute
= Path::Tiny->tempdir(TEMPLATE => 'lintian-pool-XXXXXXXXXX');
$absolute->mkpath({mode => $WORLD_WRITABLE_FOLDER});
return $absolute;
}
);
=item $pool->basedir
Returns the base directory for the pool. Most likely it's a temporary directory.
=item $pool->add_group($group)
Adds a group to the pool.
=cut
sub add_group {
my ($self, $group) = @_;
my $name = $group->name;
unless (exists $self->groups->{$name}){
# group does not exist; just add whole
$self->groups->{$name} = $group;
return 1;
}
# group exists; merge & accept all new
my $added = 0;
my $old = $self->groups->{$name};
for my $type (qw/source buildinfo changes/) {
if (!defined $old->$type && defined $group->$type) {
$old->add_processable($group->$type);
$added = 1;
}
}
for my $installable ($group->get_installables){
# New binary package ?
my $was_new = $old->add_processable($installable);
$added ||= $was_new;
}
return $added;
}
=item $pool->process
Process the pool.
=cut
sub process{
my ($self, $PROFILE, $exit_code_ref, $option)= @_;
if ($self->empty) {
say {*STDERR} encode_utf8('No packages selected.');
return;
}
my %reported_count;
my %override_count;
my %ignored_overrides;
my $unused_overrides = 0;
for my $group (values %{$self->groups}) {
my $total_start = [gettimeofday];
$group->profile($PROFILE);
$group->jobs($option->{'jobs'});
my $success= $group->process(\%ignored_overrides, $option);
for my $processable ($group->get_processables){
my @keep;
for my $hint (@{$processable->hints}) {
my $tag = $PROFILE->get_tag($hint->tag_name);
# discard experimental tags
next
if $tag->experimental
&& !$option->{'display-experimental'};
# discard overridden tags
next
if defined $hint->override
&& !$option->{'show-overrides'};
# discard outside the selected display level
next
unless $PROFILE->display_level_for_tag($hint->tag_name);
if (!defined $hint->override
|| $option->{'show-overrides'}) {
++$reported_count{$tag->visibility}
if !$tag->experimental;
++$reported_count{experimental}
if $tag->experimental;
}
++$reported_count{override}
if defined $hint->override;
++$unused_overrides
if $hint->tag_name eq 'unused-override'
|| $hint->tag_name eq 'mismatched-override';
push(@keep, $hint);
}
$processable->hints(\@keep);
}
${$exit_code_ref} = 2
if $success && any { $reported_count{$_} } @{$option->{'fail-on'}};
# interruptions can leave processes behind (manpages); wait and reap
if (${$exit_code_ref} == 1) {
1 while waitpid($ANY_CHILD, WNOHANG) > 0;
}
if ($option->{debug}) {
my $process_table = Proc::ProcessTable->new;
my @leftover= grep { $_->ppid == $$ } @{$process_table->table};
# announce left over processes, see commit 3bbcc3b
if (@leftover) {
warn encode_utf8(
"\nSome processes were left over (maybe unreaped):\n");
my $FORMAT = ' %-12s %-12s %-8s %-24s %s';
say encode_utf8(
sprintf(
$FORMAT,'PID', 'TTY', 'STATUS', 'START', 'COMMAND'
)
);
say encode_utf8(
sprintf($FORMAT,
$_->pid,$_->ttydev,
$_->state,scalar(localtime($_->start)),
$_->cmndline)
)for @leftover;
${$exit_code_ref} = 1;
die encode_utf8("Aborting.\n");
}
}
my $total_raw_res = tv_interval($total_start);
my $total_tres = sprintf('%.3fs', $total_raw_res);
my $status = $success ? 'complete' : 'error';
say {*STDERR}
encode_utf8($status . $SPACE . $group->name . " ($total_tres)")
if $option->{'status-log'};
say {*STDERR} encode_utf8('Finished processing group ' . $group->name)
if $option->{debug};
${$exit_code_ref} = 1
unless $success;
}
my $OUTPUT;
if ($option->{'output-format'} eq 'html') {
require Lintian::Output::HTML;
$OUTPUT = Lintian::Output::HTML->new;
} elsif ($option->{'output-format'} eq 'json') {
require Lintian::Output::JSON;
$OUTPUT = Lintian::Output::JSON->new;
} elsif ($option->{'output-format'} eq 'universal') {
require Lintian::Output::Universal;
$OUTPUT = Lintian::Output::Universal->new;
} else {
require Lintian::Output::EWI;
$OUTPUT = Lintian::Output::EWI->new;
}
# pass everything, in case some groups or processables have no hints
$OUTPUT->issue_hints($PROFILE, [values %{$self->groups}], $option);
my $errors = $override_count{error} // 0;
my $warnings = $override_count{warning} // 0;
my $info = $override_count{info} // 0;
my $total = $errors + $warnings + $info;
if ( $option->{'output-format'} eq 'ewi'
&& !$option->{'no-override'}
&& !$option->{'show-overrides'}
&& ($total > 0 || $unused_overrides > 0)) {
my @details;
push(@details, quantity($errors, 'error'))
if $errors;
push(@details, quantity($warnings, 'warning'))
if $warnings;
push(@details, "$info info")
if $info;
my $text = quantity($total, 'hint') . ' overridden';
$text
.= $SPACE
. $LEFT_PARENS
. join($COMMA . $SPACE, @details)
. $RIGHT_PARENS
if @details;
$text
.= $SEMICOLON
. $SPACE
. quantity($unused_overrides, 'unused override');
say encode_utf8("N: $text");
}
if ($option->{'output-format'} eq 'ewi' && %ignored_overrides) {
say encode_utf8('N: Some overrides were ignored.');
if ($option->{verbose}) {
say encode_utf8(
'N: The following tags had at least one override but are mandatory:'
);
say encode_utf8("N: - $_") for sort keys %ignored_overrides;
} else {
say encode_utf8('N: Use --verbose for more information.');
}
}
path($self->basedir)->remove_tree
if length $self->basedir && -d $self->basedir;
return;
}
=item quantity
=cut
sub quantity {
my ($count, $unit) = @_;
my $text = $count . $SPACE . $unit;
$text .= $PLURAL_S
unless $count == 1;
return $text;
}
=item $pool->get_group_names
Returns the name of all the groups in this pool.
Do not modify the list nor its contents.
=cut
sub get_group_names{
my ($self) = @_;
return keys %{ $self->groups };
}
=item $pool->get_group($name)
Returns the group called $name or C<undef>
if there is no group called $name.
=cut
sub get_group{
my ($self, $group) = @_;
return $self->groups->{$group};
}
=item $pool->empty
Returns true if the pool is empty.
=cut
sub empty{
my ($self) = @_;
return scalar keys %{$self->groups} == 0;
}
=back
=head1 AUTHOR
Originally written by Niels Thykier <niels@thykier.net> for Lintian.
=head1 SEE ALSO
lintian(1)
L<Lintian::Processable>
L<Lintian::Group>
=cut
1;
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
Reference in New Issue View Git Blame Copy Permalink