diff options
Diffstat (limited to 'lib/Lintian/Group.pm')
| -rw-r--r-- | lib/Lintian/Group.pm | 794 |
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 |