summaryrefslogtreecommitdiffstats
path: root/lib/Lintian/Pool.pm
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-14 13:42:30 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-14 13:42:30 +0000
commit75808db17caf8b960b351e3408e74142f4c85aac (patch)
tree7989e9c09a4240248bf4658a22208a0a52d991c4 /lib/Lintian/Pool.pm
parentInitial commit. (diff)
downloadlintian-75808db17caf8b960b351e3408e74142f4c85aac.tar.xz
lintian-75808db17caf8b960b351e3408e74142f4c85aac.zip
Adding upstream version 2.117.0.upstream/2.117.0upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'lib/Lintian/Pool.pm')
-rw-r--r--lib/Lintian/Pool.pm412
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