File Coverage

blib/lib/Dpkg/Deps/Simple.pm
Criterion Covered Total %
statement 165 217 76.0
branch 84 130 64.6
condition 18 46 39.1
subroutine 24 29 82.7
pod 17 17 100.0
total 308 439 70.1


line stmt bran cond sub pod time code
1             # Copyright © 1998 Richard Braakman
2             # Copyright © 1999 Darren Benham
3             # Copyright © 2000 Sean 'Shaleh' Perry
4             # Copyright © 2004 Frank Lichtenheld
5             # Copyright © 2006 Russ Allbery
6             # Copyright © 2007-2009 Raphaël Hertzog
7             # Copyright © 2008-2009, 2012-2014 Guillem Jover
8             #
9             # This program is free software; you may redistribute it and/or modify
10             # it under the terms of the GNU General Public License as published by
11             # the Free Software Foundation; either version 2 of the License, or
12             # (at your option) any later version.
13             #
14             # This is distributed in the hope that it will be useful,
15             # but WITHOUT ANY WARRANTY; without even the implied warranty of
16             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17             # GNU General Public License for more details.
18             #
19             # You should have received a copy of the GNU General Public License
20             # along with this program. If not, see .
21              
22             package Dpkg::Deps::Simple;
23              
24             =encoding utf8
25              
26             =head1 NAME
27              
28             Dpkg::Deps::Simple - represents a single dependency statement
29              
30             =head1 DESCRIPTION
31              
32             This class represents a single dependency statement.
33             It has several interesting properties:
34              
35             =over 4
36              
37             =item package
38              
39             The package name (can be undef if the dependency has not been initialized
40             or if the simplification of the dependency lead to its removal).
41              
42             =item relation
43              
44             The relational operator: "=", "<<", "<=", ">=" or ">>". It can be
45             undefined if the dependency had no version restriction. In that case the
46             following field is also undefined.
47              
48             =item version
49              
50             The version.
51              
52             =item arches
53              
54             The list of architectures where this dependency is applicable. It is
55             undefined when there's no restriction, otherwise it is an
56             array ref. It can contain an exclusion list, in that case each
57             architecture is prefixed with an exclamation mark.
58              
59             =item archqual
60              
61             The arch qualifier of the dependency (can be undef if there is none).
62             In the dependency "python:any (>= 2.6)", the arch qualifier is "any".
63              
64             =item restrictions
65              
66             The restrictions formula for this dependency. It is undefined when there
67             is no restriction formula. Otherwise it is an array ref.
68              
69             =back
70              
71             =head1 METHODS
72              
73             =over 4
74              
75             =cut
76              
77 1     1   7 use strict;
  1         2  
  1         28  
78 1     1   5 use warnings;
  1         2  
  1         50  
79              
80             our $VERSION = '1.02';
81              
82 1     1   6 use Carp;
  1         2  
  1         62  
83              
84 1     1   7 use Dpkg::Arch qw(debarch_is_concerned debarch_list_parse);
  1         1  
  1         45  
85 1     1   5 use Dpkg::BuildProfiles qw(parse_build_profiles evaluate_restriction_formula);
  1         2  
  1         53  
86 1     1   6 use Dpkg::Version;
  1         2  
  1         82  
87 1     1   7 use Dpkg::ErrorHandling;
  1         2  
  1         73  
88 1     1   6 use Dpkg::Gettext;
  1         2  
  1         60  
89              
90 1     1   520 use parent qw(Dpkg::Interface::Storable);
  1         320  
  1         6  
