| OLD | NEW |
|---|
| (Empty) |
| 1 # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> | |
| 2 # Copyright © 2012 Guillem Jover <guillem@debian.org> | |
| 3 # | |
| 4 # This program is free software; you may redistribute it and/or modify | |
| 5 # it under the terms of the GNU General Public License as published by | |
| 6 # the Free Software Foundation; either version 2 of the License, or | |
| 7 # (at your option) any later version. | |
| 8 # | |
| 9 # This is distributed in the hope that it will be useful, | |
| 10 # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 12 # GNU General Public License for more details. | |
| 13 # | |
| 14 # You should have received a copy of the GNU General Public License | |
| 15 # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
| 16 ######################################################################### | |
| 17 # Several parts are inspired by lib/Dep.pm from lintian (same license) | |
| 18 # | |
| 19 # Copyright © 1998 Richard Braakman | |
| 20 # Portions Copyright © 1999 Darren Benham | |
| 21 # Portions Copyright © 2000 Sean 'Shaleh' Perry | |
| 22 # Portions Copyright © 2004 Frank Lichtenheld | |
| 23 # Portions Copyright © 2006 Russ Allbery | |
| 24 | |
| 25 package Dpkg::Deps; | |
| 26 | |
| 27 =encoding utf8 | |
| 28 | |
| 29 =head1 NAME | |
| 30 | |
| 31 Dpkg::Deps - parse and manipulate dependencies of Debian packages | |
| 32 | |
| 33 =head1 DESCRIPTION | |
| 34 | |
| 35 The Dpkg::Deps module provides objects implementing various types of | |
| 36 dependencies. | |
| 37 | |
| 38 The most important function is deps_parse(), it turns a dependency line in | |
| 39 a set of Dpkg::Deps::{Simple,AND,OR,Union} objects depending on the case. | |
| 40 | |
| 41 =head1 FUNCTIONS | |
| 42 | |
| 43 All the deps_* functions are exported by default. | |
| 44 | |
| 45 =over 4 | |
| 46 | |
| 47 =cut | |
| 48 | |
| 49 use strict; | |
| 50 use warnings; | |
| 51 | |
| 52 our $VERSION = '1.02'; | |
| 53 | |
| 54 use Dpkg::Version; | |
| 55 use Dpkg::Arch qw(get_host_arch get_build_arch); | |
| 56 use Dpkg::BuildProfiles qw(get_build_profiles); | |
| 57 use Dpkg::ErrorHandling; | |
| 58 use Dpkg::Gettext; | |
| 59 | |
| 60 use Exporter qw(import); | |
| 61 our @EXPORT = qw(deps_concat deps_parse deps_eval_implication deps_compare); | |
| 62 | |
| 63 =item deps_eval_implication($rel_p, $v_p, $rel_q, $v_q) | |
| 64 | |
| 65 ($rel_p, $v_p) and ($rel_q, $v_q) express two dependencies as (relation, | |
| 66 version). The relation variable can have the following values that are | |
| 67 exported by Dpkg::Version: REL_EQ, REL_LT, REL_LE, REL_GT, REL_GT. | |
| 68 | |
| 69 This functions returns 1 if the "p" dependency implies the "q" | |
| 70 dependency. It returns 0 if the "p" dependency implies that "q" is | |
| 71 not satisfied. It returns undef when there's no implication. | |
| 72 | |
| 73 The $v_p and $v_q parameter should be Dpkg::Version objects. | |
| 74 | |
| 75 =cut | |
| 76 | |
| 77 sub deps_eval_implication { | |
| 78 my ($rel_p, $v_p, $rel_q, $v_q) = @_; | |
| 79 | |
| 80 # If versions are not valid, we can't decide of any implication | |
| 81 return unless defined($v_p) and $v_p->is_valid(); | |
| 82 return unless defined($v_q) and $v_q->is_valid(); | |
| 83 | |
| 84 # q wants an exact version, so p must provide that exact version. p | |
| 85 # disproves q if q's version is outside the range enforced by p. | |
| 86 if ($rel_q eq REL_EQ) { | |
| 87 if ($rel_p eq REL_LT) { | |
| 88 return ($v_p <= $v_q) ? 0 : undef; | |
| 89 } elsif ($rel_p eq REL_LE) { | |
| 90 return ($v_p < $v_q) ? 0 : undef; | |
| 91 } elsif ($rel_p eq REL_GT) { | |
| 92 return ($v_p >= $v_q) ? 0 : undef; | |
| 93 } elsif ($rel_p eq REL_GE) { | |
| 94 return ($v_p > $v_q) ? 0 : undef; | |
| 95 } elsif ($rel_p eq REL_EQ) { | |
| 96 return ($v_p == $v_q); | |
| 97 } | |
| 98 } | |
| 99 | |
| 100 # A greater than clause may disprove a less than clause. An equal | |
| 101 # cause might as well. Otherwise, if | |
| 102 # p's clause is <<, <=, or =, the version must be <= q's to imply q. | |
| 103 if ($rel_q eq REL_LE) { | |
| 104 if ($rel_p eq REL_GT) { | |
| 105 return ($v_p >= $v_q) ? 0 : undef; | |
| 106 } elsif ($rel_p eq REL_GE) { | |
| 107 return ($v_p > $v_q) ? 0 : undef; | |
| 108 } elsif ($rel_p eq REL_EQ) { | |
| 109 return ($v_p <= $v_q) ? 1 : 0; | |
| 110 } else { # <<, <= | |
| 111 return ($v_p <= $v_q) ? 1 : undef; | |
| 112 } | |
| 113 } | |
| 114 | |
| 115 # Similar, but << is stronger than <= so p's version must be << q's | |
| 116 # version if the p relation is <= or =. | |
| 117 if ($rel_q eq REL_LT) { | |
| 118 if ($rel_p eq REL_GT or $rel_p eq REL_GE) { | |
| 119 return ($v_p >= $v_p) ? 0 : undef; | |
| 120 } elsif ($rel_p eq REL_LT) { | |
| 121 return ($v_p <= $v_q) ? 1 : undef; | |
| 122 } elsif ($rel_p eq REL_EQ) { | |
| 123 return ($v_p < $v_q) ? 1 : 0; | |
| 124 } else { # <<, <= | |
| 125 return ($v_p < $v_q) ? 1 : undef; | |
| 126 } | |
| 127 } | |
| 128 | |
| 129 # Same logic as above, only inverted. | |
| 130 if ($rel_q eq REL_GE) { | |
| 131 if ($rel_p eq REL_LT) { | |
| 132 return ($v_p <= $v_q) ? 0 : undef; | |
| 133 } elsif ($rel_p eq REL_LE) { | |
| 134 return ($v_p < $v_q) ? 0 : undef; | |
| 135 } elsif ($rel_p eq REL_EQ) { | |
| 136 return ($v_p >= $v_q) ? 1 : 0; | |
| 137 } else { # >>, >= | |
| 138 return ($v_p >= $v_q) ? 1 : undef; | |
| 139 } | |
| 140 } | |
| 141 if ($rel_q eq REL_GT) { | |
| 142 if ($rel_p eq REL_LT or $rel_p eq REL_LE) { | |
| 143 return ($v_p <= $v_q) ? 0 : undef; | |
| 144 } elsif ($rel_p eq REL_GT) { | |
| 145 return ($v_p >= $v_q) ? 1 : undef; | |
| 146 } elsif ($rel_p eq REL_EQ) { | |
| 147 return ($v_p > $v_q) ? 1 : 0; | |
| 148 } else { | |
| 149 return ($v_p > $v_q) ? 1 : undef; | |
| 150 } | |
| 151 } | |
| 152 | |
| 153 return; | |
| 154 } | |
| 155 | |
| 156 =item my $dep = deps_concat(@dep_list) | |
| 157 | |
| 158 This function concatenates multiple dependency lines into a single line, | |
| 159 joining them with ", " if appropriate, and always returning a valid string. | |
| 160 | |
| 161 =cut | |
| 162 | |
| 163 sub deps_concat { | |
| 164 my (@dep_list) = @_; | |
| 165 | |
| 166 return join(', ', grep { defined $_ } @dep_list); | |
| 167 } | |
| 168 | |
| 169 =item my $dep = deps_parse($line, %options) | |
| 170 | |
| 171 This function parses the dependency line and returns an object, either a | |
| 172 Dpkg::Deps::AND or a Dpkg::Deps::Union. Various options can alter the | |
| 173 behaviour of that function. | |
| 174 | |
| 175 =over 4 | |
| 176 | |
| 177 =item use_arch (defaults to 1) | |
| 178 | |
| 179 Take into account the architecture restriction part of the dependencies. | |
| 180 Set to 0 to completely ignore that information. | |
| 181 | |
| 182 =item host_arch (defaults to the current architecture) | |
| 183 | |
| 184 Define the host architecture. By default it uses | |
| 185 Dpkg::Arch::get_host_arch() to identify the proper architecture. | |
| 186 | |
| 187 =item build_arch (defaults to the current architecture) | |
| 188 | |
| 189 Define the build architecture. By default it uses | |
| 190 Dpkg::Arch::get_build_arch() to identify the proper architecture. | |
| 191 | |
| 192 =item reduce_arch (defaults to 0) | |
| 193 | |
| 194 If set to 1, ignore dependencies that do not concern the current host | |
| 195 architecture. This implicitely strips off the architecture restriction | |
| 196 list so that the resulting dependencies are directly applicable to the | |
| 197 current architecture. | |
| 198 | |
| 199 =item use_profiles (defaults to 1) | |
| 200 | |
| 201 Take into account the profile restriction part of the dependencies. Set | |
| 202 to 0 to completely ignore that information. | |
| 203 | |
| 204 =item build_profiles (defaults to no profile) | |
| 205 | |
| 206 Define the active build profiles. By default no profile is defined. | |
| 207 | |
| 208 =item reduce_profiles (defaults to 0) | |
| 209 | |
| 210 If set to 1, ignore dependencies that do not concern the current build | |
| 211 profile. This implicitly strips off the profile restriction list so | |
| 212 that the resulting dependencies are directly applicable to the current | |
| 213 profiles. | |
| 214 | |
| 215 =item reduce_restrictions (defaults to 0) | |
| 216 | |
| 217 If set to 1, ignore dependencies that do not concern the current set of | |
| 218 restrictions. This implicitly strips off any restriction list so that the | |
| 219 resulting dependencies are directly applicable to the current restriction. | |
| 220 This currently implies C<reduce_arch> and C<reduce_profiles>, and overrides | |
| 221 them if set. | |
| 222 | |
| 223 =item union (defaults to 0) | |
| 224 | |
| 225 If set to 1, returns a Dpkg::Deps::Union instead of a Dpkg::Deps::AND. Use | |
| 226 this when parsing non-dependency fields like Conflicts. | |
| 227 | |
| 228 =item build_dep (defaults to 0) | |
| 229 | |
| 230 If set to 1, allow build-dep only arch qualifiers, that is “:native”. | |
| 231 This should be set whenever working with build-deps. | |
| 232 | |
| 233 =back | |
| 234 | |
| 235 =cut | |
| 236 | |
| 237 sub deps_parse { | |
| 238 my $dep_line = shift; | |
| 239 my %options = (@_); | |
| 240 $options{use_arch} = 1 if not exists $options{use_arch}; | |
| 241 $options{reduce_arch} = 0 if not exists $options{reduce_arch}; | |
| 242 $options{host_arch} = get_host_arch() if not exists $options{host_arch}; | |
| 243 $options{build_arch} = get_build_arch() if not exists $options{build_arch}; | |
| 244 $options{use_profiles} = 1 if not exists $options{use_profiles}; | |
| 245 $options{reduce_profiles} = 0 if not exists $options{reduce_profiles}; | |
| 246 $options{build_profiles} = [ get_build_profiles() ] | |
| 247 if not exists $options{build_profiles}; | |
| 248 $options{reduce_restrictions} = 0 if not exists $options{reduce_restrictions
}; | |
| 249 $options{union} = 0 if not exists $options{union}; | |
| 250 $options{build_dep} = 0 if not exists $options{build_dep}; | |
| 251 | |
| 252 if ($options{reduce_restrictions}) { | |
| 253 $options{reduce_arch} = 1; | |
| 254 $options{reduce_profiles} = 1; | |
| 255 } | |
| 256 | |
| 257 # Strip trailing/leading spaces | |
| 258 $dep_line =~ s/^\s+//; | |
| 259 $dep_line =~ s/\s+$//; | |
| 260 | |
| 261 my @dep_list; | |
| 262 foreach my $dep_and (split(/\s*,\s*/m, $dep_line)) { | |
| 263 my @or_list = (); | |
| 264 foreach my $dep_or (split(/\s*\|\s*/m, $dep_and)) { | |
| 265 my $dep_simple = Dpkg::Deps::Simple->new($dep_or, host_arch => | |
| 266 $options{host_arch}, | |
| 267 build_arch => | |
| 268 $options{build_arch}, | |
| 269 build_dep => | |
| 270 $options{build_dep}); | |
| 271 if (not defined $dep_simple->{package}) { | |
| 272 warning(_g("can't parse dependency %s"), $dep_or); | |
| 273 return; | |
| 274 } | |
| 275 $dep_simple->{arches} = undef if not $options{use_arch}; | |
| 276 if ($options{reduce_arch}) { | |
| 277 $dep_simple->reduce_arch($options{host_arch}); | |
| 278 next if not $dep_simple->arch_is_concerned($options{host_arch}); | |
| 279 } | |
| 280 $dep_simple->{restrictions} = undef if not $options{use_profiles}; | |
| 281 if ($options{reduce_profiles}) { | |
| 282 $dep_simple->reduce_profiles($options{build_profiles}); | |
| 283 next if not $dep_simple->profile_is_concerned($options{build_pro
files}); | |
| 284 } | |
| 285 push @or_list, $dep_simple; | |
| 286 } | |
| 287 next if not @or_list; | |
| 288 if (scalar @or_list == 1) { | |
| 289 push @dep_list, $or_list[0]; | |
| 290 } else { | |
| 291 my $dep_or = Dpkg::Deps::OR->new(); | |
| 292 $dep_or->add($_) foreach (@or_list); | |
| 293 push @dep_list, $dep_or; | |
| 294 } | |
| 295 } | |
| 296 my $dep_and; | |
| 297 if ($options{union}) { | |
| 298 $dep_and = Dpkg::Deps::Union->new(); | |
| 299 } else { | |
| 300 $dep_and = Dpkg::Deps::AND->new(); | |
| 301 } | |
| 302 foreach my $dep (@dep_list) { | |
| 303 if ($options{union} and not $dep->isa('Dpkg::Deps::Simple')) { | |
| 304 warning(_g('an union dependency can only contain simple dependencies
')); | |
| 305 return; | |
| 306 } | |
| 307 $dep_and->add($dep); | |
| 308 } | |
| 309 return $dep_and; | |
| 310 } | |
| 311 | |
| 312 =item deps_compare($a, $b) | |
| 313 | |
| 314 Implements a comparison operator between two dependency objects. | |
| 315 This function is mainly used to implement the sort() method. | |
| 316 | |
| 317 =back | |
| 318 | |
| 319 =cut | |
| 320 | |
| 321 my %relation_ordering = ( | |
| 322 undef => 0, | |
| 323 REL_GE() => 1, | |
| 324 REL_GT() => 2, | |
| 325 REL_EQ() => 3, | |
| 326 REL_LT() => 4, | |
| 327 REL_LE() => 5, | |
| 328 ); | |
| 329 | |
| 330 sub deps_compare { | |
| 331 my ($a, $b) = @_; | |
| 332 return -1 if $a->is_empty(); | |
| 333 return 1 if $b->is_empty(); | |
| 334 while ($a->isa('Dpkg::Deps::Multiple')) { | |
| 335 return -1 if $a->is_empty(); | |
| 336 my @deps = $a->get_deps(); | |
| 337 $a = $deps[0]; | |
| 338 } | |
| 339 while ($b->isa('Dpkg::Deps::Multiple')) { | |
| 340 return 1 if $b->is_empty(); | |
| 341 my @deps = $b->get_deps(); | |
| 342 $b = $deps[0]; | |
| 343 } | |
| 344 my $ar = defined($a->{relation}) ? $a->{relation} : 'undef'; | |
| 345 my $br = defined($b->{relation}) ? $b->{relation} : 'undef'; | |
| 346 return (($a->{package} cmp $b->{package}) || | |
| 347 ($relation_ordering{$ar} <=> $relation_ordering{$br}) || | |
| 348 ($a->{version} cmp $b->{version})); | |
| 349 } | |
| 350 | |
| 351 | |
| 352 package Dpkg::Deps::Simple; | |
| 353 | |
| 354 =head1 OBJECTS - Dpkg::Deps::* | |
| 355 | |
| 356 There are several kind of dependencies. A Dpkg::Deps::Simple dependency | |
| 357 represents a single dependency statement (it relates to one package only). | |
| 358 Dpkg::Deps::Multiple dependencies are built on top of this object | |
| 359 and combine several dependencies in a different manners. Dpkg::Deps::AND | |
| 360 represents the logical "AND" between dependencies while Dpkg::Deps::OR | |
| 361 represents the logical "OR". Dpkg::Deps::Multiple objects can contain | |
| 362 Dpkg::Deps::Simple object as well as other Dpkg::Deps::Multiple objects. | |
| 363 | |
| 364 In practice, the code is only meant to handle the realistic cases which, | |
| 365 given Debian's dependencies structure, imply those restrictions: AND can | |
| 366 contain Simple or OR objects, OR can only contain Simple objects. | |
| 367 | |
| 368 Dpkg::Deps::KnownFacts is a special object that is used while evaluating | |
| 369 dependencies and while trying to simplify them. It represents a set of | |
| 370 installed packages along with the virtual packages that they might | |
| 371 provide. | |
| 372 | |
| 373 =head2 COMMON FUNCTIONS | |
| 374 | |
| 375 =over 4 | |
| 376 | |
| 377 =item $dep->is_empty() | |
| 378 | |
| 379 Returns true if the dependency is empty and doesn't contain any useful | |
| 380 information. This is true when a Dpkg::Deps::Simple object has not yet | |
| 381 been initialized or when a (descendant of) Dpkg::Deps::Multiple contains | |
| 382 an empty list of dependencies. | |
| 383 | |
| 384 =item $dep->get_deps() | |
| 385 | |
| 386 Returns a list of sub-dependencies. For Dpkg::Deps::Simple it returns | |
| 387 itself. | |
| 388 | |
| 389 =item $dep->output([$fh]) | |
| 390 | |
| 391 =item "$dep" | |
| 392 | |
| 393 Returns a string representing the dependency. If $fh is set, it prints | |
| 394 the string to the filehandle. | |
| 395 | |
| 396 =item $dep->implies($other_dep) | |
| 397 | |
| 398 Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies | |
| 399 NOT($other_dep). Returns undef when there's no implication. $dep and | |
| 400 $other_dep do not need to be of the same type. | |
| 401 | |
| 402 =item $dep->sort() | |
| 403 | |
| 404 Sorts alphabetically the internal list of dependencies. It's a no-op for | |
| 405 Dpkg::Deps::Simple objects. | |
| 406 | |
| 407 =item $dep->arch_is_concerned($arch) | |
| 408 | |
| 409 Returns true if the dependency applies to the indicated architecture. For | |
| 410 multiple dependencies, it returns true if at least one of the | |
| 411 sub-dependencies apply to this architecture. | |
| 412 | |
| 413 =item $dep->reduce_arch($arch) | |
| 414 | |
| 415 Simplifies the dependency to contain only information relevant to the given | |
| 416 architecture. A Dpkg::Deps::Simple object can be left empty after this | |
| 417 operation. For Dpkg::Deps::Multiple objects, the non-relevant | |
| 418 sub-dependencies are simply removed. | |
| 419 | |
| 420 This trims off the architecture restriction list of Dpkg::Deps::Simple | |
| 421 objects. | |
| 422 | |
| 423 =item $dep->get_evaluation($facts) | |
| 424 | |
| 425 Evaluates the dependency given a list of installed packages and a list of | |
| 426 virtual packages provided. Those lists are part of the | |
| 427 Dpkg::Deps::KnownFacts object given as parameters. | |
| 428 | |
| 429 Returns 1 when it's true, 0 when it's false, undef when some information | |
| 430 is lacking to conclude. | |
| 431 | |
| 432 =item $dep->simplify_deps($facts, @assumed_deps) | |
| 433 | |
| 434 Simplifies the dependency as much as possible given the list of facts (see | |
| 435 object Dpkg::Deps::KnownFacts) and a list of other dependencies that are | |
| 436 known to be true. | |
| 437 | |
| 438 =item $dep->has_arch_restriction() | |
| 439 | |
| 440 For a simple dependency, returns the package name if the dependency | |
| 441 applies only to a subset of architectures. For multiple dependencies, it | |
| 442 returns the list of package names that have such a restriction. | |
| 443 | |
| 444 =item $dep->reset() | |
| 445 | |
| 446 Clears any dependency information stored in $dep so that $dep->is_empty() | |
| 447 returns true. | |
| 448 | |
| 449 =back | |
| 450 | |
| 451 =head2 Dpkg::Deps::Simple | |
| 452 | |
| 453 Such an object has four interesting properties: | |
| 454 | |
| 455 =over 4 | |
| 456 | |
| 457 =item package | |
| 458 | |
| 459 The package name (can be undef if the dependency has not been initialized | |
| 460 or if the simplification of the dependency lead to its removal). | |
| 461 | |
| 462 =item relation | |
| 463 | |
| 464 The relational operator: "=", "<<", "<=", ">=" or ">>". It can be | |
| 465 undefined if the dependency had no version restriction. In that case the | |
| 466 following field is also undefined. | |
| 467 | |
| 468 =item version | |
| 469 | |
| 470 The version. | |
| 471 | |
| 472 =item arches | |
| 473 | |
| 474 The list of architectures where this dependency is applicable. It's | |
| 475 undefined when there's no restriction, otherwise it's an | |
| 476 array ref. It can contain an exclusion list, in that case each | |
| 477 architecture is prefixed with an exclamation mark. | |
| 478 | |
| 479 =item archqual | |
| 480 | |
| 481 The arch qualifier of the dependency (can be undef if there's none). | |
| 482 In the dependency "python:any (>= 2.6)", the arch qualifier is "any". | |
| 483 | |
| 484 =back | |
| 485 | |
| 486 =head3 METHODS | |
| 487 | |
| 488 =over 4 | |
| 489 | |
| 490 =item $simple_dep->parse_string('dpkg-dev (>= 1.14.8) [!hurd-i386]') | |
| 491 | |
| 492 Parses the dependency and modifies internal properties to match the parsed | |
| 493 dependency. | |
| 494 | |
| 495 =item $simple_dep->merge_union($other_dep) | |
| 496 | |
| 497 Returns true if $simple_dep could be modified to represent the union of | |
| 498 both dependencies. Otherwise returns false. | |
| 499 | |
| 500 =back | |
| 501 | |
| 502 =cut | |
| 503 | |
| 504 use strict; | |
| 505 use warnings; | |
| 506 | |
| 507 use Carp; | |
| 508 | |
| 509 use Dpkg::Arch qw(debarch_is); | |
| 510 use Dpkg::Version; | |
| 511 use Dpkg::ErrorHandling; | |
| 512 use Dpkg::Gettext; | |
| 513 use Dpkg::Util qw(:list); | |
| 514 | |
| 515 use parent qw(Dpkg::Interface::Storable); | |
| 516 | |
| 517 sub new { | |
| 518 my ($this, $arg, %opts) = @_; | |
| 519 my $class = ref($this) || $this; | |
| 520 my $self = {}; | |
| 521 bless $self, $class; | |
| 522 $self->reset(); | |
| 523 $self->{host_arch} = $opts{host_arch} || Dpkg::Arch::get_host_arch(); | |
| 524 $self->{build_arch} = $opts{build_arch} || Dpkg::Arch::get_build_arch(); | |
| 525 $self->{build_dep} = $opts{build_dep} || 0; | |
| 526 $self->parse_string($arg) if defined($arg); | |
| 527 return $self; | |
| 528 } | |
| 529 | |
| 530 sub reset { | |
| 531 my ($self) = @_; | |
| 532 $self->{package} = undef; | |
| 533 $self->{relation} = undef; | |
| 534 $self->{version} = undef; | |
| 535 $self->{arches} = undef; | |
| 536 $self->{archqual} = undef; | |
| 537 $self->{restrictions} = undef; | |
| 538 } | |
| 539 | |
| 540 sub parse { | |
| 541 my ($self, $fh, $desc) = @_; | |
| 542 my $line = <$fh>; | |
| 543 chomp($line); | |
| 544 return $self->parse_string($line); | |
| 545 } | |
| 546 | |
| 547 sub parse_string { | |
| 548 my ($self, $dep) = @_; | |
| 549 return if not $dep =~ | |
| 550 m{^\s* # skip leading whitespace | |
| 551 ([a-zA-Z0-9][a-zA-Z0-9+.-]*) # package name | |
| 552 (?: # start of optional part | |
| 553 : # colon for architecture | |
| 554 ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name | |
| 555 )? # end of optional part | |
| 556 (?: # start of optional part | |
| 557 \s* \( # open parenthesis for version part | |
| 558 \s* (<<|<=|=|>=|>>|<|>) # relation part | |
| 559 \s* (.*?) # do not attempt to parse version | |
| 560 \s* \) # closing parenthesis | |
| 561 )? # end of optional part | |
| 562 (?: # start of optional architecture | |
| 563 \s* \[ # open bracket for architecture | |
| 564 \s* (.*?) # don't parse architectures now | |
| 565 \s* \] # closing bracket | |
| 566 )? # end of optional architecture | |
| 567 (?: # start of optional restriction | |
| 568 \s* < # open bracket for restriction | |
| 569 \s* (.*?) # don't parse restrictions now | |
| 570 \s* > # closing bracket | |
| 571 )? # end of optional restriction | |
| 572 \s*$ # trailing spaces at end | |
| 573 }x; | |
| 574 if (defined($2)) { | |
| 575 return if $2 eq 'native' and not $self->{build_dep}; | |
| 576 $self->{archqual} = $2; | |
| 577 } | |
| 578 $self->{package} = $1; | |
| 579 $self->{relation} = version_normalize_relation($3) if defined($3); | |
| 580 if (defined($4)) { | |
| 581 $self->{version} = Dpkg::Version->new($4); | |
| 582 } | |
| 583 if (defined($5)) { | |
| 584 $self->{arches} = [ split(/\s+/, $5) ]; | |
| 585 } | |
| 586 if (defined($6)) { | |
| 587 $self->{restrictions} = [ map { lc } split /\s+/, $6 ]; | |
| 588 } | |
| 589 } | |
| 590 | |
| 591 sub output { | |
| 592 my ($self, $fh) = @_; | |
| 593 my $res = $self->{package}; | |
| 594 if (defined($self->{archqual})) { | |
| 595 $res .= ':' . $self->{archqual}; | |
| 596 } | |
| 597 if (defined($self->{relation})) { | |
| 598 $res .= ' (' . $self->{relation} . ' ' . $self->{version} . ')'; | |
| 599 } | |
| 600 if (defined($self->{arches})) { | |
| 601 $res .= ' [' . join(' ', @{$self->{arches}}) . ']'; | |
| 602 } | |
| 603 if (defined($self->{restrictions})) { | |
| 604 $res .= ' <' . join(' ', @{$self->{restrictions}}) . '>'; | |
| 605 } | |
| 606 if (defined($fh)) { | |
| 607 print { $fh } $res; | |
| 608 } | |
| 609 return $res; | |
| 610 } | |
| 611 | |
| 612 # _arch_is_superset(\@p, \@q) | |
| 613 # | |
| 614 # Returns true if the arch list @p is a superset of arch list @q. | |
| 615 # The arguments can also be undef in case there's no explicit architecture | |
| 616 # restriction. | |
| 617 sub _arch_is_superset { | |
| 618 my ($p, $q) = @_; | |
| 619 my $p_arch_neg = defined($p) && $p->[0] =~ /^!/; | |
| 620 my $q_arch_neg = defined($q) && $q->[0] =~ /^!/; | |
| 621 | |
| 622 # If "p" has no arches, it is a superset of q and we should fall through | |
| 623 # to the version check. | |
| 624 if (not defined $p) { | |
| 625 return 1; | |
| 626 } | |
| 627 | |
| 628 # If q has no arches, it is a superset of p and there are no useful | |
| 629 # implications. | |
| 630 elsif (not defined $q) { | |
| 631 return 0; | |
| 632 } | |
| 633 | |
| 634 # Both have arches. If neither are negated, we know nothing useful | |
| 635 # unless q is a subset of p. | |
| 636 elsif (not $p_arch_neg and not $q_arch_neg) { | |
| 637 my %p_arches = map { $_ => 1 } @{$p}; | |
| 638 my $subset = 1; | |
| 639 for my $arch (@{$q}) { | |
| 640 $subset = 0 unless $p_arches{$arch}; | |
| 641 } | |
| 642 return 0 unless $subset; | |
| 643 } | |
| 644 | |
| 645 # If both are negated, we know nothing useful unless p is a subset of | |
| 646 # q (and therefore has fewer things excluded, and therefore is more | |
| 647 # general). | |
| 648 elsif ($p_arch_neg and $q_arch_neg) { | |
| 649 my %q_arches = map { $_ => 1 } @{$q}; | |
| 650 my $subset = 1; | |
| 651 for my $arch (@{$p}) { | |
| 652 $subset = 0 unless $q_arches{$arch}; | |
| 653 } | |
| 654 return 0 unless $subset; | |
| 655 } | |
| 656 | |
| 657 # If q is negated and p isn't, we'd need to know the full list of | |
| 658 # arches to know if there's any relationship, so bail. | |
| 659 elsif (not $p_arch_neg and $q_arch_neg) { | |
| 660 return 0; | |
| 661 } | |
| 662 | |
| 663 # If p is negated and q isn't, q is a subset of p if none of the | |
| 664 # negated arches in p are present in q. | |
| 665 elsif ($p_arch_neg and not $q_arch_neg) { | |
| 666 my %q_arches = map { $_ => 1 } @{$q}; | |
| 667 my $subset = 1; | |
| 668 for my $arch (@{$p}) { | |
| 669 $subset = 0 if $q_arches{substr($arch, 1)}; | |
| 670 } | |
| 671 return 0 unless $subset; | |
| 672 } | |
| 673 return 1; | |
| 674 } | |
| 675 | |
| 676 # _arch_qualifier_allows_implication($p, $q) | |
| 677 # | |
| 678 # Returns true if the arch qualifier $p and $q are compatible with the | |
| 679 # implication $p -> $q, false otherwise. $p/$q can be | |
| 680 # undef/"any"/"native" or an architecture string. | |
| 681 sub _arch_qualifier_allows_implication { | |
| 682 my ($p, $q) = @_; | |
| 683 if (defined $p and $p eq 'any') { | |
| 684 return 1 if defined $q and $q eq 'any'; | |
| 685 return 0; | |
| 686 } elsif (defined $p and $p eq 'native') { | |
| 687 return 1 if defined $q and ($q eq 'any' or $q eq 'native'); | |
| 688 return 0; | |
| 689 } elsif (defined $p) { | |
| 690 return 1 if defined $q and ($p eq $q or $q eq 'any'); | |
| 691 return 0; | |
| 692 } else { | |
| 693 return 0 if defined $q and $q ne 'any' and $q ne 'native'; | |
| 694 return 1; | |
| 695 } | |
| 696 } | |
| 697 | |
| 698 # Returns true if the dependency in parameter can deduced from the current | |
| 699 # dependency. Returns false if it can be negated. Returns undef if nothing | |
| 700 # can be concluded. | |
| 701 sub implies { | |
| 702 my ($self, $o) = @_; | |
| 703 if ($o->isa('Dpkg::Deps::Simple')) { | |
| 704 # An implication is only possible on the same package | |
| 705 return if $self->{package} ne $o->{package}; | |
| 706 | |
| 707 # Our architecture set must be a superset of the architectures for | |
| 708 # o, otherwise we can't conclude anything. | |
| 709 return unless _arch_is_superset($self->{arches}, $o->{arches}); | |
| 710 | |
| 711 # The arch qualifier must not forbid an implication | |
| 712 return unless _arch_qualifier_allows_implication($self->{archqual}, | |
| 713 $o->{archqual}); | |
| 714 | |
| 715 # If o has no version clause, then our dependency is stronger | |
| 716 return 1 if not defined $o->{relation}; | |
| 717 # If o has a version clause, we must also have one, otherwise there | |
| 718 # can't be an implication | |
| 719 return if not defined $self->{relation}; | |
| 720 | |
| 721 return Dpkg::Deps::deps_eval_implication($self->{relation}, | |
| 722 $self->{version}, $o->{relation}, $o->{version}); | |
| 723 | |
| 724 } elsif ($o->isa('Dpkg::Deps::AND')) { | |
| 725 # TRUE: Need to imply all individual elements | |
| 726 # FALSE: Need to NOT imply at least one individual element | |
| 727 my $res = 1; | |
| 728 foreach my $dep ($o->get_deps()) { | |
| 729 my $implication = $self->implies($dep); | |
| 730 unless (defined($implication) && $implication == 1) { | |
| 731 $res = $implication; | |
| 732 last if defined $res; | |
| 733 } | |
| 734 } | |
| 735 return $res; | |
| 736 } elsif ($o->isa('Dpkg::Deps::OR')) { | |
| 737 # TRUE: Need to imply at least one individual element | |
| 738 # FALSE: Need to not apply all individual elements | |
| 739 # UNDEF: The rest | |
| 740 my $res = undef; | |
| 741 foreach my $dep ($o->get_deps()) { | |
| 742 my $implication = $self->implies($dep); | |
| 743 if (defined($implication)) { | |
| 744 if (not defined $res) { | |
| 745 $res = $implication; | |
| 746 } else { | |
| 747 if ($implication) { | |
| 748 $res = 1; | |
| 749 } else { | |
| 750 $res = 0; | |
| 751 } | |
| 752 } | |
| 753 last if defined($res) && $res == 1; | |
| 754 } | |
| 755 } | |
| 756 return $res; | |
| 757 } else { | |
| 758 croak 'Dpkg::Deps::Simple cannot evaluate implication with a ' . | |
| 759 ref($o); | |
| 760 } | |
| 761 } | |
| 762 | |
| 763 sub get_deps { | |
| 764 my $self = shift; | |
| 765 return $self; | |
| 766 } | |
| 767 | |
| 768 sub sort { | |
| 769 # Nothing to sort | |
| 770 } | |
| 771 | |
| 772 sub arch_is_concerned { | |
| 773 my ($self, $host_arch) = @_; | |
| 774 | |
| 775 return 0 if not defined $self->{package}; # Empty dep | |
| 776 return 1 if not defined $self->{arches}; # Dep without arch spec | |
| 777 | |
| 778 my $seen_arch = 0; | |
| 779 foreach my $arch (@{$self->{arches}}) { | |
| 780 $arch=lc($arch); | |
| 781 | |
| 782 if ($arch =~ /^!/) { | |
| 783 my $not_arch = $arch; | |
| 784 $not_arch =~ s/^!//; | |
| 785 | |
| 786 if (debarch_is($host_arch, $not_arch)) { | |
| 787 $seen_arch = 0; | |
| 788 last; | |
| 789 } else { | |
| 790 # !arch includes by default all other arches | |
| 791 # unless they also appear in a !otherarch | |
| 792 $seen_arch = 1; | |
| 793 } | |
| 794 } elsif (debarch_is($host_arch, $arch)) { | |
| 795 $seen_arch = 1; | |
| 796 last; | |
| 797 } | |
| 798 } | |
| 799 return $seen_arch; | |
| 800 } | |
| 801 | |
| 802 sub reduce_arch { | |
| 803 my ($self, $host_arch) = @_; | |
| 804 if (not $self->arch_is_concerned($host_arch)) { | |
| 805 $self->reset(); | |
| 806 } else { | |
| 807 $self->{arches} = undef; | |
| 808 } | |
| 809 } | |
| 810 | |
| 811 sub has_arch_restriction { | |
| 812 my ($self) = @_; | |
| 813 if (defined $self->{arches}) { | |
| 814 return $self->{package}; | |
| 815 } else { | |
| 816 return (); | |
| 817 } | |
| 818 } | |
| 819 | |
| 820 sub profile_is_concerned { | |
| 821 my ($self, $build_profiles) = @_; | |
| 822 | |
| 823 return 0 if not defined $self->{package}; # Empty dep | |
| 824 return 1 if not defined $self->{restrictions}; # Dep without restrictions | |
| 825 | |
| 826 my $seen_profile = 0; | |
| 827 foreach my $restriction (@{$self->{restrictions}}) { | |
| 828 # Determine if this restriction is negated, and within the "profile" | |
| 829 # namespace, otherwise it does not concern this check. | |
| 830 next if $restriction !~ m/^(!)?profile\.(.*)/; | |
| 831 | |
| 832 my $negated = defined $1 && $1 eq '!'; | |
| 833 my $profile = $2; | |
| 834 | |
| 835 # Determine if the restriction matches any of the specified profiles. | |
| 836 my $found = any { $_ eq $profile } @{$build_profiles}; | |
| 837 | |
| 838 if ($negated) { | |
| 839 if ($found) { | |
| 840 $seen_profile = 0; | |
| 841 last; | |
| 842 } else { | |
| 843 # "!profile.this" includes by default all other profiles | |
| 844 # unless they also appear in a "!profile.other". | |
| 845 $seen_profile = 1; | |
| 846 } | |
| 847 } elsif ($found) { | |
| 848 $seen_profile = 1; | |
| 849 last; | |
| 850 } | |
| 851 } | |
| 852 return $seen_profile; | |
| 853 } | |
| 854 | |
| 855 sub reduce_profiles { | |
| 856 my ($self, $build_profiles) = @_; | |
| 857 | |
| 858 if (not $self->profile_is_concerned($build_profiles)) { | |
| 859 $self->reset(); | |
| 860 } else { | |
| 861 $self->{restrictions} = undef; | |
| 862 } | |
| 863 } | |
| 864 | |
| 865 sub get_evaluation { | |
| 866 my ($self, $facts) = @_; | |
| 867 return if not defined $self->{package}; | |
| 868 return $facts->_evaluate_simple_dep($self); | |
| 869 } | |
| 870 | |
| 871 sub simplify_deps { | |
| 872 my ($self, $facts) = @_; | |
| 873 my $eval = $self->get_evaluation($facts); | |
| 874 $self->reset() if defined $eval and $eval == 1; | |
| 875 } | |
| 876 | |
| 877 sub is_empty { | |
| 878 my $self = shift; | |
| 879 return not defined $self->{package}; | |
| 880 } | |
| 881 | |
| 882 sub merge_union { | |
| 883 my ($self, $o) = @_; | |
| 884 return 0 if not $o->isa('Dpkg::Deps::Simple'); | |
| 885 return 0 if $self->is_empty() or $o->is_empty(); | |
| 886 return 0 if $self->{package} ne $o->{package}; | |
| 887 return 0 if defined $self->{arches} or defined $o->{arches}; | |
| 888 | |
| 889 if (not defined $o->{relation} and defined $self->{relation}) { | |
| 890 # Union is the non-versioned dependency | |
| 891 $self->{relation} = undef; | |
| 892 $self->{version} = undef; | |
| 893 return 1; | |
| 894 } | |
| 895 | |
| 896 my $implication = $self->implies($o); | |
| 897 my $rev_implication = $o->implies($self); | |
| 898 if (defined($implication)) { | |
| 899 if ($implication) { | |
| 900 $self->{relation} = $o->{relation}; | |
| 901 $self->{version} = $o->{version}; | |
| 902 return 1; | |
| 903 } else { | |
| 904 return 0; | |
| 905 } | |
| 906 } | |
| 907 if (defined($rev_implication)) { | |
| 908 if ($rev_implication) { | |
| 909 # Already merged... | |
| 910 return 1; | |
| 911 } else { | |
| 912 return 0; | |
| 913 } | |
| 914 } | |
| 915 return 0; | |
| 916 } | |
| 917 | |
| 918 package Dpkg::Deps::Multiple; | |
| 919 | |
| 920 =head2 Dpkg::Deps::Multiple | |
| 921 | |
| 922 This is the base class for Dpkg::Deps::{AND,OR,Union}. It implements | |
| 923 the following methods: | |
| 924 | |
| 925 =over 4 | |
| 926 | |
| 927 =item $mul->add($dep) | |
| 928 | |
| 929 Adds a new dependency object at the end of the list. | |
| 930 | |
| 931 =back | |
| 932 | |
| 933 =cut | |
| 934 | |
| 935 use strict; | |
| 936 use warnings; | |
| 937 | |
| 938 use Carp; | |
| 939 | |
| 940 use Dpkg::ErrorHandling; | |
| 941 | |
| 942 use parent qw(Dpkg::Interface::Storable); | |
| 943 | |
| 944 sub new { | |
| 945 my $this = shift; | |
| 946 my $class = ref($this) || $this; | |
| 947 my $self = { list => [ @_ ] }; | |
| 948 bless $self, $class; | |
| 949 return $self; | |
| 950 } | |
| 951 | |
| 952 sub reset { | |
| 953 my ($self) = @_; | |
| 954 $self->{list} = []; | |
| 955 } | |
| 956 | |
| 957 sub add { | |
| 958 my $self = shift; | |
| 959 push @{$self->{list}}, @_; | |
| 960 } | |
| 961 | |
| 962 sub get_deps { | |
| 963 my $self = shift; | |
| 964 return grep { not $_->is_empty() } @{$self->{list}}; | |
| 965 } | |
| 966 | |
| 967 sub sort { | |
| 968 my $self = shift; | |
| 969 my @res = (); | |
| 970 @res = sort { Dpkg::Deps::deps_compare($a, $b) } @{$self->{list}}; | |
| 971 $self->{list} = [ @res ]; | |
| 972 } | |
| 973 | |
| 974 sub arch_is_concerned { | |
| 975 my ($self, $host_arch) = @_; | |
| 976 my $res = 0; | |
| 977 foreach my $dep (@{$self->{list}}) { | |
| 978 $res = 1 if $dep->arch_is_concerned($host_arch); | |
| 979 } | |
| 980 return $res; | |
| 981 } | |
| 982 | |
| 983 sub reduce_arch { | |
| 984 my ($self, $host_arch) = @_; | |
| 985 my @new; | |
| 986 foreach my $dep (@{$self->{list}}) { | |
| 987 $dep->reduce_arch($host_arch); | |
| 988 push @new, $dep if $dep->arch_is_concerned($host_arch); | |
| 989 } | |
| 990 $self->{list} = [ @new ]; | |
| 991 } | |
| 992 | |
| 993 sub has_arch_restriction { | |
| 994 my ($self) = @_; | |
| 995 my @res; | |
| 996 foreach my $dep (@{$self->{list}}) { | |
| 997 push @res, $dep->has_arch_restriction(); | |
| 998 } | |
| 999 return @res; | |
| 1000 } | |
| 1001 | |
| 1002 | |
| 1003 sub is_empty { | |
| 1004 my $self = shift; | |
| 1005 return scalar @{$self->{list}} == 0; | |
| 1006 } | |
| 1007 | |
| 1008 sub merge_union { | |
| 1009 croak 'method merge_union() is only valid for Dpkg::Deps::Simple'; | |
| 1010 } | |
| 1011 | |
| 1012 package Dpkg::Deps::AND; | |
| 1013 | |
| 1014 =head2 Dpkg::Deps::AND | |
| 1015 | |
| 1016 This object represents a list of dependencies who must be met at the same | |
| 1017 time. | |
| 1018 | |
| 1019 =over 4 | |
| 1020 | |
| 1021 =item $and->output([$fh]) | |
| 1022 | |
| 1023 The output method uses ", " to join the list of sub-dependencies. | |
| 1024 | |
| 1025 =back | |
| 1026 | |
| 1027 =cut | |
| 1028 | |
| 1029 use strict; | |
| 1030 use warnings; | |
| 1031 | |
| 1032 use parent -norequire, qw(Dpkg::Deps::Multiple); | |
| 1033 | |
| 1034 sub output { | |
| 1035 my ($self, $fh) = @_; | |
| 1036 my $res = join(', ', map { $_->output() } grep { not $_->is_empty() } $self-
>get_deps()); | |
| 1037 if (defined($fh)) { | |
| 1038 print { $fh } $res; | |
| 1039 } | |
| 1040 return $res; | |
| 1041 } | |
| 1042 | |
| 1043 sub implies { | |
| 1044 my ($self, $o) = @_; | |
| 1045 # If any individual member can imply $o or NOT $o, we're fine | |
| 1046 foreach my $dep ($self->get_deps()) { | |
| 1047 my $implication = $dep->implies($o); | |
| 1048 return 1 if defined($implication) && $implication == 1; | |
| 1049 return 0 if defined($implication) && $implication == 0; | |
| 1050 } | |
| 1051 # If o is an AND, we might have an implication, if we find an | |
| 1052 # implication within us for each predicate in o | |
| 1053 if ($o->isa('Dpkg::Deps::AND')) { | |
| 1054 my $subset = 1; | |
| 1055 foreach my $odep ($o->get_deps()) { | |
| 1056 my $found = 0; | |
| 1057 foreach my $dep ($self->get_deps()) { | |
| 1058 $found = 1 if $dep->implies($odep); | |
| 1059 } | |
| 1060 $subset = 0 if not $found; | |
| 1061 } | |
| 1062 return 1 if $subset; | |
| 1063 } | |
| 1064 return; | |
| 1065 } | |
| 1066 | |
| 1067 sub get_evaluation { | |
| 1068 my ($self, $facts) = @_; | |
| 1069 # Return 1 only if all members evaluates to true | |
| 1070 # Return 0 if at least one member evaluates to false | |
| 1071 # Return undef otherwise | |
| 1072 my $result = 1; | |
| 1073 foreach my $dep ($self->get_deps()) { | |
| 1074 my $eval = $dep->get_evaluation($facts); | |
| 1075 if (not defined $eval) { | |
| 1076 $result = undef; | |
| 1077 } elsif ($eval == 0) { | |
| 1078 $result = 0; | |
| 1079 last; | |
| 1080 } elsif ($eval == 1) { | |
| 1081 # Still possible | |
| 1082 } | |
| 1083 } | |
| 1084 return $result; | |
| 1085 } | |
| 1086 | |
| 1087 sub simplify_deps { | |
| 1088 my ($self, $facts, @knowndeps) = @_; | |
| 1089 my @new; | |
| 1090 | |
| 1091 WHILELOOP: | |
| 1092 while (@{$self->{list}}) { | |
| 1093 my $dep = shift @{$self->{list}}; | |
| 1094 my $eval = $dep->get_evaluation($facts); | |
| 1095 next if defined($eval) and $eval == 1; | |
| 1096 foreach my $odep (@knowndeps, @new) { | |
| 1097 next WHILELOOP if $odep->implies($dep); | |
| 1098 } | |
| 1099 # When a dependency is implied by another dependency that | |
| 1100 # follows, then invert them | |
| 1101 # "a | b, c, a" becomes "a, c" and not "c, a" | |
| 1102 my $i = 0; | |
| 1103 foreach my $odep (@{$self->{list}}) { | |
| 1104 if (defined $odep and $odep->implies($dep)) { | |
| 1105 splice @{$self->{list}}, $i, 1; | |
| 1106 unshift @{$self->{list}}, $odep; | |
| 1107 next WHILELOOP; | |
| 1108 } | |
| 1109 $i++; | |
| 1110 } | |
| 1111 push @new, $dep; | |
| 1112 } | |
| 1113 $self->{list} = [ @new ]; | |
| 1114 } | |
| 1115 | |
| 1116 | |
| 1117 package Dpkg::Deps::OR; | |
| 1118 | |
| 1119 =head2 Dpkg::Deps::OR | |
| 1120 | |
| 1121 This object represents a list of dependencies of which only one must be met | |
| 1122 for the dependency to be true. | |
| 1123 | |
| 1124 =over 4 | |
| 1125 | |
| 1126 =item $or->output([$fh]) | |
| 1127 | |
| 1128 The output method uses " | " to join the list of sub-dependencies. | |
| 1129 | |
| 1130 =back | |
| 1131 | |
| 1132 =cut | |
| 1133 | |
| 1134 use strict; | |
| 1135 use warnings; | |
| 1136 | |
| 1137 use parent -norequire, qw(Dpkg::Deps::Multiple); | |
| 1138 | |
| 1139 sub output { | |
| 1140 my ($self, $fh) = @_; | |
| 1141 my $res = join(' | ', map { $_->output() } grep { not $_->is_empty() } $self
->get_deps()); | |
| 1142 if (defined($fh)) { | |
| 1143 print { $fh } $res; | |
| 1144 } | |
| 1145 return $res; | |
| 1146 } | |
| 1147 | |
| 1148 sub implies { | |
| 1149 my ($self, $o) = @_; | |
| 1150 | |
| 1151 # Special case for AND with a single member, replace it by its member | |
| 1152 if ($o->isa('Dpkg::Deps::AND')) { | |
| 1153 my @subdeps = $o->get_deps(); | |
| 1154 if (scalar(@subdeps) == 1) { | |
| 1155 $o = $subdeps[0]; | |
| 1156 } | |
| 1157 } | |
| 1158 | |
| 1159 # In general, an OR dependency can't imply anything except if each | |
| 1160 # of its member implies a member in the other OR dependency | |
| 1161 if ($o->isa('Dpkg::Deps::OR')) { | |
| 1162 my $subset = 1; | |
| 1163 foreach my $dep ($self->get_deps()) { | |
| 1164 my $found = 0; | |
| 1165 foreach my $odep ($o->get_deps()) { | |
| 1166 $found = 1 if $dep->implies($odep); | |
| 1167 } | |
| 1168 $subset = 0 if not $found; | |
| 1169 } | |
| 1170 return 1 if $subset; | |
| 1171 } | |
| 1172 return; | |
| 1173 } | |
| 1174 | |
| 1175 sub get_evaluation { | |
| 1176 my ($self, $facts) = @_; | |
| 1177 # Returns false if all members evaluates to 0 | |
| 1178 # Returns true if at least one member evaluates to true | |
| 1179 # Returns undef otherwise | |
| 1180 my $result = 0; | |
| 1181 foreach my $dep ($self->get_deps()) { | |
| 1182 my $eval = $dep->get_evaluation($facts); | |
| 1183 if (not defined $eval) { | |
| 1184 $result = undef; | |
| 1185 } elsif ($eval == 1) { | |
| 1186 $result = 1; | |
| 1187 last; | |
| 1188 } elsif ($eval == 0) { | |
| 1189 # Still possible to have a false evaluation | |
| 1190 } | |
| 1191 } | |
| 1192 return $result; | |
| 1193 } | |
| 1194 | |
| 1195 sub simplify_deps { | |
| 1196 my ($self, $facts) = @_; | |
| 1197 my @new; | |
| 1198 | |
| 1199 WHILELOOP: | |
| 1200 while (@{$self->{list}}) { | |
| 1201 my $dep = shift @{$self->{list}}; | |
| 1202 my $eval = $dep->get_evaluation($facts); | |
| 1203 if (defined($eval) and $eval == 1) { | |
| 1204 $self->{list} = []; | |
| 1205 return; | |
| 1206 } | |
| 1207 foreach my $odep (@new, @{$self->{list}}) { | |
| 1208 next WHILELOOP if $odep->implies($dep); | |
| 1209 } | |
| 1210 push @new, $dep; | |
| 1211 } | |
| 1212 $self->{list} = [ @new ]; | |
| 1213 } | |
| 1214 | |
| 1215 package Dpkg::Deps::Union; | |
| 1216 | |
| 1217 =head2 Dpkg::Deps::Union | |
| 1218 | |
| 1219 This object represents a list of relationships. | |
| 1220 | |
| 1221 =over 4 | |
| 1222 | |
| 1223 =item $union->output([$fh]) | |
| 1224 | |
| 1225 The output method uses ", " to join the list of relationships. | |
| 1226 | |
| 1227 =item $union->implies($other_dep) | |
| 1228 | |
| 1229 =item $union->get_evaluation($other_dep) | |
| 1230 | |
| 1231 Those methods are not meaningful for this object and always return undef. | |
| 1232 | |
| 1233 =item $union->simplify_deps($facts) | |
| 1234 | |
| 1235 The simplication is done to generate an union of all the relationships. | |
| 1236 It uses $simple_dep->merge_union($other_dep) to get its job done. | |
| 1237 | |
| 1238 =back | |
| 1239 | |
| 1240 =cut | |
| 1241 | |
| 1242 use strict; | |
| 1243 use warnings; | |
| 1244 | |
| 1245 use parent -norequire, qw(Dpkg::Deps::Multiple); | |
| 1246 | |
| 1247 sub output { | |
| 1248 my ($self, $fh) = @_; | |
| 1249 my $res = join(', ', map { $_->output() } grep { not $_->is_empty() } $self-
>get_deps()); | |
| 1250 if (defined($fh)) { | |
| 1251 print { $fh } $res; | |
| 1252 } | |
| 1253 return $res; | |
| 1254 } | |
| 1255 | |
| 1256 sub implies { | |
| 1257 # Implication test are not useful on Union | |
| 1258 return; | |
| 1259 } | |
| 1260 | |
| 1261 sub get_evaluation { | |
| 1262 # Evaluation are not useful on Union | |
| 1263 return; | |
| 1264 } | |
| 1265 | |
| 1266 sub simplify_deps { | |
| 1267 my ($self, $facts) = @_; | |
| 1268 my @new; | |
| 1269 | |
| 1270 WHILELOOP: | |
| 1271 while (@{$self->{list}}) { | |
| 1272 my $odep = shift @{$self->{list}}; | |
| 1273 foreach my $dep (@new) { | |
| 1274 next WHILELOOP if $dep->merge_union($odep); | |
| 1275 } | |
| 1276 push @new, $odep; | |
| 1277 } | |
| 1278 $self->{list} = [ @new ]; | |
| 1279 } | |
| 1280 | |
| 1281 package Dpkg::Deps::KnownFacts; | |
| 1282 | |
| 1283 =head2 Dpkg::Deps::KnownFacts | |
| 1284 | |
| 1285 This object represents a list of installed packages and a list of virtual | |
| 1286 packages provided (by the set of installed packages). | |
| 1287 | |
| 1288 =over 4 | |
| 1289 | |
| 1290 =item my $facts = Dpkg::Deps::KnownFacts->new(); | |
| 1291 | |
| 1292 Creates a new object. | |
| 1293 | |
| 1294 =cut | |
| 1295 | |
| 1296 use strict; | |
| 1297 use warnings; | |
| 1298 | |
| 1299 use Dpkg::Version; | |
| 1300 | |
| 1301 sub new { | |
| 1302 my $this = shift; | |
| 1303 my $class = ref($this) || $this; | |
| 1304 my $self = { | |
| 1305 pkg => {}, | |
| 1306 virtualpkg => {}, | |
| 1307 }; | |
| 1308 bless $self, $class; | |
| 1309 return $self; | |
| 1310 } | |
| 1311 | |
| 1312 =item $facts->add_installed_package($package, $version, $arch, $multiarch) | |
| 1313 | |
| 1314 Records that the given version of the package is installed. If | |
| 1315 $version/$arch is undefined we know that the package is installed but we | |
| 1316 don't know which version/architecture it is. $multiarch is the Multi-Arch | |
| 1317 field of the package. If $multiarch is undef, it will be equivalent to | |
| 1318 "Multi-Arch: no". | |
| 1319 | |
| 1320 Note that $multiarch is only used if $arch is provided. | |
| 1321 | |
| 1322 =cut | |
| 1323 | |
| 1324 sub add_installed_package { | |
| 1325 my ($self, $pkg, $ver, $arch, $multiarch) = @_; | |
| 1326 my $p = { | |
| 1327 package => $pkg, | |
| 1328 version => $ver, | |
| 1329 architecture => $arch, | |
| 1330 multiarch => $multiarch || 'no', | |
| 1331 }; | |
| 1332 $self->{pkg}{"$pkg:$arch"} = $p if defined $arch; | |
| 1333 push @{$self->{pkg}{$pkg}}, $p; | |
| 1334 } | |
| 1335 | |
| 1336 =item $facts->add_provided_package($virtual, $relation, $version, $by) | |
| 1337 | |
| 1338 Records that the "$by" package provides the $virtual package. $relation | |
| 1339 and $version correspond to the associated relation given in the Provides | |
| 1340 field. This might be used in the future for versioned provides. | |
| 1341 | |
| 1342 =cut | |
| 1343 | |
| 1344 sub add_provided_package { | |
| 1345 my ($self, $pkg, $rel, $ver, $by) = @_; | |
| 1346 if (not exists $self->{virtualpkg}{$pkg}) { | |
| 1347 $self->{virtualpkg}{$pkg} = []; | |
| 1348 } | |
| 1349 push @{$self->{virtualpkg}{$pkg}}, [ $by, $rel, $ver ]; | |
| 1350 } | |
| 1351 | |
| 1352 =item my ($check, $param) = $facts->check_package($package) | |
| 1353 | |
| 1354 $check is one when the package is found. For a real package, $param | |
| 1355 contains the version. For a virtual package, $param contains an array | |
| 1356 reference containing the list of packages that provide it (each package is | |
| 1357 listed as [ $provider, $relation, $version ]). | |
| 1358 | |
| 1359 This function is obsolete and should not be used. Dpkg::Deps::KnownFacts | |
| 1360 is only meant to be filled with data and then passed to Dpkg::Deps | |
| 1361 methods where appropriate, but it should not be directly queried. | |
| 1362 | |
| 1363 =back | |
| 1364 | |
| 1365 =cut | |
| 1366 | |
| 1367 sub check_package { | |
| 1368 my ($self, $pkg) = @_; | |
| 1369 if (exists $self->{pkg}{$pkg}) { | |
| 1370 return (1, $self->{pkg}{$pkg}[0]{version}); | |
| 1371 } | |
| 1372 if (exists $self->{virtualpkg}{$pkg}) { | |
| 1373 return (1, $self->{virtualpkg}{$pkg}); | |
| 1374 } | |
| 1375 return (0, undef); | |
| 1376 } | |
| 1377 | |
| 1378 ## The functions below are private to Dpkg::Deps | |
| 1379 | |
| 1380 sub _find_package { | |
| 1381 my ($self, $dep, $lackinfos) = @_; | |
| 1382 my ($pkg, $archqual) = ($dep->{package}, $dep->{archqual}); | |
| 1383 return if not exists $self->{pkg}{$pkg}; | |
| 1384 my $host_arch = $dep->{host_arch}; | |
| 1385 my $build_arch = $dep->{build_arch}; | |
| 1386 foreach my $p (@{$self->{pkg}{$pkg}}) { | |
| 1387 my $a = $p->{architecture}; | |
| 1388 my $ma = $p->{multiarch}; | |
| 1389 if (not defined $a) { | |
| 1390 $$lackinfos = 1; | |
| 1391 next; | |
| 1392 } | |
| 1393 if (not defined $archqual) { | |
| 1394 return $p if $ma eq 'foreign'; | |
| 1395 return $p if $a eq $host_arch or $a eq 'all'; | |
| 1396 } elsif ($archqual eq 'any') { | |
| 1397 return $p if $ma eq 'allowed'; | |
| 1398 } elsif ($archqual eq 'native') { | |
| 1399 return $p if $a eq $build_arch and $ma ne 'foreign'; | |
| 1400 } else { | |
| 1401 return $p if $a eq $archqual; | |
| 1402 } | |
| 1403 } | |
| 1404 return; | |
| 1405 } | |
| 1406 | |
| 1407 sub _find_virtual_packages { | |
| 1408 my ($self, $pkg) = @_; | |
| 1409 return () if not exists $self->{virtualpkg}{$pkg}; | |
| 1410 return @{$self->{virtualpkg}{$pkg}}; | |
| 1411 } | |
| 1412 | |
| 1413 sub _evaluate_simple_dep { | |
| 1414 my ($self, $dep) = @_; | |
| 1415 my ($lackinfos, $pkg) = (0, $dep->{package}); | |
| 1416 my $p = $self->_find_package($dep, \$lackinfos); | |
| 1417 if ($p) { | |
| 1418 if (defined $dep->{relation}) { | |
| 1419 if (defined $p->{version}) { | |
| 1420 return 1 if version_compare_relation($p->{version}, | |
| 1421 $dep->{relation}, $dep->{version}); | |
| 1422 } else { | |
| 1423 $lackinfos = 1; | |
| 1424 } | |
| 1425 } else { | |
| 1426 return 1; | |
| 1427 } | |
| 1428 } | |
| 1429 foreach my $virtpkg ($self->_find_virtual_packages($pkg)) { | |
| 1430 # XXX: Adapt when versioned provides are allowed | |
| 1431 next if defined $virtpkg->[1]; | |
| 1432 next if defined $dep->{relation}; # Provides don't satisfy versioned dep
s | |
| 1433 return 1; | |
| 1434 } | |
| 1435 return if $lackinfos; | |
| 1436 return 0; | |
| 1437 } | |
| 1438 | |
| 1439 =head1 CHANGES | |
| 1440 | |
| 1441 =head2 Version 1.02 | |
| 1442 | |
| 1443 =over | |
| 1444 | |
| 1445 =item * Add new Dpkg::deps_concat() function. | |
| 1446 | |
| 1447 =back | |
| 1448 | |
| 1449 =head2 Version 1.01 | |
| 1450 | |
| 1451 =over | |
| 1452 | |
| 1453 =item * Add new $dep->reset() method that all dependency objects support. | |
| 1454 | |
| 1455 =item * Dpkg::Deps::Simple now recognizes the arch qualifier "any" and | |
| 1456 stores it in the "archqual" property when present. | |
| 1457 | |
| 1458 =item * Dpkg::Deps::KnownFacts->add_installed_package() now accepts 2 | |
| 1459 supplementary parameters ($arch and $multiarch). | |
| 1460 | |
| 1461 =item * Dpkg::Deps::KnownFacts->check_package() is obsolete, it should | |
| 1462 not have been part of the public API. | |
| 1463 | |
| 1464 =back | |
| 1465 | |
| 1466 =cut | |
| 1467 | |
| 1468 1; | |
| OLD | NEW |
|---|
Chromium Code Reviews
Issue 2425693003:
Revert of Linux build: Use sysroot when calculating dependencies (Closed)
