vcs.maemo.org Git - maemian/blob - nokia-lintian/lib/Dep.pm

   1 # -*- perl -*-
   2
   3 # This library handles operations on dependencies.
   4 # It provides a routine Dep::parse that converts a dependency line in
   5 # the dpkg control format to its own internal format.
   6 # All its other routines work on that internal format.
   7
   8 # A dependency line is viewed as a predicate formula.  The comma
   9 # separator means "and", and the alternatives separator means "or".
  10 # A bare package name is the predicate "a package of this name is
  11 # available".  A package name with a version clause is the predicate
  12 # "a package of this name that satisfies this version clause is
  13 # available".
  14 #
  15 # This way, the presence of a package can be represented simply as
  16 # "packagename (=version)", or if it has a Provides line, as
  17 # "packagename (=version) | provide1 | provide2 | provide3".
  18
  19 use strict;
  20
  21 use lib "$ENV{'LINTIAN_ROOT'}/lib";
  22 use Pipeline;
  23
  24 package Dep;
  25
  26 # ---------------------------------
  27 # public routines
  28
  29 # We permit substvars for package names so that we can use the routines in
  30 # this library against the unparsed debian/control file.
  31 sub Pred {
  32     $_[0] =~
  33             /^\s*                           # skip leading whitespace
  34               (                             # package name or substvar
  35                [a-zA-Z0-9][a-zA-Z0-9+.-]+   #   package name
  36                |                            #   or
  37                (?:\$\{[a-zA-Z0-9:-]+\})     #   substvar
  38               )                             # end of package name or substvar
  39               (?:                           # start of optional part
  40                 \s* \(                      # open parenthesis for version part
  41                 \s* (<<|<=|=|>=|>>|<|>)     # relation part
  42                 \s* (.*?)                   # do not attempt to parse version
  43                 \s* \)                      # closing parenthesis
  44               )?                            # end of optional part
  45               (?:                           # start of optional architecture
  46                 \s* \[                      # open bracket for architecture
  47                 \s* (.*?)                   # don't parse architectures now
  48                 \s* \]                      # closing bracket
  49               )?                            # end of optional architecture
  50             /x;
  51     return ['PRED', $1, undef, undef, $4] if not defined $2;
  52     my $two = $2;
  53     if ($two eq '<') {
  54         $two = '<<';
  55     } elsif ($two eq '>') {
  56         $two = '>>';
  57     }
  58     return ['PRED', $1, $two, $3, $4];
  59 }
  60
  61 sub Or { return ['OR', @_]; }
  62 sub And { return ['AND', @_]; }
  63 sub Not { return ['NOT', $_[0]]; }
  64
  65 # Convert a dependency line into the internal format.
  66 # Non-local callers may store the results of this routine.
  67 sub parse {
  68     my @deps;
  69     for (split(/\s*,\s*/, $_[0])) {
  70         next if /^$/;
  71         my @alts;
  72         if (/^perl\s+\|\s+perl5$/ or /^perl5\s+\|\s+perl\s+/) {
  73             $_ = 'perl5';
  74         }
  75         for (split(/\s*\|\s*/, $_)) {
  76             push(@alts, Dep::Pred($_));
  77         }
  78         if (@alts == 1) {
  79             push(@deps, $alts[0]);
  80         } else {
  81             push(@deps, ['OR', @alts]);
  82         }
  83     }
  84     return $deps[0] if @deps == 1;
  85     return ['AND', @deps];
  86 }
  87
  88 # Take the internal format and convert it back to text.  Note that what this
  89 # generates for NOT isn't valid Debian dependency syntax.
  90 sub unparse {
  91     my ($p) = @_;
  92     if ($p->[0] eq 'PRED') {
  93         my $text = $p->[1];
  94         if (defined $p->[2]) {
  95             $text .= " ($p->[2] $p->[3])";
  96         }
  97         if (defined $p->[4]) {
  98             $text .= " [$p->[4]]";
  99         }
 100         return $text;
 101     } elsif ($p->[0] eq 'AND' || $p->[0] eq 'OR') {
 102         my $sep = ($p->[0] eq 'AND') ? ', ' : ' | ';
 103         my $text = '';
 104         my $i = 1;
 105         while ($i < @$p) {
 106             $text .= $sep if $text;
 107             $text .= unparse($p->[$i++]);
 108         }
 109         return $text;
 110     } elsif ($p->[0] eq 'NOT') {
 111         return '! ' . unparse($p->[1]);
 112     }
 113     return undef;
 114 }
 115
 116 # ---------------------------------
 117
 118 # Takes two predicate formulas and returns true iff the second can be
 119 # deduced from the first.
 120 sub implies {
 121     my ($p, $q) = @_;
 122     my $i;
 123
 124     #Dep::debugprint($p);
 125     #warn " |- ";
 126     #Dep::debugprint($q);
 127     #warn "\n";
 128     #use Data::Dumper;
 129
 130     if ($q->[0] eq 'PRED') {
 131         if ($p->[0] eq 'PRED') {
 132                 return Dep::pred_implies($p, $q);
 133         } elsif ($p->[0] eq 'AND') {
 134             $i = 1;
 135             while ($i < @$p) {
 136                 return 1 if Dep::implies($p->[$i++], $q);
 137             }
 138             return 0;
 139         } elsif ($p->[0] eq 'OR') {
 140             $i = 1;
 141             while ($i < @$p) {
 142                 return 0 if not Dep::implies($p->[$i++], $q);
 143             }
 144             return 1;
 145         } elsif ($p->[0] eq 'NOT') {
 146             return Dep::implies_inverse($p->[1], $q);
 147         }
 148     } elsif ($q->[0] eq 'AND') {
 149         # Each of q's clauses must be deduced from p.
 150         $i = 1;
 151         while ($i < @$q) {
 152             return 0 if not Dep::implies($p, $q->[$i++]);
 153         }
 154         return 1;
 155     } elsif ($q->[0] eq 'OR') {
 156         # If p is something other than OR, p needs to satisfy one of the
 157         # clauses of q.  If p is an AND clause, q is satisfied if any of the
 158         # clauses of p satisfy it.
 159         #
 160         # The interesting case is OR.  In this case, do an OR to OR comparison
 161         # to determine if q's clause is a superset of p's clause as follows:
 162         # take each branch of p and see if it satisfies a branch of q.  If
 163         # each branch of p satisfies some branch of q, return 1.  Otherwise,
 164         # return 0.
 165         #
 166         # Simple logic that requires that p satisfy at least one of the
 167         # clauses of q considered in isolation will miss that a|b satisfies
 168         # a|b|c, since a|b doesn't satisfy any of a, b, or c in isolation.
 169         if ($p->[0] eq 'PRED') {
 170             $i = 1;
 171             while ($i < @$q) {
 172                 return 1 if Dep::implies($p, $q->[$i++]);
 173             }
 174             return 0;
 175         } elsif ($p->[0] eq 'AND') {
 176             $i = 1;
 177             while ($i < @$p) {
 178                 return 1 if Dep::implies($p->[$i++], $q);
 179             }
 180             return 0;
 181         } elsif ($p->[0] eq 'OR') {
 182             for ($i = 1; $i < @$p; $i++) {
 183                 my $j = 1;
 184                 my $satisfies = 0;
 185                 while ($j < @$q) {
 186                     if (Dep::implies($p->[$i], $q->[$j++])) {
 187                         $satisfies = 1;
 188                         last;
 189                     }
 190                 }
 191                 return 0 unless $satisfies;
 192             }
 193             return 1;
 194         } elsif ($p->[0] eq 'NOT') {
 195             return Dep::implies_inverse($p->[1], $q);
 196         }
 197     } elsif ($q->[0] eq 'NOT') {
 198         if ($p->[0] eq 'NOT') {
 199             return Dep::implies($q->[1], $p->[1]);
 200         }
 201         return Dep::implies_inverse($p, $q->[1]);
 202     }
 203 }
 204
 205 # Takes two predicate formulas and returns true iff the falsehood of the
 206 # second can be deduced from the truth of the first.
 207 sub implies_inverse {
 208     my ($p, $q) = @_;
 209     my $i;
 210
 211 #    Dep::debugprint($p);
 212 #    warn " |- !";
 213 #    Dep::debugprint($q);
 214 #    warn "\n";
 215
 216     if ($$q[0] eq 'PRED') {
 217         if ($$p[0] eq 'PRED') {
 218             return Dep::pred_implies_inverse($p, $q);
 219         } elsif ($$p[0] eq 'AND') {
 220             # q's falsehood can be deduced from any of p's clauses
 221             $i = 1;
 222             while ($i < @$p) {
 223                 return 1 if Dep::implies_inverse($$p[$i++], $q);
 224             }
 225             return 0;
 226         } elsif ($$p[0] eq 'OR') {
 227             # q's falsehood must be deduced from each of p's clauses
 228             $i = 1;
 229             while ($i < @$p) {
 230                 return 0 if not Dep::implies_inverse($$p[$i++], $q);
 231             }
 232             return 1;
 233         } elsif ($$p[0] eq 'NOT') {
 234             return Dep::implies($q, $$p[1]);
 235         }
 236     } elsif ($$q[0] eq 'AND') {
 237         # Any of q's clauses must be falsified by p.
 238         $i = 1;
 239         while ($i < @$q) {
 240             return 1 if Dep::implies_inverse($p, $$q[$i++]);
 241         }
 242         return 0;
 243     } elsif ($$q[0] eq 'OR') {
 244         # Each of q's clauses must be falsified by p.
 245         $i = 1;
 246         while ($i < @$q) {
 247             return 0 if not Dep::implies_inverse($p, $$q[$i++]);
 248         }
 249         return 1;
 250     } elsif ($$q[0] eq 'NOT') {
 251         return Dep::implies($p, $$q[1]);
 252     }
 253 }
 254
 255 # Takes two predicates and returns true iff the second can be deduced from the
 256 # first.  If the second is falsified by the first (in other words, if p
 257 # actually implies not q), return 0.  Otherwise, return undef.  The 0 return
 258 # is used by pred_implies_inverse.
 259 sub pred_implies {
 260     my ($p, $q) = @_;
 261     # If the names don't match, there is no relationship between them.
 262     $$p[1] ||= ''; $$q[1] ||= '';
 263     return undef if $$p[1] ne $$q[1];
 264
 265     # If the names match, then the only difference is in the architecture or
 266     # version clauses.  First, check architecture.  The architectures for p
 267     # must be a superset of the architectures for q.
 268     my @p_arches = split(' ', $$p[4] || '');
 269     my @q_arches = split(' ', $$q[4] || '');
 270     if (@p_arches || @q_arches) {
 271         my $p_arch_neg = @p_arches && $p_arches[0] =~ /^!/;
 272         my $q_arch_neg = @q_arches && $q_arches[0] =~ /^!/;
 273
 274         # If p has no arches, it is a superset of q and we should fall through
 275         # to the version check.
 276         if (not @p_arches) {
 277             # nothing
 278         }
 279
 280         # If q has no arches, it is a superset of p and there are no useful
 281         # implications.
 282         elsif (not @q_arches) {
 283             return undef;
 284         }
 285
 286         # Both have arches.  If neither are negated, we know nothing useful
 287         # unless q is a subset of p.
 288         elsif (not $p_arch_neg and not $q_arch_neg) {
 289             my %p_arches = map { $_ => 1 } @p_arches;
 290             my $subset = 1;
 291             for my $arch (@q_arches) {
 292                 $subset = 0 unless $p_arches{$arch};
 293             }
 294             return undef unless $subset;
 295         }
 296
 297         # If both are negated, we know nothing useful unless p is a subset of
 298         # q (and therefore has fewer things excluded, and therefore is more
 299         # general).
 300         elsif ($p_arch_neg and $q_arch_neg) {
 301             my %q_arches = map { $_ => 1 } @q_arches;
 302             my $subset = 1;
 303             for my $arch (@p_arches) {
 304                 $subset = 0 unless $q_arches{$arch};
 305             }
 306             return undef unless $subset;
 307         }
 308
 309         # If q is negated and p isn't, we'd need to know the full list of
 310         # arches to know if there's any relationship, so bail.
 311         elsif (not $p_arch_neg and $q_arch_neg) {
 312             return undef;
 313         }
 314
 315         # If p is negated and q isn't, q is a subset of p iff none of the
 316         # negated arches in p are present in q.
 317         elsif ($p_arch_neg and not $q_arch_neg) {
 318             my %q_arches = map { $_ => 1 } @q_arches;
 319             my $subset = 1;
 320             for my $arch (@p_arches) {
 321                 $subset = 0 if $q_arches{substr($arch, 1)};
 322             }
 323             return undef unless $subset;
 324         }
 325     }
 326
 327     # Now, down to version.  The implication is true if p's clause is stronger
 328     # than q's, or is equivalent.
 329
 330     # If q has no version clause, then p's clause is always stronger.
 331     return 1 if not defined $$q[2];
 332
 333     # If q does have a version clause, then p must also have one.
 334     return undef if not defined $$p[2];
 335
 336     # q wants an exact version, so p must provide that exact version.  p
 337     # disproves q if q's version is outside the range enforced by p.
 338     if ($$q[2] eq '=') {
 339         if ($$p[2] eq '<<') {
 340             return Dep::versions_lte($$p[3], $$q[3]) ? 0 : undef;
 341         } elsif ($$p[2] eq '<=') {
 342             return Dep::versions_lt($$p[3], $$q[3]) ? 0 : undef;
 343         } elsif ($$p[2] eq '>>') {
 344             return Dep::versions_gte($$p[3], $$q[3]) ? 0 : undef;
 345         } elsif ($$p[2] eq '>=') {
 346             return Dep::versions_gt($$p[3], $$q[3]) ? 0 : undef;
 347         } elsif ($$p[2] eq '=') {
 348             return Dep::versions_equal($$p[3], $$q[3]);
 349         }
 350     }
 351
 352     # A greater than clause may disprove a less than clause.  Otherwise, if
 353     # p's clause is <<, <=, or =, the version must be <= q's to imply q.
 354     if ($$q[2] eq '<=') {
 355         if ($$p[2] eq '>>') {
 356             return Dep::versions_gte($$p[3], $$q[3]) ? 0 : undef;
 357         } elsif ($$p[2] eq '>=') {
 358             return Dep::versions_gt($$p[3], $$q[3]) ? 0 : undef;
 359         } elsif ($$p[2] eq '=') {
 360             return Dep::versions_lte($$p[3], $$q[3]);
 361         } else {
 362             return Dep::versions_lte($$p[3], $$q[3]) ? 1 : undef;
 363         }
 364     }
 365
 366     # Similar, but << is stronger than <= so p's version must be << q's
 367     # version if the p relation is <= or =.
 368     if ($$q[2] eq '<<') {
 369         if ($$p[2] eq '>>' or $$p[2] eq '>=') {
 370             return Dep::versions_gte($$p[3], $$p[3]) ? 0 : undef;
 371         } elsif ($$p[2] eq '<<') {
 372             return Dep::versions_lte($$p[3], $$q[3]);
 373         } elsif ($$p[2] eq '=') {
 374             return Dep::versions_lt($$p[3], $$q[3]);
 375         } else {
 376             return Dep::versions_lt($$p[3], $$q[3]) ? 1 : undef;
 377         }
 378     }
 379
 380     # Same logic as above, only inverted.
 381     if ($$q[2] eq '>=') {
 382         if ($$p[2] eq '<<') {
 383             return Dep::versions_lte($$p[3], $$q[3]) ? 0 : undef;
 384         } elsif ($$p[2] eq '<=') {
 385             return Dep::versions_lt($$p[3], $$q[3]) ? 0 : undef;
 386         } elsif ($$p[2] eq '=') {
 387             return Dep::versions_gte($$p[3], $$q[3]);
 388         } else {
 389             return Dep::versions_gte($$p[3], $$q[3]) ? 1 : undef;
 390         }
 391     }
 392     if ($$q[2] eq '>>') {
 393         if ($$p[2] eq '<<' or $$p[2] eq '<=') {
 394             return Dep::versions_lte($$p[3], $$q[3]) ? 0 : undef;
 395         } elsif ($$p[2] eq '>>') {
 396             return Dep::versions_gte($$p[3], $$q[3]);
 397         } elsif ($$p[2] eq '=') {
 398             return Dep::versions_gt($$p[3], $$q[3]);
 399         } else {
 400             return Dep::versions_gt($$p[3], $$q[3]) ? 1 : undef;
 401         }
 402     }
 403
 404     return undef;
 405 }
 406
 407 # Takes two predicates and returns true iff the falsehood of the second can be
 408 # deduced from the truth of the first.  In other words, p implies not q, or
 409 # resstated, q implies not p.  (Since if a implies b, not b implies not a.)
 410 sub pred_implies_inverse {
 411     my ($p, $q) = @_;
 412     my $res = Dep::pred_implies($q, $p);
 413
 414     return not $res if defined $res;
 415     return undef;
 416 }
 417
 418 # ---------------------------------
 419 # version routines
 420
 421 my %cached;
 422
 423 sub versions_equal {
 424     my ($p, $q) = @_;
 425     my $res;
 426
 427     return 1 if $p eq $q;
 428     return 1 if $Dep::cached{"$p == $q"};
 429     return 1 if $Dep::cached{"$p <= $q"} and $Dep::cached{"$p >= $q"};
 430     return 0 if $Dep::cached{"$p != $q"};
 431     return 0 if $Dep::cached{"$p << $q"};
 432     return 0 if $Dep::cached{"$p >> $q"};
 433
 434     $res = Dep::get_version_cmp($p, 'eq', $q);
 435
 436     if ($res) {
 437         $Dep::cached{"$p == $q"} = 1;
 438     } else {
 439         $Dep::cached{"$p != $q"} = 1;
 440     }
 441
 442     return $res;
 443 }
 444
 445 sub versions_lte {
 446     my ($p, $q) = @_;
 447     my $res;
 448
 449     return 1 if $p eq $q;
 450     return 1 if $Dep::cached{"$p <= $q"};
 451     return 1 if $Dep::cached{"$p == $q"};
 452     return 1 if $Dep::cached{"$p << $q"};
 453     return 0 if $Dep::cached{"$p >> $q"};
 454     return 0 if $Dep::cached{"$p >= $q"} and $Dep::cached{"$p != $q"};
 455
 456     $res = Dep::get_version_cmp($p, 'le', $q);
 457
 458     if ($res) {
 459         $Dep::cached{"$p <= $q"} = 1;
 460     } else {
 461         $Dep::cached{"$p >> $q"} = 1;
 462     }
 463
 464     return $res;
 465 }
 466
 467 sub versions_gte {
 468     my ($p, $q) = @_;
 469     my $res;
 470
 471     return 1 if $p eq $q;
 472     return 1 if $Dep::cached{"$p >= $q"};
 473     return 1 if $Dep::cached{"$p == $q"};
 474     return 1 if $Dep::cached{"$p >> $q"};
 475     return 0 if $Dep::cached{"$p << $q"};
 476     return 0 if $Dep::cached{"$p <= $q"} and $Dep::cached{"$p != $q"};
 477
 478     $res = Dep::get_version_cmp($p, 'ge', $q);
 479
 480     if ($res) {
 481         $Dep::cached{"$p >= $q"} = 1;
 482     } else {
 483         $Dep::cached{"$p << $q"} = 1;
 484     }
 485
 486     return $res;
 487 }
 488
 489 sub versions_lt {
 490     my ($p, $q) = @_;
 491     my $res;
 492
 493     return 0 if $p eq $q;
 494     return 1 if $Dep::cached{"$p << $q"};
 495     return 0 if $Dep::cached{"$p == $q"};
 496     return 0 if $Dep::cached{"$p >= $q"};
 497     return 0 if $Dep::cached{"$p >> $q"};
 498     return 1 if $Dep::cached{"$p <= $q"} and $Dep::cached{"$p != $q"};
 499
 500     $res = Dep::get_version_cmp($p, 'lt', $q);
 501
 502     if ($res) {
 503         $Dep::cached{"$p << $q"} = 1;
 504     } else {
 505         $Dep::cached{"$p >= $q"} = 1;
 506     }
 507
 508     return $res;
 509 }
 510
 511 sub versions_gt {
 512     my ($p, $q) = @_;
 513     my $res;
 514
 515     return 0 if $p eq $q;
 516     return 1 if $Dep::cached{"$p >> $q"};
 517     return 0 if $Dep::cached{"$p == $q"};
 518     return 0 if $Dep::cached{"$p <= $q"};
 519     return 0 if $Dep::cached{"$p << $q"};
 520     return 1 if $Dep::cached{"$p >= $q"} and $Dep::cached{"$p != $q"};
 521
 522     $res = Dep::get_version_cmp($p, 'gt', $q);
 523
 524     if ($res) {
 525         $Dep::cached{"$p >> $q"} = 1;
 526     } else {
 527         $Dep::cached{"$p <= $q"} = 1;
 528     }
 529
 530     return $res;
 531 }
 532
 533 sub get_version_cmp {
 534     return ::spawn('dpkg', '--compare-versions', @_) == 0;
 535 }
 536
 537 # ---------------------------------
 538
 539 # Return a list of duplicated relations.  Each member of the list will be an
 540 # anonymous array holding the set of relations that are considered duplicated.
 541 # Two relations are considered duplicates if one implies the other.
 542 sub get_dups {
 543     my $p = shift;
 544
 545     if ($p->[0] ne 'AND') {
 546         return ();
 547     }
 548
 549     # The logic here is a bit complex in order to merge sets of duplicate
 550     # dependencies.  We want foo (<< 2), foo (>> 1), foo (= 1.5) to end up as
 551     # one set of dupliactes, even though the first doesn't imply the second.
 552     #
 553     # $dups holds a hash, where the key is the earliest dependency in a set
 554     # and the value is a hash whose keys are the other dependencies in the
 555     # set.  $seen holds a map from package names to the duplicate sets that
 556     # they're part of, if they're not the earliest package in a set.  If
 557     # either of the dependencies in a duplicate pair were already seen, add
 558     # the missing one of the pair to the existing set rather than creating a
 559     # new one.
 560     my (%dups, %seen);
 561     for (my $i = 1; $i < @$p; $i++) {
 562         for (my $j = $i + 1; $j < @$p; $j++) {
 563             if (Dep::implies($p->[$i], $p->[$j]) || Dep::implies($p->[$j], $p->[$i])) {
 564                 my $first = unparse($p->[$i]);
 565                 my $second = unparse($p->[$j]);
 566                 if ($seen{$first}) {
 567                     $dups{$seen{$first}}->{$second} = $j;
 568                     $seen{$second} = $seen{$first};
 569                 } elsif ($seen{$second}) {
 570                     $dups{$seen{$second}}->{$first} = $i;
 571                     $seen{$first} = $seen{$second};
 572                 } else {
 573                     $dups{$first} ||= {};
 574                     $dups{$first}->{$second} = $j;
 575                     $seen{$second} = $first;
 576                 }
 577             }
 578         }
 579     }
 580
 581     # The sort maintains the original order in which we encountered the
 582     # dependencies, just in case that helps the user find the problems,
 583     # despite the fact we're using a hash.
 584     return map {
 585         [ $_,
 586           sort {
 587               $dups{$_}->{$a} <=> $dups{$_}->{$b}
 588           } keys %{ $dups{$_} }
 589         ]
 590     } keys %dups;
 591 }
 592
 593 # ---------------------------------
 594
 595 sub debugprint {
 596     my $x;
 597     my $i;
 598
 599     for $x (@_) {
 600         if ($$x[0] eq 'PRED') {
 601             if (@$x == 2) {
 602                 warn "PRED($$x[1])";
 603             } else {
 604                 warn "PRED($$x[1] $$x[2] $$x[3])";
 605             }
 606         } else {
 607             warn "$$x[0](";
 608             $i = 1;
 609             while ($i < @$x) {
 610                 Dep::debugprint($$x[$i++]);
 611                 warn ", " if ($i < @$x);
 612             }
 613             warn ")";
 614         }
 615      }
 616 }
 617
 618 1;
 619
 620 # Local Variables:
 621 # indent-tabs-mode: t
 622 # cperl-indent-level: 4
 623 # End:
 624 # vim: syntax=perl sw=4 ts=8