Adding upstream version 2.117.0.upstream/2.117.0upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 794 insertions, 0 deletions

diff --git a/lib/Lintian/Group.pm b/lib/Lintian/Group.pm
new file mode 100644
index 0000000..010f42e
--- /dev/null
+++ b/lib/Lintian/Group.pm
@@ -0,0 +1,794 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+# Copyright (C) 2019-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.
+
+package Lintian::Group;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use Cwd;
+use Devel::Size qw(total_size);
+use Email::Address::XS;
+use File::Spec;
+use List::Compare;
+use List::SomeUtils qw(any none uniq firstval true);
+use List::UtilsBy qw(sort_by);
+use POSIX qw(ENOENT);
+use Syntax::Keyword::Try;
+use Time::HiRes qw(gettimeofday tv_interval);
+use Time::Piece;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Hint::Pointed;
+use Lintian::Mask;
+use Lintian::Util qw(human_bytes match_glob);
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $UNDERSCORE => q{_};
+
+const my $EXTRA_VERBOSE => 3;
+
+# A private table of supported types.
+const my %SUPPORTED_TYPES => (
+    'binary'  => 1,
+    'buildinfo' => 1,
+    'changes' => 1,
+    'source'  => 1,
+    'udeb'    => 1,
+);
+
+use Moo;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Group -- A group of objects that Lintian can process
+
+=head1 SYNOPSIS
+
+ use Lintian::Group;
+
+ my $group = Lintian::Group->new('lintian_2.5.0_i386.changes');
+
+=head1 DESCRIPTION
+
+Instances of this perl class are sets of
+L<processables|Lintian::Processable>.  It allows at most one source
+and one changes or buildinfo package per set, but multiple binary packages
+(provided that the binary is not already in the set).
+
+=head1 METHODS
+
+=over 4
+
+=item $group->pooldir
+
+Returns or sets the pool directory used by this group.
+
+=item $group->source_name
+
+=item $group->source_version
+
+=item $group->binary
+
+Returns a hash reference to the binary processables in this group.
+
+=item $group->buildinfo
+
+Returns the buildinfo processable in this group.
+
+=item $group->changes
+
+Returns the changes processable in this group.
+
+=item $group->source
+
+Returns the source processable in this group.
+
+=item $group->udeb
+
+Returns a hash reference to the udeb processables in this group.
+
+=item jobs
+
+Returns or sets the max number of jobs to be processed in parallel.
+
+If the limit is 0, then there is no limit for the number of parallel
+jobs.
+
+=item processing_start
+
+=item processing_end
+
+=item cache
+
+Cache for some items.
+
+=item profile
+
+Hash with active jobs.
+
+=item C<saved_direct_dependencies>
+
+=item C<saved_direct_reliants>
+
+=cut
+
+has pooldir => (is => 'rw', default => $EMPTY);
+has source_name => (is => 'rw', default => $EMPTY);
+has source_version => (is => 'rw', default => $EMPTY);
+
+has binary => (is => 'rw', default => sub{ {} });
+has buildinfo => (is => 'rw');
+has changes => (is => 'rw');
+has source => (is => 'rw');
+has udeb => (is => 'rw', default => sub{ {} });
+
+has jobs => (is => 'rw', default => 1);
+has processing_start => (is => 'rw', default => $EMPTY);
+has processing_end => (is => 'rw', default => $EMPTY);
+
+has cache => (is => 'rw', default => sub { {} });
+has profile => (is => 'rw', default => sub { {} });
+
+=item $group->name
+
+Returns a unique identifier for the group based on source and version.
+
+=cut
+
+sub name {
+    my ($self) = @_;
+
+    return $EMPTY
+      unless length $self->source_name && length $self->source_version;
+
+    return $self->source_name . $UNDERSCORE . $self->source_version;
+}
+
+=item process
+
+Process group.
+
+=cut
+
+sub process {
+    my ($self, $ignored_overrides, $option)= @_;
+
+    my $groupname = $self->name;
+    local $SIG{__WARN__}
+      = sub { warn encode_utf8("Warning in group $groupname: $_[0]") };
+
+    my $savedir = getcwd;
+
+    $self->processing_start(gmtime->datetime . 'Z');
+    say {*STDERR} encode_utf8('Starting on group ' . $self->name)
+      if $option->{debug};
+    my $group_timer = [gettimeofday];
+
+    my $success = 1;
+    for my $processable ($self->get_processables){
+
+        my $path = $processable->path;
+        local $SIG{__WARN__}
+          = sub { warn encode_utf8("Warning in processable $path: $_[0]") };
+
+        my @hints;
+        my %enabled_overrides;
+
+        say {*STDERR}
+          encode_utf8(
+            'Base directory for processable: '. $processable->basedir)
+          if $option->{debug};
+
+        unless ($option->{'no-override'}) {
+
+            say {*STDERR} encode_utf8('Loading overrides file (if any) ...')
+              if $option->{debug};
+
+            for my $override (@{$processable->overrides}) {
+
+                my $pattern = $override->pattern;
+
+                # catch renames
+                my $tag_name
+                  = $self->profile->get_current_name($override->tag_name);
+
+                # catches unknown tags
+                next
+                  unless length $tag_name;
+
+                next
+                  unless $self->profile->tag_is_enabled($tag_name);
+
+                my @architectures = @{$override->architectures};
+
+                # count negations
+                my $negations = true { /^!/ } @architectures;
+
+                # strip negations if present
+                s/^!// for @architectures;
+
+                # enable overrides for this architecture
+                # proceed when none specified
+                my $data = $self->profile->data;
+                next
+                  if @architectures
+                  && (
+                    $negations xor none {
+                        $data->architectures->restriction_matches($_,
+                            $processable->architecture)
+                    }@architectures
+                  );
+
+                if ($self->profile->is_durable($tag_name)) {
+
+                    ++$ignored_overrides->{$tag_name};
+                    next;
+                }
+
+                $enabled_overrides{$tag_name}{$pattern} = $override;
+            }
+        }
+
+        my @check_names = sort $self->profile->enabled_checks;
+
+        my @from_checks;
+        for my $name (@check_names) {
+
+            my $absolute = $self->profile->check_path_by_name->{$name};
+            require $absolute;
+
+            my $module = $self->profile->check_module_by_name->{$name};
+            my $check = $module->new;
+
+            $check->name($name);
+            $check->processable($processable);
+            $check->group($self);
+            $check->profile($self->profile);
+
+            my $timer = [gettimeofday];
+            my $procid = $processable->identifier;
+            say {*STDERR} encode_utf8("Running check: $name on $procid  ...")
+              if $option->{debug};
+
+            try {
+                my @found_here = $check->run;
+                push(@from_checks, @found_here);
+
+            } catch {
+                my $message = $@;
+                $message
+                  .= "warning: cannot run $name check on package $procid\n";
+                $message .= "skipping check of $procid\n";
+                warn encode_utf8($message);
+
+                $success = 0;
+
+                next;
+            }
+
+            my $raw_res = tv_interval($timer);
+            my $tres = sprintf('%.3fs', $raw_res);
+
+            say {*STDERR} encode_utf8("Check $name for $procid done ($tres)")
+              if $option->{debug};
+            say {*STDERR} encode_utf8("$procid,check/$name,$raw_res")
+              if $option->{'perf-output'};
+        }
+
+        my %context_tracker;
+        my %used_overrides;
+
+        for my $hint (@from_checks) {
+
+            my $as_issued = $hint->tag_name;
+
+            croak encode_utf8('No tag name')
+              unless length $as_issued;
+
+            my $issuer = $hint->issued_by;
+
+            # try local name space
+            my $tag = $self->profile->get_tag("$issuer/$as_issued");
+
+            warn encode_utf8(
+"Using tag $as_issued as name spaced while not so declared (in check $issuer)."
+            )if defined $tag && !$tag->name_spaced;
+
+            # try global name space
+            $tag ||= $self->profile->get_tag($as_issued);
+
+            unless (defined $tag) {
+                warn encode_utf8(
+                    "Tried to issue unknown tag $as_issued in check $issuer.");
+                next;
+            }
+
+            if (  !$tag->name_spaced && $tag->name ne $as_issued
+                || $tag->name_spaced && $tag->name ne "$issuer/$as_issued") {
+
+                my $current_name = $tag->name;
+                warn encode_utf8(
+"Tried to issue renamed tag $as_issued (current name $current_name) in check $issuer."
+                );
+
+                next;
+            }
+
+            my $owner = $tag->check;
+            if ($issuer ne $owner) {
+                warn encode_utf8(
+                    "Check $issuer has no tag $as_issued (but $owner does).");
+                next;
+            }
+
+            # pull name from tag; could be name-spaced
+            $hint->tag_name($tag->name);
+            my $tag_name = $hint->tag_name;
+
+            # skip disabled tags
+            next
+              unless $self->profile->tag_is_enabled($tag_name);
+
+            my $context = $hint->context;
+
+            if (exists $context_tracker{$tag_name}{$context}) {
+                warn encode_utf8(
+"Tried to issue duplicate hint in check $issuer: $tag_name $context\n"
+                );
+                next;
+            }
+
+            $context_tracker{$tag_name}{$context} = 1;
+
+            my @masks;
+            for my $screen (@{$tag->screens}) {
+
+                next
+                  unless $screen->suppress($processable, $hint);
+
+                my $mask = Lintian::Mask->new;
+                $mask->screen($screen->name);
+
+                push(@masks, $mask);
+            }
+
+            my @screen_names = map { $_->screen } @masks;
+            my $screen_list = join($SPACE, (sort @screen_names));
+
+            warn encode_utf8("Crossing screens for $tag_name ($screen_list)")
+              if @masks > 1;
+
+            $hint->masks(\@masks)
+              if !$tag->show_always;
+
+            if (exists $enabled_overrides{$tag_name}) {
+
+                my $for_tag = $enabled_overrides{$tag_name};
+
+                if (exists $for_tag->{$EMPTY}) {
+                    $hint->override($for_tag->{$EMPTY});
+
+                } else {
+
+                    # overrides without context handled above
+                    my @patterns = grep { length } keys %{$for_tag};
+
+                    # try short ones first
+                    my @by_length = sort_by { length } @patterns;
+
+                    my $match = firstval {
+                        match_glob($_, $hint->context)
+                    }
+                    @by_length;
+
+                    $hint->override($for_tag->{$match})
+                      if defined $match;
+                }
+            }
+
+            # new hash values autovivify to 0
+            ++$used_overrides{$tag_name}{$hint->override->pattern}
+              if defined $hint->override;
+
+            push(@hints, $hint);
+        }
+
+        # look for unused overrides
+        for my $tag_name (keys %enabled_overrides) {
+
+            my @declared_patterns = keys %{$enabled_overrides{$tag_name}};
+            my @used_patterns = keys %{$used_overrides{$tag_name} // {}};
+
+            my $pattern_lc
+              = List::Compare->new(\@declared_patterns, \@used_patterns);
+            my @unused_patterns = $pattern_lc->get_Lonly;
+
+            for my $pattern (@unused_patterns) {
+
+                my $override = $enabled_overrides{$tag_name}{$pattern};
+
+                my $override_item = $processable->override_file;
+                my $position = $override->position;
+                my $pointer = $override_item->pointer($position);
+
+                my $unused = Lintian::Hint::Pointed->new;
+                $unused->issued_by('lintian');
+
+                $unused->tag_name('unused-override');
+                $unused->tag_name('mismatched-override')
+                  if exists $context_tracker{$tag_name};
+
+                # use the original name, in case the tag was renamed
+                my $original_name = $override->tag_name;
+                $unused->note($original_name . $SPACE . $pattern);
+
+                $unused->pointer($pointer);
+
+                # cannot be overridden or suppressed
+                push(@hints, $unused);
+            }
+        }
+
+        # carry hints into the output modules
+        $processable->hints(\@hints);
+    }
+
+    $self->processing_end(gmtime->datetime . 'Z');
+
+    my $raw_res = tv_interval($group_timer);
+    my $tres = sprintf('%.3fs', $raw_res);
+    say {*STDERR}
+      encode_utf8('Checking all of group ' . $self->name . " done ($tres)")
+      if $option->{debug};
+    say {*STDERR} encode_utf8($self->name . ",total-group-check,$raw_res")
+      if $option->{'perf-output'};
+
+    if ($option->{'debug'} > 2) {
+
+        # suppress warnings without reliable sizes
+        local $Devel::Size::warn = 0;
+
+        my @processables = $self->get_processables;
+        my $pivot = shift @processables;
+        my $group_id
+          = $pivot->source_name . $UNDERSCORE . $pivot->source_version;
+        my $group_usage
+          = human_bytes(total_size([map { $_ } $self->get_processables]));
+        say {*STDERR}
+          encode_utf8("Memory usage [group:$group_id]: $group_usage")
+          if $option->{debug} >= $EXTRA_VERBOSE;
+
+        for my $processable ($self->get_processables) {
+            my $id = $processable->identifier;
+            my $usage = human_bytes(total_size($processable));
+
+            say {*STDERR} encode_utf8("Memory usage [$id]: $usage")
+              if $option->{debug} >= $EXTRA_VERBOSE;
+        }
+    }
+
+    # change to known folder; ealier failures could prevent removal below
+    chdir $savedir
+      or warn encode_utf8("Cannot change to directory $savedir");
+
+    return $success;
+}
+
+=item $group->add_processable($proc)
+
+Adds $proc to $group.  At most one source and one changes $proc can be
+in a $group.  There can be multiple binary $proc's, as long as they
+are all unique.  Successive buildinfo $proc's are silently ignored.
+
+This will error out if an additional source or changes $proc is added
+to the group. Otherwise it will return a truth value if $proc was
+added.
+
+=cut
+
+sub add_processable {
+    my ($self, $processable) = @_;
+
+    if ($processable->tainted) {
+        warn encode_utf8(
+            sprintf(
+                "warning: tainted %1\$s package '%2\$s', skipping\n",
+                $processable->type, $processable->name
+            )
+        );
+        return 0;
+    }
+
+    $self->source_name($processable->source_name)
+      unless length $self->source_name;
+    $self->source_version($processable->source_version)
+      unless length $self->source_version;
+
+    return 0
+      if $self->source_name ne $processable->source_name
+      || $self->source_version ne $processable->source_version;
+
+    croak encode_utf8('Please set pool directory first.')
+      unless $self->pooldir;
+
+    $processable->pooldir($self->pooldir);
+
+    croak encode_utf8('Not a supported type (' . $processable->type . ')')
+      unless exists $SUPPORTED_TYPES{$processable->type};
+
+    if ($processable->type eq 'changes') {
+        die encode_utf8('Cannot add another ' . $processable->type . ' file')
+          if $self->changes;
+        $self->changes($processable);
+
+    } elsif ($processable->type eq 'buildinfo') {
+        # Ignore multiple .buildinfo files; use the first one
+        $self->buildinfo($processable)
+          unless $self->buildinfo;
+
+    } elsif ($processable->type eq 'source'){
+        die encode_utf8('Cannot add another source package')
+          if $self->source;
+        $self->source($processable);
+
+    } else {
+        my $type = $processable->type;
+        die encode_utf8('Unknown type ' . $type)
+          unless $type eq 'binary' || $type eq 'udeb';
+
+        # check for duplicate; should be rewritten with arrays
+        my $id = $processable->identifier;
+        return 0
+          if exists $self->$type->{$id};
+
+        $self->$type->{$id} = $processable;
+    }
+
+    return 1;
+}
+
+=item get_processables
+
+Returns an array of all processables in $group.
+
+=cut
+
+sub get_processables {
+    my ($self) = @_;
+
+    my @processables;
+
+    push(@processables, $self->changes)
+      if defined $self->changes;
+
+    push(@processables, $self->source)
+      if defined $self->source;
+
+    push(@processables, $self->buildinfo)
+      if defined $self->buildinfo;
+
+    push(@processables, $self->get_installables);
+
+    return @processables;
+}
+
+=item get_installables
+
+Returns all binary (and udeb) processables in $group.
+
+If $group does not have any binary processables then an empty list is
+returned.
+
+=cut
+
+sub get_installables {
+    my ($self) = @_;
+
+    my @installables;
+
+    push(@installables, values %{$self->binary});
+    push(@installables, values %{$self->udeb});
+
+    return @installables;
+}
+
+=item direct_dependencies (PROC)
+
+If PROC is a part of the underlying processable group, this method
+returns a listref containing all the direct dependencies of PROC.  If
+PROC is not a part of the group, this returns undef.
+
+Note: Only strong dependencies (Pre-Depends and Depends) are
+considered.
+
+Note: Self-dependencies (if any) are I<not> included in the result.
+
+=cut
+
+has saved_direct_dependencies => (is => 'rw', default => sub { {} });
+
+sub direct_dependencies {
+    my ($self, $processable) = @_;
+
+    unless (keys %{$self->saved_direct_dependencies}) {
+
+        my @processables = $self->get_installables;
+
+        my %dependencies;
+        for my $that (@processables) {
+
+            my $relation = $that->relation('strong');
+            my @specific;
+
+            for my $this (@processables) {
+
+                # Ignore self deps - we have checks for that and it
+                # will just end up complicating "correctness" of
+                # otherwise simple checks.
+                next
+                  if $this->name eq $that->name;
+
+                push @specific, $this
+                  if $relation->satisfies($this->name);
+            }
+            $dependencies{$that->name} = \@specific;
+        }
+
+        $self->saved_direct_dependencies(\%dependencies);
+    }
+
+    return $self->saved_direct_dependencies->{$processable->name}
+      if $processable;
+
+    return $self->saved_direct_dependencies;
+}
+
+=item direct_reliants (PROC)
+
+If PROC is a part of the underlying processable group, this method
+returns a listref containing all the packages in the group that rely
+on PROC.  If PROC is not a part of the group, this returns undef.
+
+Note: Only strong dependencies (Pre-Depends and Depends) are
+considered.
+
+Note: Self-dependencies (if any) are I<not> included in the result.
+
+=cut
+
+has saved_direct_reliants => (is => 'rw', default => sub { {} });
+
+sub direct_reliants {
+    my ($self, $processable) = @_;
+
+    unless (keys %{$self->saved_direct_reliants}) {
+
+        my @processables = $self->get_installables;
+
+        my %reliants;
+        foreach my $that (@processables) {
+
+            my @specific;
+            foreach my $this (@processables) {
+
+                # Ignore self deps - we have checks for that and it
+                # will just end up complicating "correctness" of
+                # otherwise simple checks.
+                next
+                  if $this->name eq $that->name;
+
+                my $relation = $this->relation('strong');
+                push @specific, $this
+                  if $relation->satisfies($that->name);
+            }
+            $reliants{$that->name} = \@specific;
+        }
+
+        $self->saved_direct_reliants(\%reliants);
+    }
+
+    return $self->saved_direct_reliants->{$processable->name}
+      if $processable;
+
+    return $self->saved_direct_reliants;
+}
+
+=item spelling_exceptions
+
+Returns a hashref of words, which the spell checker should ignore.
+These words are generally based on the package names in the group to
+avoid false-positive "spelling error" when packages have "fun" names.
+
+Example: Package alot-doc (#687464)
+
+=cut
+
+has spelling_exceptions => (
+    is => 'rw',
+    lazy => 1,
+    default => sub {
+        my ($self) = @_;
+
+        my @acceptable;
+
+        # this run may not have all types
+        for my $processable ($self->get_processables) {
+
+            # all processables have those
+            my @package_names= ($processable->name, $processable->source_name);
+
+            # for sources we have d/control
+            push(@package_names, $processable->debian_control->installables)
+              if $processable->type eq 'source';
+
+            push(@acceptable, @package_names);
+
+            # exempt pieces, too
+            my @package_pieces = map { split(m{-}) } @package_names;
+            push(@acceptable, @package_pieces);
+
+            my @people_names;
+            for my $role (qw(Maintainer Uploaders Changed-By)) {
+
+                my $value = $processable->fields->value($role);
+                for my $parsed (Email::Address::XS->parse($value)) {
+
+                    push(@people_names, $parsed->phrase)
+                      if length $parsed->phrase;
+                }
+            }
+
+            push(@acceptable, @people_names);
+
+            # exempt first and last name separately, too
+            my @people_pieces = map { split($SPACE) } @people_names;
+            push(@acceptable, @people_pieces);
+        }
+
+        return [uniq @acceptable];
+    }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+L<Lintian::Processable>
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et