summaryrefslogtreecommitdiffstats
path: root/lib/Lintian/Relation/Predicate.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Lintian/Relation/Predicate.pm')
-rw-r--r--lib/Lintian/Relation/Predicate.pm553
1 files changed, 553 insertions, 0 deletions
diff --git a/lib/Lintian/Relation/Predicate.pm b/lib/Lintian/Relation/Predicate.pm
new file mode 100644
index 0000000..4714197
--- /dev/null
+++ b/lib/Lintian/Relation/Predicate.pm
@@ -0,0 +1,553 @@
+# -*- perl -*-
+# Lintian::Relation::Predicate -- relationship predicates
+
+# Copyright (C) 1998 Christian Schwarz and Richard Braakman
+# Copyright (C) 2004-2009 Russ Allbery <rra@debian.org>
+# Copyright (C) 2018 Chris Lamb <lamby@debian.org>
+# 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, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Relation::Predicate;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+
+use Lintian::Relation::Version qw(:all);
+
+use Moo;
+use namespace::clean;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $COLON => q{:};
+
+const my $EQUAL => q{=};
+const my $LESS_THAN => q{<};
+const my $LESS_THAN_OR_EQUAL => q{<=};
+const my $DOUBLE_LESS_THAN => q{<<};
+const my $GREATER_THAN => q{>};
+const my $GREATER_THAN_OR_EQUAL => q{>=};
+const my $DOUBLE_GREATER_THAN => q{>>};
+
+const my $LEFT_PARENS => q{(};
+const my $RIGHT_PARENS => q{)};
+const my $LEFT_SQUARE => q{[};
+const my $RIGHT_SQUARE => q{]};
+const my $LEFT_ANGLE => q{<};
+const my $RIGHT_ANGLE => q{>};
+
+const my $TRUE => 1;
+const my $FALSE => 0;
+
+=head1 NAME
+
+Lintian::Relation::Predicate - Lintian type for relationship predicates
+
+=head1 SYNOPSIS
+
+ use Lintian::Relation::Predicate;
+
+=head1 DESCRIPTION
+
+This module provides functions for parsing and evaluating package
+relationships such as Depends and Recommends for binary packages and
+Build-Depends for source packages. It parses a relationship into an
+internal format and can then answer questions such as "does this
+dependency require that a given package be installed" or "is this
+relationship a superset of another relationship."
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item literal
+
+=item C<parsable>
+
+=item name
+
+=item multiarch_qualifier
+
+=item version_operator
+
+=item reference_version
+
+=item build_architecture
+
+=item build_profile
+
+=cut
+
+has literal => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has parsable => (is => 'rw', default => $FALSE);
+
+has name => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has multiarch_qualifier => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has version_operator => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has reference_version => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has build_architecture => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+has build_profile => (
+ is => 'rw',
+ default => $EMPTY,
+ coerce => sub { my ($text) = @_; return ($text // $EMPTY); }
+);
+
+=item parse
+
+=cut
+
+# The internal parser which converts a single package element of a
+# relationship into the parsed form used for later processing. We permit
+# substvars to be used as package names so that we can use these routines with
+# the unparsed debian/control file.
+sub parse {
+ my ($self, $text, $with_restrictions) = @_;
+
+ $with_restrictions //= $TRUE;
+
+ # store the element as-is, so we can reconstitute it later
+ $self->literal($text);
+
+ if (
+ $text =~ m{
+ ^\s* # skip leading whitespace
+ ( # package name or substvar (1)
+ (?: # start of the name
+ [a-zA-Z0-9][a-zA-Z0-9+.-]* # start of a package name
+ | # or
+ \$\{[a-zA-Z0-9:-]+\} # substvar
+ ) # end of start of the name
+ (?: # substvars may be mixed in
+ [a-zA-Z0-9+.-]+ # package name portion
+ | # or
+ \$\{[a-zA-Z0-9:-]+\} # substvar
+ )* # zero or more portions or substvars
+ ) # end of package name or substvar
+ (?:[:]([a-z0-9-]+))? # optional Multi-arch arch specification (2)
+ (?: # start of optional version
+ \s* \( # open parenthesis for version part
+ \s* (<<|<=|>=|>>|[=<>]) # relation part (3)
+ \s* ([^\)]+) # version (4)
+ \s* \) # closing parenthesis
+ )? # end of optional version
+ (?: # start of optional architecture
+ \s* \[ # open bracket for architecture
+ \s* ([^\]]+) # architectures (5)
+ \s* \] # closing bracket
+ )? # end of optional architecture
+ (?: # start of optional restriction
+ \s* < # open bracket for restriction
+ \s* ([^,]+) # don't parse restrictions now
+ \s* > # closing bracket
+ )? # end of optional restriction
+ \s* $}x
+ ) {
+ $self->parsable($TRUE);
+
+ $self->name($1);
+ $self->multiarch_qualifier($2);
+ $self->version_operator($3);
+ $self->reference_version($4);
+ $self->build_architecture($5);
+ $self->build_profile($6);
+
+ $self->reference_version($EMPTY)
+ unless length $self->version_operator;
+
+ $self->version_operator($DOUBLE_LESS_THAN)
+ if $self->version_operator eq $LESS_THAN;
+
+ $self->version_operator($DOUBLE_GREATER_THAN)
+ if $self->version_operator eq $GREATER_THAN;
+
+ unless ($with_restrictions) {
+ $self->multiarch_qualifier('any');
+ $self->version_operator($EMPTY);
+ $self->reference_version($EMPTY);
+ $self->build_architecture($EMPTY);
+ $self->build_profile($EMPTY);
+ }
+ }
+
+ return;
+}
+
+=item satisfies
+
+=cut
+
+# This internal function does the heavily lifting of comparing two
+# elements.
+#
+# Takes two elements and returns true iff the second can be deduced from the
+# first. If the second is falsified by the first (in other words, if self
+# actually satisfies not other), return 0. Otherwise, return undef. The 0 return
+# is used by implies_element_inverse.
+sub satisfies {
+ my ($self, $other) = @_;
+
+ if (!$self->parsable || !$other->parsable) {
+
+ return 1
+ if $self->to_string eq $other->to_string;
+
+ return undef;
+ }
+
+ # If the names don't match, there is no relationship between them.
+ return undef
+ if $self->name ne $other->name;
+
+ # the restriction formula forms a disjunctive normal form expression one
+ # way to check whether A <dnf1> satisfies A <dnf2> is to check:
+ #
+ # if dnf1 == dnf1 OR dnf2:
+ # the second dependency is superfluous because the first dependency
+ # applies in all cases the second one applies
+ #
+ # an easy way to check for equivalence of the two dnf expressions would be
+ # to construct the truth table for both expressions ("dnf1" and "dnf1 OR
+ # dnf2") for all involved profiles and then comparing whether they are
+ # equal
+ #
+ # the size of the truth tables grows with 2 to the power of the amount of
+ # involved profile names but since there currently only exist six possible
+ # profile names (see data/fields/build-profiles) that should be okay
+ #
+ # FIXME: we are not doing this check yet so if we encounter a dependency
+ # with build profiles we assume that one does not satisfy the other:
+
+ return undef
+ if length $self->build_profile
+ || length $other->build_profile;
+
+ # If the names match, then the only difference is in the architecture or
+ # version clauses. First, check architecture. The architectures for self
+ # must be a superset of the architectures for other.
+ my @self_arches = split($SPACE, $self->build_architecture);
+ my @other_arches = split($SPACE, $other->build_architecture);
+ if (@self_arches || @other_arches) {
+ my $self_arch_neg = @self_arches && $self_arches[0] =~ /^!/;
+ my $other_arch_neg = @other_arches && $other_arches[0] =~ /^!/;
+
+ # If self has no arches, it is a superset of other and we should fall through
+ # to the version check.
+ if (not @self_arches) {
+ # nothing
+ }
+
+ # If other has no arches, it is a superset of self and there are no useful
+ # implications.
+ elsif (not @other_arches) {
+
+ return undef;
+ }
+
+ # Both have arches. If neither are negated, we know nothing useful
+ # unless other is a subset of self.
+ elsif (not $self_arch_neg and not $other_arch_neg) {
+ my %self_arches = map { $_ => 1 } @self_arches;
+ my $subset = 1;
+ for my $arch (@other_arches) {
+ $subset = 0 unless $self_arches{$arch};
+ }
+
+ return undef
+ unless $subset;
+ }
+
+ # If both are negated, we know nothing useful unless self is a subset of
+ # other (and therefore has fewer things excluded, and therefore is more
+ # general).
+ elsif ($self_arch_neg and $other_arch_neg) {
+ my %other_arches = map { $_ => 1 } @other_arches;
+ my $subset = 1;
+ for my $arch (@self_arches) {
+ $subset = 0 unless $other_arches{$arch};
+ }
+
+ return undef
+ unless $subset;
+ }
+
+ # If other is negated and self isn't, we'd need to know the full list of
+ # arches to know if there's any relationship, so bail.
+ elsif (not $self_arch_neg and $other_arch_neg) {
+
+ return undef;
+ }
+
+# If self is negated and other isn't, other is a subset of self iff none of the
+# negated arches in self are present in other.
+ elsif ($self_arch_neg and not $other_arch_neg) {
+ my %other_arches = map { $_ => 1 } @other_arches;
+ my $subset = 1;
+ for my $arch (@self_arches) {
+ $subset = 0 if $other_arches{substr($arch, 1)};
+ }
+
+ return undef
+ unless $subset;
+ }
+ }
+
+ # Multi-arch architecture specification
+
+ # According to the spec, only the special value "any" is allowed
+ # and it is "recommended" to consider "other such package
+ # relations as unsatisfiable". That said, there seem to be an
+ # interest in supporting ":<arch>" as well, so we will (probably)
+ # have to accept those as well.
+ #
+ # Other than that, we would need to know that the package has the
+ # field "Multi-arch: allowed", but we cannot check that here. So
+ # we assume that it is okay.
+
+ # pkg has no chance of satisfing pkg:Y unless Y is 'any'
+ return undef
+ if !length $self->multiarch_qualifier
+ && length $other->multiarch_qualifier
+ && $other->multiarch_qualifier ne 'any';
+
+ # TODO: Review this case. Are there cases where other cannot
+ # disprove self due to the ":any"-qualifier? For now, we
+ # assume there are no such cases.
+ # pkg:X has no chance of satisfying pkg
+ return undef
+ if length $self->multiarch_qualifier
+ && !length $other->multiarch_qualifier;
+
+ # For now assert that only the identity holds. In practise, the
+ # "pkg:X" (for any valid value of X) seems to satisfy "pkg:any",
+ # fixing that is a TODO (because version clauses complicates
+ # matters)
+ # pkg:X has no chance of satisfying pkg:Y unless X equals Y
+ return undef
+ if length $self->multiarch_qualifier
+ && length $other->multiarch_qualifier
+ && $self->multiarch_qualifier ne $other->multiarch_qualifier;
+
+ # Now, down to version. The implication is true if self's clause is stronger
+ # than other's, or is equivalent.
+
+ # If other has no version clause, then self's clause is always stronger.
+ return 1
+ unless length $other->version_operator;
+
+# If other does have a version clause, then self must also have one to have any
+# useful relationship.
+ return undef
+ unless length $self->version_operator;
+
+ # other wants an exact version, so self must provide that exact version. self
+ # disproves other if other's version is outside the range enforced by self.
+ if ($other->version_operator eq $EQUAL) {
+ if ($self->version_operator eq $DOUBLE_LESS_THAN) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $LESS_THAN_OR_EQUAL) {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $DOUBLE_GREATER_THAN) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_equal($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ }
+ }
+
+# A greater than clause may disprove a less than clause. Otherwise, if
+# self's clause is <<, <=, or =, the version must be <= other's to satisfy other.
+ if ($other->version_operator eq $LESS_THAN_OR_EQUAL) {
+ if ($self->version_operator eq $DOUBLE_GREATER_THAN) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+
+ # Similar, but << is stronger than <= so self's version must be << other's
+ # version if the self relation is <= or =.
+ if ($other->version_operator eq $DOUBLE_LESS_THAN) {
+ if ( $self->version_operator eq $DOUBLE_GREATER_THAN
+ || $self->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ return versions_gte($self->reference_version,
+ $self->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $DOUBLE_LESS_THAN) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+
+ # Same logic as above, only inverted.
+ if ($other->version_operator eq $GREATER_THAN_OR_EQUAL) {
+ if ($self->version_operator eq $DOUBLE_LESS_THAN) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $LESS_THAN_OR_EQUAL) {
+ return versions_lt($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+ if ($other->version_operator eq $DOUBLE_GREATER_THAN) {
+ if ( $self->version_operator eq $DOUBLE_LESS_THAN
+ || $self->version_operator eq $LESS_THAN_OR_EQUAL) {
+ return versions_lte($self->reference_version,
+ $other->reference_version) ? 0 : undef;
+ } elsif ($self->version_operator eq $DOUBLE_GREATER_THAN) {
+ return versions_gte($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ } elsif ($self->version_operator eq $EQUAL) {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 1 : 0;
+ } else {
+ return versions_gt($self->reference_version,
+ $other->reference_version) ? 1 : undef;
+ }
+ }
+
+ return undef;
+}
+
+=item satisfies_inverse
+
+=cut
+
+# This internal function does the heavy lifting of inverse implication between
+# two elements. Takes two elements and returns true iff the falsehood of
+# the second can be deduced from the truth of the first. In other words, self
+# satisfies not other, or restated, other satisfies not self. (Since if a satisfies b, not b
+# satisfies not a.) Due to the return value of implies_element(), we can let it
+# do most of the work.
+sub satisfies_inverse {
+ my ($self, $other) = @_;
+
+ my $result = $self->satisfies($other);
+ return undef
+ if !defined $result;
+
+ return $result ? 0 : 1;
+}
+
+=item to_string
+
+=cut
+
+sub to_string {
+ my ($self) = @_;
+
+ # return the original value
+ return $self->literal
+ unless $self->parsable;
+
+ my $text = $self->name;
+
+ $text .= $COLON . $self->multiarch_qualifier
+ if length $self->multiarch_qualifier;
+
+ $text
+ .= $SPACE
+ . $LEFT_PARENS
+ . $self->version_operator
+ . $SPACE
+ . $self->reference_version
+ . $RIGHT_PARENS
+ if length $self->version_operator;
+
+ $text.= $SPACE . $LEFT_SQUARE . $self->build_architecture . $RIGHT_SQUARE
+ if length $self->build_architecture;
+
+ $text .= $SPACE . $LEFT_ANGLE . $self->build_profile . $RIGHT_ANGLE
+ if length $self->build_profile;
+
+ return $text;
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Russ Allbery <rra@debian.org> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
generated by cgit v1.2.3 (git 2.39.1) at 2024-08-10 07:04:12 +0000