vcs.maemo.org Git - maemian/blob - lib/Maemian/Relation.pm

   1 # -*- perl -*-
   2 # Maemian::Relation -- operations on dependencies and relationships
   3
   4 # Copyright (C) 1998 Christian Schwarz and Richard Braakman
   5 # Copyright (C) 2004-2009 Russ Allbery <rra@debian.org>
   6 #
   7 # This program is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by the Free
   9 # Software Foundation; either version 2 of the License, or (at your option)
  10 # any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful, but WITHOUT
  13 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
  15 # more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along with
  18 # this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 package Maemian::Relation;
  21
  22 use strict;
  23 use warnings;
  24
  25 use Maemian::Relation::Version;
  26
  27 =head1 NAME
  28
  29 Maemian::Relation - Maemian operations on dependencies and relationships
  30
  31 =head1 SYNOPSIS
  32
  33     my $depends = Maemian::Relation->new('foo | bar, baz');
  34     print "yes\n" if $depends->implies('baz');
  35     print "no\n" if $depends->implies('foo');
  36
  37 =head1 DESCRIPTION
  38
  39 This module provides functions for parsing and evaluating package
  40 relationship fields such as Depends and Recommends for binary packages and
  41 Build-Depends for source packages.  It parses a relationship into an
  42 internal format and can then answer questions such as "does this
  43 dependency require that a given package be installed" or "is this
  44 relationship a superset of another relationship."
  45
  46 A dependency line is viewed as a predicate formula.  The comma separator
  47 means "and", and the alternatives separator means "or".  A bare package
  48 name is the predicate "a package of this name is available".  A package
  49 name with a version clause is the predicate "a package of this name that
  50 satisfies this version clause is available."  Architecture restrictions,
  51 as specified in Policy for build dependencies, are supported and also
  52 checked in the implication logic unless the new_noarch() constructor is
  53 used.  With that constructor, architecture restrictions are ignored.
  54
  55 =head1 CLASS METHODS
  56
  57 =over 4
  58
  59 =item new(RELATION)
  60
  61 Creates a new Maemian::Relation object corresponding to the parsed
  62 relationship RELATION.  This object can then be used to ask questions
  63 about that relationship.  RELATION may be C<undef> or the empty string, in
  64 which case the returned Maemian::Relation object is empty (always
  65 satisfied).
  66
  67 =cut
  68
  69 # The internal parser which converts a single package element of a
  70 # relationship into the parsed form used for later processing.  We permit
  71 # substvars to be used as package names so that we can use these routines with
  72 # the unparsed debian/control file.
  73 sub parse_element {
  74     my ($class, $element) = @_;
  75     $element =~ /
  76         ^\s*                            # skip leading whitespace
  77         (                               # package name or substvar (1)
  78          [a-zA-Z0-9][a-zA-Z0-9+.-]+     #   package name
  79          |                              #   or
  80          \$\{[a-zA-Z0-9:-]+\}           #   substvar
  81         )                               # end of package name or substvar
  82         (?:                             # start of optional version
  83          \s* \(                         # open parenthesis for version part
  84          \s* (<<|<=|=|>=|>>|<|>)        # relation part (2)
  85          \s* (.*?)                      # version (3)
  86          \s* \)                         # closing parenthesis
  87         )?                              # end of optional version
  88         (?:                             # start of optional architecture
  89          \s* \[                         # open bracket for architecture
  90          \s* (.*?)                      # architectures (4)
  91          \s* \]                         # closing bracket
  92         )?                              # end of optional architecture
  93     /x;
  94
  95     # If there's no version, we don't need to do any further processing.
  96     # Otherwise, convert the legacy < and > relations to the current ones.
  97     return ['PRED', $1, undef, undef, $4] if not defined $2;
  98     my $two = $2;
  99     if ($two eq '<') {
 100         $two = '<<';
 101     } elsif ($two eq '>') {
 102         $two = '>>';
 103     }
 104     return ['PRED', $1, $two, $3, $4];
 105 }
 106
 107
 108 # Create a new Maemian::Relation object, parsing the argument into our
 109 # internal format.
 110 sub new {
 111     my ($class, $relation) = @_;
 112     $relation = '' unless defined($relation);
 113     my @result;
 114     for my $element (split(/\s*,\s*/, $relation)) {
 115         next if $element =~ /^$/;
 116         my @alternatives;
 117         for my $alternative (split(/\s*\|\s*/, $element)) {
 118             push(@alternatives, $class->parse_element($alternative));
 119         }
 120         if (@alternatives == 1) {
 121             push(@result, @alternatives);
 122         } else {
 123             push(@result, ['OR', @alternatives]);
 124         }
 125     }
 126     my $self;
 127     if (@result == 1) {
 128         $self = $result[0];
 129     } else {
 130         $self = ['AND', @result];
 131     }
 132     bless($self, $class);
 133     return $self;
 134 }
 135
 136 =item new_noarch(RELATION)
 137
 138 Creates a new Maemian::Relation object corresponding to the parsed
 139 relationship RELATION, ignoring architecture restrictions.  This should be
 140 used in cases where we only care if a dependency is present in some cases
 141 and we don't want to require that the architectures match (such as when
 142 checking for proper build dependencies, since if there are architecture
 143 constraints the maintainer is doing something beyond Maemian's ability to
 144 analyze).  RELATION may be C<undef> or the empty string, in which case the
 145 returned Maemian::Relation object is empty (always satisfied).
 146
 147 =cut
 148
 149 sub new_noarch {
 150     my ($class, $relation) = @_;
 151     $relation = '' unless defined($relation);
 152     $relation =~ s/\[[^\]]*\]//g;
 153     return $class->new($relation);
 154 }
 155
 156 =back
 157
 158 =head1 INSTANCE METHODS
 159
 160 =over 4
 161
 162 =item duplicates()
 163
 164 Returns a list of duplicated elements within the relation object.  Each
 165 element of the returned list will be a reference to an anonymous array
 166 holding a set of relations considered duplicates of each other.  Two
 167 relations are considered duplicates if one implies the other, meaning that
 168 if one relationship is satisfied, the other is necessarily satisfied.
 169 This relationship does not have to be commutative: the opposite
 170 implication may not hold.
 171
 172 =cut
 173
 174 sub duplicates {
 175     my ($self) = @_;
 176
 177     # There are no duplicates unless the top-level relationship is AND.
 178     if ($self->[0] ne 'AND') {
 179         return ();
 180     }
 181
 182     # The logic here is a bit complex in order to merge sets of duplicate
 183     # dependencies.  We want foo (<< 2), foo (>> 1), foo (= 1.5) to end up as
 184     # one set of duplicates, even though the first doesn't imply the second.
 185     #
 186     # $dups holds a hash, where the key is the earliest dependency in a set
 187     # and the value is a hash whose keys are the other dependencies in the
 188     # set.  $seen holds a map from package names to the duplicate sets that
 189     # they're part of, if they're not the earliest package in a set.  If
 190     # either of the dependencies in a duplicate pair were already seen, add
 191     # the missing one of the pair to the existing set rather than creating a
 192     # new one.
 193     my (%dups, %seen);
 194     for (my $i = 1; $i < @$self; $i++) {
 195         for (my $j = $i + 1; $j < @$self; $j++) {
 196             my $forward = $self->implies_array($self->[$i], $self->[$j]);
 197             my $reverse = $self->implies_array($self->[$j], $self->[$i]);
 198             if ($forward or $reverse) {
 199                 my $first = unparse($self->[$i]);
 200                 my $second = unparse($self->[$j]);
 201                 if ($seen{$first}) {
 202                     $dups{$seen{$first}}->{$second} = $j;
 203                     $seen{$second} = $seen{$first};
 204                 } elsif ($seen{$second}) {
 205                     $dups{$seen{$second}}->{$first} = $i;
 206                     $seen{$first} = $seen{$second};
 207                 } else {
 208                     $dups{$first} ||= {};
 209                     $dups{$first}->{$second} = $j;
 210                     $seen{$second} = $first;
 211                 }
 212             }
 213         }
 214     }
 215
 216     # The sort maintains the original order in which we encountered the
 217     # dependencies, just in case that helps the user find the problems,
 218     # despite the fact we're using a hash.
 219     return map {
 220         [ $_,
 221           sort { $dups{$_}->{$a} <=> $dups{$_}->{$b} } keys %{ $dups{$_} }
 222         ]
 223     } keys %dups;
 224 }
 225
 226 =item implies(RELATION)
 227
 228 Returns true if the relationship implies RELATION, meaning that if the
 229 Maemian::Relation object is satisfied, RELATION will always be satisfied.
 230 RELATION may be either a string or another Maemian::Relation object.
 231
 232 By default, architecture restrictions are honored in RELATION if it is a
 233 string.  If architecture restrictions should be ignored in RELATION,
 234 create a Maemian::Relation object with new_noarch() and pass that in as
 235 RELATION instead of the string.
 236
 237 =cut
 238
 239 # This internal function does the heavily lifting of comparing two
 240 # elements.
 241 #
 242 # Takes two elements and returns true iff the second can be deduced from the
 243 # first.  If the second is falsified by the first (in other words, if p
 244 # actually implies not q), return 0.  Otherwise, return undef.  The 0 return
 245 # is used by implies_element_inverse.
 246 sub implies_element {
 247     my ($self, $p, $q) = @_;
 248
 249     # If the names don't match, there is no relationship between them.
 250     $$p[1] = '' unless defined $$p[1];
 251     $$q[1] = '' unless defined $$q[1];
 252     return undef if $$p[1] ne $$q[1];
 253
 254     # If the names match, then the only difference is in the architecture or
 255     # version clauses.  First, check architecture.  The architectures for p
 256     # must be a superset of the architectures for q.
 257     my @p_arches = split(' ', defined($$p[4]) ? $$p[4] : '');
 258     my @q_arches = split(' ', defined($$q[4]) ? $$q[4] : '');
 259     if (@p_arches || @q_arches) {
 260         my $p_arch_neg = @p_arches && $p_arches[0] =~ /^!/;
 261         my $q_arch_neg = @q_arches && $q_arches[0] =~ /^!/;
 262
 263         # If p has no arches, it is a superset of q and we should fall through
 264         # to the version check.
 265         if (not @p_arches) {
 266             # nothing
 267         }
 268
 269         # If q has no arches, it is a superset of p and there are no useful
 270         # implications.
 271         elsif (not @q_arches) {
 272             return undef;
 273         }
 274
 275         # Both have arches.  If neither are negated, we know nothing useful
 276         # unless q is a subset of p.
 277         elsif (not $p_arch_neg and not $q_arch_neg) {
 278             my %p_arches = map { $_ => 1 } @p_arches;
 279             my $subset = 1;
 280             for my $arch (@q_arches) {
 281                 $subset = 0 unless $p_arches{$arch};
 282             }
 283             return undef unless $subset;
 284         }
 285
 286         # If both are negated, we know nothing useful unless p is a subset of
 287         # q (and therefore has fewer things excluded, and therefore is more
 288         # general).
 289         elsif ($p_arch_neg and $q_arch_neg) {
 290             my %q_arches = map { $_ => 1 } @q_arches;
 291             my $subset = 1;
 292             for my $arch (@p_arches) {
 293                 $subset = 0 unless $q_arches{$arch};
 294             }
 295             return undef unless $subset;
 296         }
 297
 298         # If q is negated and p isn't, we'd need to know the full list of
 299         # arches to know if there's any relationship, so bail.
 300         elsif (not $p_arch_neg and $q_arch_neg) {
 301             return undef;
 302         }
 303
 304         # If p is negated and q isn't, q is a subset of p iff none of the
 305         # negated arches in p are present in q.
 306         elsif ($p_arch_neg and not $q_arch_neg) {
 307             my %q_arches = map { $_ => 1 } @q_arches;
 308             my $subset = 1;
 309             for my $arch (@p_arches) {
 310                 $subset = 0 if $q_arches{substr($arch, 1)};
 311             }
 312             return undef unless $subset;
 313         }
 314     }
 315
 316     # Now, down to version.  The implication is true if p's clause is stronger
 317     # than q's, or is equivalent.
 318
 319     # If q has no version clause, then p's clause is always stronger.
 320     return 1 if not defined $$q[2];
 321
 322     # If q does have a version clause, then p must also have one to have any
 323     # useful relationship.
 324     return undef if not defined $$p[2];
 325
 326     # q wants an exact version, so p must provide that exact version.  p
 327     # disproves q if q's version is outside the range enforced by p.
 328     if ($$q[2] eq '=') {
 329         if ($$p[2] eq '<<') {
 330             return versions_lte($$p[3], $$q[3]) ? 0 : undef;
 331         } elsif ($$p[2] eq '<=') {
 332             return versions_lt($$p[3], $$q[3]) ? 0 : undef;
 333         } elsif ($$p[2] eq '>>') {
 334             return versions_gte($$p[3], $$q[3]) ? 0 : undef;
 335         } elsif ($$p[2] eq '>=') {
 336             return versions_gt($$p[3], $$q[3]) ? 0 : undef;
 337         } elsif ($$p[2] eq '=') {
 338             return versions_equal($$p[3], $$q[3]);
 339         }
 340     }
 341
 342     # A greater than clause may disprove a less than clause.  Otherwise, if
 343     # p's clause is <<, <=, or =, the version must be <= q's to imply q.
 344     if ($$q[2] eq '<=') {
 345         if ($$p[2] eq '>>') {
 346             return versions_gte($$p[3], $$q[3]) ? 0 : undef;
 347         } elsif ($$p[2] eq '>=') {
 348             return versions_gt($$p[3], $$q[3]) ? 0 : undef;
 349         } elsif ($$p[2] eq '=') {
 350             return versions_lte($$p[3], $$q[3]);
 351         } else {
 352             return versions_lte($$p[3], $$q[3]) ? 1 : undef;
 353         }
 354     }
 355
 356     # Similar, but << is stronger than <= so p's version must be << q's
 357     # version if the p relation is <= or =.
 358     if ($$q[2] eq '<<') {
 359         if ($$p[2] eq '>>' or $$p[2] eq '>=') {
 360             return versions_gte($$p[3], $$p[3]) ? 0 : undef;
 361         } elsif ($$p[2] eq '<<') {
 362             return versions_lte($$p[3], $$q[3]);
 363         } elsif ($$p[2] eq '=') {
 364             return versions_lt($$p[3], $$q[3]);
 365         } else {
 366             return versions_lt($$p[3], $$q[3]) ? 1 : undef;
 367         }
 368     }
 369
 370     # Same logic as above, only inverted.
 371     if ($$q[2] eq '>=') {
 372         if ($$p[2] eq '<<') {
 373             return versions_lte($$p[3], $$q[3]) ? 0 : undef;
 374         } elsif ($$p[2] eq '<=') {
 375             return versions_lt($$p[3], $$q[3]) ? 0 : undef;
 376         } elsif ($$p[2] eq '=') {
 377             return versions_gte($$p[3], $$q[3]);
 378         } else {
 379             return versions_gte($$p[3], $$q[3]) ? 1 : undef;
 380         }
 381     }
 382     if ($$q[2] eq '>>') {
 383         if ($$p[2] eq '<<' or $$p[2] eq '<=') {
 384             return versions_lte($$p[3], $$q[3]) ? 0 : undef;
 385         } elsif ($$p[2] eq '>>') {
 386             return versions_gte($$p[3], $$q[3]);
 387         } elsif ($$p[2] eq '=') {
 388             return versions_gt($$p[3], $$q[3]);
 389         } else {
 390             return versions_gt($$p[3], $$q[3]) ? 1 : undef;
 391         }
 392     }
 393
 394     return undef;
 395 }
 396
 397 # This internal function does the heavy of AND, OR, and NOT logic.  It expects
 398 # two references to arrays instead of an object and a relation.
 399 sub implies_array {
 400     my ($self, $p, $q) = @_;
 401     my $i;
 402     if ($q->[0] eq 'PRED') {
 403         if ($p->[0] eq 'PRED') {
 404             return $self->implies_element($p, $q);
 405         } elsif ($p->[0] eq 'AND') {
 406             $i = 1;
 407             while ($i < @$p) {
 408                 return 1 if $self->implies_array($p->[$i++], $q);
 409             }
 410             return 0;
 411         } elsif ($p->[0] eq 'OR') {
 412             $i = 1;
 413             while ($i < @$p) {
 414                 return 0 if not $self->implies_array($p->[$i++], $q);
 415             }
 416             return 1;
 417         } elsif ($p->[0] eq 'NOT') {
 418             return $self->implies_array_inverse($p->[1], $q);
 419         }
 420     } elsif ($q->[0] eq 'AND') {
 421         # Each of q's clauses must be deduced from p.
 422         $i = 1;
 423         while ($i < @$q) {
 424             return 0 if not $self->implies_array($p, $q->[$i++]);
 425         }
 426         return 1;
 427     } elsif ($q->[0] eq 'OR') {
 428         # If p is something other than OR, p needs to satisfy one of the
 429         # clauses of q.  If p is an AND clause, q is satisfied if any of the
 430         # clauses of p satisfy it.
 431         #
 432         # The interesting case is OR.  In this case, do an OR to OR comparison
 433         # to determine if q's clause is a superset of p's clause as follows:
 434         # take each branch of p and see if it satisfies a branch of q.  If
 435         # each branch of p satisfies some branch of q, return 1.  Otherwise,
 436         # return 0.
 437         #
 438         # Simple logic that requires that p satisfy at least one of the
 439         # clauses of q considered in isolation will miss that a|b satisfies
 440         # a|b|c, since a|b doesn't satisfy any of a, b, or c in isolation.
 441         if ($p->[0] eq 'PRED') {
 442             $i = 1;
 443             while ($i < @$q) {
 444                 return 1 if $self->implies_array($p, $q->[$i++]);
 445             }
 446             return 0;
 447         } elsif ($p->[0] eq 'AND') {
 448             $i = 1;
 449             while ($i < @$p) {
 450                 return 1 if $self->implies_array($p->[$i++], $q);
 451             }
 452             return 0;
 453         } elsif ($p->[0] eq 'OR') {
 454             for ($i = 1; $i < @$p; $i++) {
 455                 my $j = 1;
 456                 my $satisfies = 0;
 457                 while ($j < @$q) {
 458                     if ($self->implies_array($p->[$i], $q->[$j++])) {
 459                         $satisfies = 1;
 460                         last;
 461                     }
 462                 }
 463                 return 0 unless $satisfies;
 464             }
 465             return 1;
 466         } elsif ($p->[0] eq 'NOT') {
 467             return $self->implies_array_inverse($p->[1], $q);
 468         }
 469     } elsif ($q->[0] eq 'NOT') {
 470         if ($p->[0] eq 'NOT') {
 471             return $self->implies_array($q->[1], $p->[1]);
 472         }
 473         return $self->implies_array_inverse($p, $q->[1]);
 474     }
 475 }
 476
 477 # The public interface.
 478 sub implies {
 479     my ($self, $relation) = @_;
 480     if (ref($relation) ne 'Maemian::Relation') {
 481         $relation = Maemian::Relation->new($relation);
 482     }
 483     return $self->implies_array($self, $relation);
 484 }
 485
 486 =item implies_inverse(RELATION)
 487
 488 Returns true if the relationship implies that RELATION is certainly false,
 489 meaning that if the Maemian::Relation object is satisfied, RELATION cannot
 490 be satisfied.  RELATION may be either a string or another
 491 Maemian::Relation object.
 492
 493 As with implies(), by default, architecture restrictions are honored in
 494 RELATION if it is a string.  If architecture restrictions should be
 495 ignored in RELATION, create a Maemian::Relation object with new_noarch()
 496 and pass that in as RELATION instead of the string.
 497
 498 =cut
 499
 500 # This internal function does the heavy lifting of inverse implication between
 501 # two elements.  Takes two elements and returns true iff the falsehood of
 502 # the second can be deduced from the truth of the first.  In other words, p
 503 # implies not q, or resstated, q implies not p.  (Since if a implies b, not b
 504 # implies not a.)  Due to the return value of implies_element(), we can let it
 505 # do most of the work.
 506 sub implies_element_inverse {
 507     my ($self, $p, $q) = @_;
 508     my $result = $self->implies_element($q, $p);
 509
 510     return not $result if defined $result;
 511     return undef;
 512 }
 513
 514 # This internal function does the heavily lifting for AND, OR, and NOT
 515 # handling for inverse implications.  It takes two references to arrays and
 516 # returns true iff the falsehood of the second can be deduced from the truth
 517 # of the first.
 518 sub implies_array_inverse {
 519     my ($self, $p, $q) = @_;
 520     my $i;
 521     if ($$q[0] eq 'PRED') {
 522         if ($$p[0] eq 'PRED') {
 523             return $self->implies_element_inverse($p, $q);
 524         } elsif ($$p[0] eq 'AND') {
 525             # q's falsehood can be deduced from any of p's clauses
 526             $i = 1;
 527             while ($i < @$p) {
 528                 return 1 if $self->implies_array_inverse($$p[$i++], $q);
 529             }
 530             return 0;
 531         } elsif ($$p[0] eq 'OR') {
 532             # q's falsehood must be deduced from each of p's clauses
 533             $i = 1;
 534             while ($i < @$p) {
 535                 return 0 if not $self->implies_array_inverse($$p[$i++], $q);
 536             }
 537             return 1;
 538         } elsif ($$p[0] eq 'NOT') {
 539             return $self->implies_array($q, $$p[1]);
 540         }
 541     } elsif ($$q[0] eq 'AND') {
 542         # Any of q's clauses must be falsified by p.
 543         $i = 1;
 544         while ($i < @$q) {
 545             return 1 if $self->implies_array_inverse($p, $$q[$i++]);
 546         }
 547         return 0;
 548     } elsif ($$q[0] eq 'OR') {
 549         # Each of q's clauses must be falsified by p.
 550         $i = 1;
 551         while ($i < @$q) {
 552             return 0 if not $self->implies_array_inverse($p, $$q[$i++]);
 553         }
 554         return 1;
 555     } elsif ($$q[0] eq 'NOT') {
 556         return $self->implies_array($p, $$q[1]);
 557     }
 558 }
 559
 560 # The public interface.
 561 sub implies_inverse {
 562     my ($self, $relation) = @_;
 563     if (ref($relation) ne 'Maemian::Relation') {
 564         $relation = Maemian::Relation->new($relation);
 565     }
 566     return $self->implies_array_inverse($self, $relation);
 567 }
 568
 569 =item unparse()
 570
 571 Returns the textual form of a relationship.  This converts the internal
 572 form back into the textual representation and returns that, not the
 573 original argument, so the spacing is standardized.  Returns undef on
 574 internal faliures (such as an object in an unexpected format).
 575
 576 =cut
 577
 578 # The second argument isn't part of the public API.  It's a partial relation
 579 # that's not a blessed object and is used by unparse() internally so that it
 580 # can recurse.
 581 #
 582 # We also support a NOT predicate.  This currently isn't ever generated by a
 583 # regular relation, but it may someday be useful.
 584 sub unparse {
 585     my ($self, $partial) = @_;
 586     my $relation = defined($partial) ? $partial : $self;
 587     if ($relation->[0] eq 'PRED') {
 588         my $text = $relation->[1];
 589         if (defined $relation->[2]) {
 590             $text .= " ($relation->[2] $relation->[3])";
 591         }
 592         if (defined $relation->[4]) {
 593             $text .= " [$relation->[4]]";
 594         }
 595         return $text;
 596     } elsif ($relation->[0] eq 'AND' || $relation->[0] eq 'OR') {
 597         my $seperator = ($relation->[0] eq 'AND') ? ', ' : ' | ';
 598         my $text = '';
 599         for my $element (@$relation) {
 600             $text .= $seperator if $text;
 601             my $result = $self->unparse($element);
 602             return unless defined($result);
 603             $text .= $result;
 604         }
 605         return $text;
 606     } elsif ($relation->[0] eq 'NOT') {
 607         return '! ' . $self->unparse($relation->[1]);
 608     } else {
 609         return;
 610     }
 611 }
 612
 613 =back
 614
 615 =head1 AUTHOR
 616
 617 Originally written by Russ Allbery <rra@debian.org> for Maemian.
 618
 619 =head1 SEE ALSO
 620
 621 lintian(1)
 622
 623 =cut
 624
 625 1;
 626
 627 # Local Variables:
 628 # indent-tabs-mode: nil
 629 # cperl-indent-level: 4
 630 # End:
 631 # vim: syntax=perl sw=4 ts=8