91              
92             =item $dep = Dpkg::Deps::Simple->new([$dep[, %opts]]);
93              
94             Creates a new object. Some options can be set through %opts:
95              
96             =over
97              
98             =item host_arch
99              
100             Sets the host architecture.
101              
102             =item build_arch
103              
104             Sets the build architecture.
105              
106             =item build_dep
107              
108             Specifies whether the parser should consider it a build dependency.
109             Defaults to 0.
110              
111             =item tests_dep
112              
113             Specifies whether the parser should consider it a tests dependency.
114             Defaults to 0.
115              
116             =back
117              
118             =cut
119              
120             sub new {
121 254     254 1 703 my ($this, $arg, %opts) = @_;
122 254   33     779 my $class = ref($this) || $this;
123 254         458 my $self = {};
124              
125 254         400 bless $self, $class;
126 254         605 $self->reset();
127 254         384 $self->{host_arch} = $opts{host_arch};
128 254         532 $self->{build_arch} = $opts{build_arch};
129 254   50     528 $self->{build_dep} = $opts{build_dep} // 0;
130 254   50     491 $self->{tests_dep} = $opts{tests_dep} // 0;
131 254 50       685 $self->parse_string($arg) if defined $arg;
132 254         711 return $self;
133             }
134              
135             =item $dep->reset()
136              
137             Clears any dependency information stored in $dep so that $dep->is_empty()
138             returns true.
139              
140             =cut
141              
142             sub reset {
143 318     318 1 465 my $self = shift;
144              
145 318         610 $self->{package} = undef;
146 318         447 $self->{relation} = undef;
147 318         439 $self->{version} = undef;
148 318         442 $self->{arches} = undef;
149 318         422 $self->{archqual} = undef;
150 318         537 $self->{restrictions} = undef;
151             }
152              
153             =item $dep->parse_string($dep_string)
154              
155             Parses the dependency string and modifies internal properties to match the
156             parsed dependency.
157              
158             =cut
159              
160             sub parse_string {
161 254     254 1 422 my ($self, $dep) = @_;
162              
163 254         300 my $pkgname_re;
164 254 100       444 if ($self->{tests_dep}) {
165 3         10 $pkgname_re = qr/[\@a-zA-Z0-9][\@a-zA-Z0-9+.-]*/;
166             } else {
167 251         709 $pkgname_re = qr/[a-zA-Z0-9][a-zA-Z0-9+.-]*/;
168             }
169              
170 254 100       2845 return if not $dep =~
171             m{^\s* # skip leading whitespace
172             ($pkgname_re) # package name
173             (?: # start of optional part
174             : # colon for architecture
175             ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name
176             )? # end of optional part
177             (?: # start of optional part
178             \s* \( # open parenthesis for version part
179             \s* (<<|<=|=|>=|>>|[<>]) # relation part
180             \s* ([^\)\s]+) # do not attempt to parse version
181             \s* \) # closing parenthesis
182             )? # end of optional part
183             (?: # start of optional architecture
184             \s* \[ # open bracket for architecture
185             \s* ([^\]]+) # don't parse architectures now
186             \s* \] # closing bracket
187             )? # end of optional architecture
188             (
189             (?: # start of optional restriction
190             \s* < # open bracket for restriction
191             \s* [^>]+ # do not parse restrictions now
192             \s* > # closing bracket
193             )+
194             )? # end of optional restriction
195             \s*$ # trailing spaces at end
196             }x;
197 250 100       658 if (defined $2) {
198 18 50 66     69 return if $2 eq 'native' and not $self->{build_dep};
199 18         42 $self->{archqual} = $2;
200             }
201 250         561 $self->{package} = $1;
202 250 100       578 $self->{relation} = version_normalize_relation($3) if defined $3;
203 250 100       512 if (defined $4) {
204 46         140 $self->{version} = Dpkg::Version->new($4);
205             }
206 250 100       470 if (defined $5) {
207 10         35 $self->{arches} = [ debarch_list_parse($5) ];
208             }
209 250 100       592 if (defined $6) {
210 133         338 $self->{restrictions} = [ parse_build_profiles($6) ];
211             }
212             }
213              
214             =item $dep->parse($fh, $desc)
215              
216             Parse a dependency line from a filehandle.
217              
218             =cut
219              
220             sub parse {
221 0     0 1 0 my ($self, $fh, $desc) = @_;
222              
223 0         0 my $line = <$fh>;
224 0         0 chomp $line;
225 0         0 return $self->parse_string($line);
226             }
227              
228             =item $dep->load($filename)
229              
230             Parse a dependency line from $filename.
231              
232             =item $dep->output([$fh])
233              
234             =item "$dep"
235              
236             Returns a string representing the dependency. If $fh is set, it prints
237             the string to the filehandle.
238              
239             =cut
240              
241             sub output {
242 141     141 1 257 my ($self, $fh) = @_;
243              
244 141         223 my $res = $self->{package};
245 141 100       240 if (defined $self->{archqual}) {
246 10         38 $res .= ':' . $self->{archqual};
247             }
248 141 100       250 if (defined $self->{relation}) {
249 30         108 $res .= ' (' . $self->{relation} . ' ' . $self->{version} . ')';
250             }
251 141 100       252 if (defined $self->{arches}) {
252 1         5 $res .= ' [' . join(' ', @{$self->{arches}}) . ']';
  1         4  
253             }
254 141 100       231 if (defined $self->{restrictions}) {
255 6         10 for my $restrlist (@{$self->{restrictions}}) {
  6         20  
256 7         12 $res .= ' <' . join(' ', @{$restrlist}) . '>';
  7         22  
257             }
258             }
259 141 50       217 if (defined $fh) {
260 0         0 print { $fh } $res;
  0         0  
261             }
262 141         355 return $res;
263             }
264              
265             =item $dep->save($filename)
266              
267             Save the dependency into the given $filename.
268              
269             =cut
270              
271             # _arch_is_superset(\@p, \@q)
272             #
273             # Returns true if the arch list @p is a superset of arch list @q.
274             # The arguments can also be undef in case there's no explicit architecture
275             # restriction.
276             sub _arch_is_superset {
277 70     70   103 my ($p, $q) = @_;
278 70 50       131 my $p_arch_neg = defined $p and $p->[0] =~ /^!/;
279 70 50       129 my $q_arch_neg = defined $q and $q->[0] =~ /^!/;
280              
281             # If "p" has no arches, it is a superset of q and we should fall through
282             # to the version check.
283 70 50 0     113 if (not defined $p) {
    0 0        
    0 0        
    0 0        
    0          
    0          
284 70         148 return 1;
285             }
286             # If q has no arches, it is a superset of p and there are no useful
287             # implications.
288             elsif (not defined $q) {
289 0         0 return 0;
290             }
291             # Both have arches. If neither are negated, we know nothing useful
292             # unless q is a subset of p.
293             elsif (not $p_arch_neg and not $q_arch_neg) {
294 0         0 my %p_arches = map { $_ => 1 } @{$p};
  0         0  
  0         0  
295 0         0 my $subset = 1;
296 0         0 for my $arch (@{$q}) {
  0         0  
297 0 0       0 $subset = 0 unless $p_arches{$arch};
298             }
299 0 0       0 return 0 unless $subset;
300             }
301             # If both are negated, we know nothing useful unless p is a subset of
302             # q (and therefore has fewer things excluded, and therefore is more
303             # general).
304             elsif ($p_arch_neg and $q_arch_neg) {
305 0         0 my %q_arches = map { $_ => 1 } @{$q};
  0         0  
  0         0  
306 0         0 my $subset = 1;
307 0         0 for my $arch (@{$p}) {
  0         0  
308 0 0       0 $subset = 0 unless $q_arches{$arch};
309             }
310 0 0       0 return 0 unless $subset;
311             }
312             # If q is negated and p isn't, we'd need to know the full list of
313             # arches to know if there's any relationship, so bail.
314             elsif (not $p_arch_neg and $q_arch_neg) {
315 0         0 return 0;
316             }
317             # If p is negated and q isn't, q is a subset of p if none of the
318             # negated arches in p are present in q.
319             elsif ($p_arch_neg and not $q_arch_neg) {
320 0         0 my %q_arches = map { $_ => 1 } @{$q};
  0         0  
  0         0  
321 0         0 my $subset = 1;
322 0         0 for my $arch (@{$p}) {
  0         0  
323 0 0       0 $subset = 0 if $q_arches{substr($arch, 1)};
324             }
325 0 0       0 return 0 unless $subset;
326             }
327 0         0 return 1;
328             }
329              
330             # _arch_qualifier_implies($p, $q)
331             #
332             # Returns true if the arch qualifier $p and $q are compatible with the
333             # implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native"
334             # or an architecture string.
335             #
336             # Because we are handling dependencies in isolation, and the full context
337             # of the implications are only known when doing dependency resolution at
338             # run-time, we can only assert that they are implied if they are equal.
339             #
340             # For example dependencies with different arch-qualifiers cannot be simplified
341             # as these depend on the state of Multi-Arch field in the package depended on.
342             sub _arch_qualifier_implies {
343 70     70   132 my ($p, $q) = @_;
344              
345 70 100 100     212 return $p eq $q if defined $p and defined $q;
346 53 100 100     201 return 1 if not defined $p and not defined $q;
347 8         28 return 0;
348             }
349              
350             # _restrictions_imply($p, $q)
351             #
352             # Returns true if the restrictions $p and $q are compatible with the
353             # implication $p -> $q, false otherwise.
354             # NOTE: We don't try to be very clever here, so we may conservatively
355             # return false when there is an implication.
356             sub _restrictions_imply {
357 48     48   71 my ($p, $q) = @_;
358              
359 48 100       79 if (not defined $p) {
    50          
360 45         80 return 1;
361             } elsif (not defined $q) {
362 0         0 return 0;
363             } else {
364             # Check whether set difference is empty.
365 3         5 my %restr;
366              
367 3         6 for my $restrlist (@{$q}) {
  3         13  
368 3         8 my $reststr = join ' ', sort @{$restrlist};
  3         13  
369 3         12 $restr{$reststr} = 1;
370             }
371 3         4 for my $restrlist (@{$p}) {
  3         5  
372 3         5 my $reststr = join ' ', sort @{$restrlist};
  3         6  
373 3         9 delete $restr{$reststr};
374             }
375              
376 3         17 return keys %restr == 0;
377             }
378             }
379              
380             =item $dep->implies($other_dep)
381              
382             Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies
383             NOT($other_dep). Returns undef when there is no implication. $dep and
384             $other_dep do not need to be of the same type.
385              
386             =cut
387              
388             sub implies {
389 303     303 1 455 my ($self, $o) = @_;
390              
391 303 100       706 if ($o->isa('Dpkg::Deps::Simple')) {
    100          
    50          
392             # An implication is only possible on the same package
393 276 100       721 return if $self->{package} ne $o->{package};
394              
395             # Our architecture set must be a superset of the architectures for
396             # o, otherwise we can't conclude anything.
397 70 50       132 return unless _arch_is_superset($self->{arches}, $o->{arches});
398              
399             # The arch qualifier must not forbid an implication
400             return unless _arch_qualifier_implies($self->{archqual},
401 70 100       151 $o->{archqual});
402              
403             # Our restrictions must imply the restrictions for o
404             return unless _restrictions_imply($self->{restrictions},
405 48 100       96 $o->{restrictions});
406              
407             # If o has no version clause, then our dependency is stronger
408 46 100       108 return 1 if not defined $o->{relation};
409             # If o has a version clause, we must also have one, otherwise there
410             # can't be an implication
411 31 100       63 return if not defined $self->{relation};
412              
413             return Dpkg::Deps::deps_eval_implication($self->{relation},
414 25         63 $self->{version}, $o->{relation}, $o->{version});
415             } elsif ($o->isa('Dpkg::Deps::AND')) {
416             # TRUE: Need to imply all individual elements
417             # FALSE: Need to NOT imply at least one individual element
418 24         34 my $res = 1;
419 24         47 foreach my $dep ($o->get_deps()) {
420 80         131 my $implication = $self->implies($dep);
421 80 100 100     169 unless (defined $implication and $implication == 1) {
422 73         91 $res = $implication;
423 73 100       124 last if defined $res;
424             }
425             }
426 24         50 return $res;
427             } elsif ($o->isa('Dpkg::Deps::OR')) {
428             # TRUE: Need to imply at least one individual element
429             # FALSE: Need to not apply all individual elements
430             # UNDEF: The rest
431 3         6 my $res = undef;
432 3         7 foreach my $dep ($o->get_deps()) {
433 5         9 my $implication = $self->implies($dep);
434 5 100       12 if (defined $implication) {
435 1 50       3 if (not defined $res) {
436 1         3 $res = $implication;
437             } else {
438 0 0       0 if ($implication) {
439 0         0 $res = 1;
440             } else {
441 0         0 $res = 0;
442             }
443             }
444 1 50 33     16 last if defined $res and $res == 1;
445             }
446             }
447 3         12 return $res;
448             } else {
449 0         0 croak 'Dpkg::Deps::Simple cannot evaluate implication with a ' .
450             ref($o);
451             }
452             }
453              
454             =item $dep->get_deps()
455              
456             Returns a list of sub-dependencies, which for this object it means it
457             returns itself.
458              
459             =cut
460              
461             sub get_deps {
462 0     0 1 0 my $self = shift;
463              
464 0         0 return $self;
465             }
466              
467             =item $dep->sort()
468              
469             This method is a no-op for this object.
470              
471             =cut
472              
473       0 1   sub sort {
474             # Nothing to sort
475             }
476              
477             =item $dep->arch_is_concerned($arch)
478              
479             Returns true if the dependency applies to the indicated architecture.
480              
481             =cut
482              
483             sub arch_is_concerned {
484 30     30 1 47 my ($self, $host_arch) = @_;
485              
486 30 100       81 return 0 if not defined $self->{package}; # Empty dep
487 24 100       70 return 1 if not defined $self->{arches}; # Dep without arch spec
488              
489 9         16 return debarch_is_concerned($host_arch, @{$self->{arches}});
  9         22  
490             }
491              
492             =item $dep->reduce_arch($arch)
493              
494             Simplifies the dependency to contain only information relevant to the given
495             architecture. This object can be left empty after this operation. This trims
496             off the architecture restriction list of these objects.
497              
498             =cut
499              
500             sub reduce_arch {
501 15     15 1 35 my ($self, $host_arch) = @_;
502              
503 15 100       30 if (not $self->arch_is_concerned($host_arch)) {
504 6         17 $self->reset();
505             } else {
506 9         21 $self->{arches} = undef;
507             }
508             }
509              
510             =item $dep->has_arch_restriction()
511              
512             Returns the package name if the dependency applies only to a subset of
513             architectures.
514              
515             =cut
516              
517             sub has_arch_restriction {
518 0     0 1 0 my $self = shift;
519              
520 0 0       0 if (defined $self->{arches}) {
521 0         0 return $self->{package};
522             } else {
523 0         0 return ();
524             }
525             }
526              
527             =item $dep->profile_is_concerned()
528              
529             Returns true if the dependency applies to the indicated profile.
530              
531             =cut
532              
533             sub profile_is_concerned {
534 252     252 1 404 my ($self, $build_profiles) = @_;
535              
536 252 100       595 return 0 if not defined $self->{package}; # Empty dep
537 194 100       430 return 1 if not defined $self->{restrictions}; # Dep without restrictions
538 124         236 return evaluate_restriction_formula($self->{restrictions}, $build_profiles);
539             }
540              
541             =item $dep->reduce_profiles()
542              
543             Simplifies the dependency to contain only information relevant to the given
544             profile. This object can be left empty after this operation. This trims off
545             the profile restriction list of this object.
546              
547             =cut
548              
549             sub reduce_profiles {
550 124     124 1 195 my ($self, $build_profiles) = @_;
551              
552 124 100       194 if (not $self->profile_is_concerned($build_profiles)) {
553 58         106 $self->reset();
554             } else {
555 66         162 $self->{restrictions} = undef;
556             }
557             }
558              
559             =item $dep->get_evaluation($facts)
560              
561             Evaluates the dependency given a list of installed packages and a list of
562             virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts
563             object given as parameters.
564              
565             Returns 1 when it's true, 0 when it's false, undef when some information
566             is lacking to conclude.
567              
568             =cut
569              
570             sub get_evaluation {
571 56     56 1 92 my ($self, $facts) = @_;
572              
573 56 50       108 return if not defined $self->{package};
574 56         119 return $facts->evaluate_simple_dep($self);
575             }
576              
577             =item $dep->simplify_deps($facts, @assumed_deps)
578              
579             Simplifies the dependency as much as possible given the list of facts (see
580             class Dpkg::Deps::KnownFacts) and a list of other dependencies that are
581             known to be true.
582              
583             =cut
584              
585             sub simplify_deps {
586 0     0 1 0 my ($self, $facts) = @_;
587              
588 0         0 my $eval = $self->get_evaluation($facts);
589 0 0 0     0 $self->reset() if defined $eval and $eval == 1;
590             }
591              
592             =item $dep->is_empty()
593              
594             Returns true if the dependency is empty and doesn't contain any useful
595             information. This is true when the object has not yet been initialized.
596              
597             =cut
598              
599             sub is_empty {
600 726     726 1 904 my $self = shift;
601              
602 726         1890 return not defined $self->{package};
603             }
604              
605             =item $dep->merge_union($other_dep)
606              
607             Returns true if $dep could be modified to represent the union of both
608             dependencies. Otherwise returns false.
609              
610             =cut
611              
612             sub merge_union {
613 17     17 1 29 my ($self, $o) = @_;
614              
615 17 50       50 return 0 if not $o->isa('Dpkg::Deps::Simple');
616 17 50 33     28 return 0 if $self->is_empty() or $o->is_empty();
617 17 100       53 return 0 if $self->{package} ne $o->{package};
618 6 50 33     27 return 0 if defined $self->{arches} or defined $o->{arches};
619              
620 6 50 33     16 if (not defined $o->{relation} and defined $self->{relation}) {
621             # Union is the non-versioned dependency
622 0         0 $self->{relation} = undef;
623 0         0 $self->{version} = undef;
624 0         0 return 1;
625             }
626              
627 6         13 my $implication = $self->implies($o);
628 6         32 my $rev_implication = $o->implies($self);
629 6 100       21 if (defined $implication) {
630 4 100       10 if ($implication) {
631 1         4 $self->{relation} = $o->{relation};
632 1         4 $self->{version} = $o->{version};
633 1         5 return 1;
634             } else {
635 3         12 return 0;
636             }
637             }
638 2 50       4 if (defined $rev_implication) {
639 2 50       6 if ($rev_implication) {
640             # Already merged...
641 2         12 return 1;
642             } else {
643 0           return 0;
644             }
645             }
646 0           return 0;
647             }
648              
649             =back
650              
651             =head1 CHANGES
652              
653             =head2 Version 1.02 (dpkg 1.17.10)
654              
655             New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles().
656              
657             =head2 Version 1.01 (dpkg 1.16.1)
658              
659             New method: Add $dep->reset().
660              
661             New property: recognizes the arch qualifier "any" and stores it in the
662             "archqual" property when present.
663              
664             =head2 Version 1.00 (dpkg 1.15.6)
665              
666             Mark the module as public.
667              
668             =cut
669              
670             1;