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