diff options
Diffstat (limited to 'lib/Lintian/Pool.pm')
| -rw-r--r-- | lib/Lintian/Pool.pm | 412 |
1 files changed, 412 insertions, 0 deletions
diff --git a/lib/Lintian/Pool.pm b/lib/Lintian/Pool.pm new file mode 100644 index 0000000..db153f9 --- /dev/null +++ b/lib/Lintian/Pool.pm @@ -0,0 +1,412 @@ +# 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) { + + ++$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 |