This is an automated email from the git hooks/post-receive script. guillem pushed a commit to branch master in repository dpkg.
View the commit online: https://git.dpkg.org/cgit/dpkg/dpkg.git/commit/?id=738c8d5d545e164c3e7450751960618443bf7431 commit 738c8d5d545e164c3e7450751960618443bf7431 (HEAD -> master) Author: Guillem Jover <[email protected]> AuthorDate: Mon Jul 30 01:26:08 2018 +0200 Dpkg::Deps: Split subpackages This makes the structure easier to comprehend, and easier to read, otherwise it's difficutl to search for specific methods or functions and know immediately to what module they belong. It also makes for more structured POD. --- debian/changelog | 1 + scripts/Dpkg/Deps.pm | 1379 +-------------------------------------- scripts/Dpkg/Deps/AND.pm | 182 ++++++ scripts/Dpkg/Deps/KnownFacts.pm | 244 +++++++ scripts/Dpkg/Deps/Multiple.pm | 250 +++++++ scripts/Dpkg/Deps/OR.pm | 174 +++++ scripts/Dpkg/Deps/Simple.pm | 659 +++++++++++++++++++ scripts/Dpkg/Deps/Union.pm | 119 ++++ scripts/Makefile.am | 6 + scripts/po/POTFILES.in | 6 + 10 files changed, 1659 insertions(+), 1361 deletions(-) diff --git a/debian/changelog b/debian/changelog index 374c09cf8..d0c53872d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -130,6 +130,7 @@ dpkg (1.19.1) UNRELEASED; urgency=medium - Dpkg::BuildFlags: Move default flags setting into the Dpkg::Vendor modules. - Dpkg::Gettext: Fix fallback textdomain() to honor its expected interface. + - Dpkg::Deps: Split subpackages into their own separate modules. * Documentation: - Update gettext minimal version in README. - Add a missing dot on the dpkg-buildflags(1) «lfs» feature paragraph. diff --git a/scripts/Dpkg/Deps.pm b/scripts/Dpkg/Deps.pm index 613ca2d7a..f3a19e78e 100644 --- a/scripts/Dpkg/Deps.pm +++ b/scripts/Dpkg/Deps.pm @@ -63,6 +63,11 @@ use Dpkg::Arch qw(get_host_arch get_build_arch debarch_to_debtuple); use Dpkg::BuildProfiles qw(get_build_profiles); use Dpkg::ErrorHandling; use Dpkg::Gettext; +use Dpkg::Deps::Simple; +use Dpkg::Deps::Union; +use Dpkg::Deps::AND; +use Dpkg::Deps::OR; +use Dpkg::Deps::KnownFacts; =item deps_eval_implication($rel_p, $v_p, $rel_q, $v_q) @@ -411,9 +416,6 @@ sub deps_compare { } } - -package Dpkg::Deps::Simple; - =head1 OBJECTS - Dpkg::Deps::* There are several kind of dependencies. A Dpkg::Deps::Simple dependency @@ -433,1377 +435,32 @@ dependencies and while trying to simplify them. It represents a set of installed packages along with the virtual packages that they might provide. -=head2 OBJECT - Dpkg::Deps::Simple - -This object has several interesting properties: - -=over 4 - -=item package - -The package name (can be undef if the dependency has not been initialized -or if the simplification of the dependency lead to its removal). - -=item relation - -The relational operator: "=", "<<", "<=", ">=" or ">>". It can be -undefined if the dependency had no version restriction. In that case the -following field is also undefined. - -=item version - -The version. - -=item arches - -The list of architectures where this dependency is applicable. It is -undefined when there's no restriction, otherwise it is an -array ref. It can contain an exclusion list, in that case each -architecture is prefixed with an exclamation mark. - -=item archqual - -The arch qualifier of the dependency (can be undef if there is none). -In the dependency "python:any (>= 2.6)", the arch qualifier is "any". - -=item restrictions - -The restrictions formula for this dependency. It is undefined when there -is no restriction formula. Otherwise it is an array ref. - -=back - -=head2 METHODS - Dpkg::Deps::Simple - -=over 4 - -=cut - -use strict; -use warnings; - -use Carp; - -use Dpkg::Arch qw(debarch_is_concerned debarch_list_parse); -use Dpkg::BuildProfiles qw(parse_build_profiles evaluate_restriction_formula); -use Dpkg::Version; -use Dpkg::ErrorHandling; -use Dpkg::Gettext; - -use parent qw(Dpkg::Interface::Storable); - -=item $dep = Dpkg::Deps::Simple->new(%opts); - -Creates a new object. Some options can be set through %opts: - -=over - -=item host_arch - -Sets the host architecture. - -=item build_arch - -Sets the build architecture. - -=item build_dep - -Specifies whether the parser should consider it a build dependency. -Defaults to 0. - -=item tests_dep - -Specifies whether the parser should consider it a tests dependency. -Defaults to 0. - -=back - -=cut - -sub new { - my ($this, $arg, %opts) = @_; - my $class = ref($this) || $this; - my $self = {}; - bless $self, $class; - $self->reset(); - $self->{host_arch} = $opts{host_arch}; - $self->{build_arch} = $opts{build_arch}; - $self->{build_dep} = $opts{build_dep} // 0; - $self->{tests_dep} = $opts{tests_dep} // 0; - $self->parse_string($arg) if defined($arg); - return $self; -} - -=item $dep->reset() - -Clears any dependency information stored in $dep so that $dep->is_empty() -returns true. - -=cut - -sub reset { - my $self = shift; - $self->{package} = undef; - $self->{relation} = undef; - $self->{version} = undef; - $self->{arches} = undef; - $self->{archqual} = undef; - $self->{restrictions} = undef; -} - -=item $dep->parse($fh, $desc) - -Parses a line from a filehandle. - -=cut - -sub parse { - my ($self, $fh, $desc) = @_; - my $line = <$fh>; - chomp($line); - return $self->parse_string($line); -} - -=item $dep->parse_string($dep_string) - -Parses the dependency string and modifies internal properties to match the -parsed dependency. - -=cut - -sub parse_string { - my ($self, $dep) = @_; - - my $pkgname_re; - if ($self->{tests_dep}) { - $pkgname_re = qr/[\@a-zA-Z0-9][\@a-zA-Z0-9+.-]*/; - } else { - $pkgname_re = qr/[a-zA-Z0-9][a-zA-Z0-9+.-]*/; - } - - return if not $dep =~ - m{^\s* # skip leading whitespace - ($pkgname_re) # package name - (?: # start of optional part - : # colon for architecture - ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name - )? # end of optional part - (?: # start of optional part - \s* \( # open parenthesis for version part - \s* (<<|<=|=|>=|>>|[<>]) # relation part - \s* ([^\)\s]+) # do not attempt to parse version - \s* \) # closing parenthesis - )? # end of optional part - (?: # start of optional architecture - \s* \[ # open bracket for architecture - \s* ([^\]]+) # don't parse architectures now - \s* \] # closing bracket - )? # end of optional architecture - ( - (?: # start of optional restriction - \s* < # open bracket for restriction - \s* [^>]+ # do not parse restrictions now - \s* > # closing bracket - )+ - )? # end of optional restriction - \s*$ # trailing spaces at end - }x; - if (defined($2)) { - return if $2 eq 'native' and not $self->{build_dep}; - $self->{archqual} = $2; - } - $self->{package} = $1; - $self->{relation} = version_normalize_relation($3) if defined($3); - if (defined($4)) { - $self->{version} = Dpkg::Version->new($4); - } - if (defined($5)) { - $self->{arches} = [ debarch_list_parse($5) ]; - } - if (defined($6)) { - $self->{restrictions} = [ parse_build_profiles($6) ]; - } -} - -=item $dep->output([$fh]) - -=item "$dep" - -Returns a string representing the dependency. If $fh is set, it prints -the string to the filehandle. - -=cut - -sub output { - my ($self, $fh) = @_; - my $res = $self->{package}; - if (defined($self->{archqual})) { - $res .= ':' . $self->{archqual}; - } - if (defined($self->{relation})) { - $res .= ' (' . $self->{relation} . ' ' . $self->{version} . ')'; - } - if (defined($self->{arches})) { - $res .= ' [' . join(' ', @{$self->{arches}}) . ']'; - } - if (defined($self->{restrictions})) { - for my $restrlist (@{$self->{restrictions}}) { - $res .= ' <' . join(' ', @{$restrlist}) . '>'; - } - } - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -# _arch_is_superset(\@p, \@q) -# -# Returns true if the arch list @p is a superset of arch list @q. -# The arguments can also be undef in case there's no explicit architecture -# restriction. -sub _arch_is_superset { - my ($p, $q) = @_; - my $p_arch_neg = defined($p) && $p->[0] =~ /^!/; - my $q_arch_neg = defined($q) && $q->[0] =~ /^!/; - - # If "p" has no arches, it is a superset of q and we should fall through - # to the version check. - if (not defined $p) { - return 1; - } - - # If q has no arches, it is a superset of p and there are no useful - # implications. - elsif (not defined $q) { - return 0; - } - - # Both have arches. If neither are negated, we know nothing useful - # unless q is a subset of p. - elsif (not $p_arch_neg and not $q_arch_neg) { - my %p_arches = map { $_ => 1 } @{$p}; - my $subset = 1; - for my $arch (@{$q}) { - $subset = 0 unless $p_arches{$arch}; - } - return 0 unless $subset; - } - - # If both are negated, we know nothing useful unless p is a subset of - # q (and therefore has fewer things excluded, and therefore is more - # general). - elsif ($p_arch_neg and $q_arch_neg) { - my %q_arches = map { $_ => 1 } @{$q}; - my $subset = 1; - for my $arch (@{$p}) { - $subset = 0 unless $q_arches{$arch}; - } - return 0 unless $subset; - } - - # If q is negated and p isn't, we'd need to know the full list of - # arches to know if there's any relationship, so bail. - elsif (not $p_arch_neg and $q_arch_neg) { - return 0; - } - - # If p is negated and q isn't, q is a subset of p if none of the - # negated arches in p are present in q. - elsif ($p_arch_neg and not $q_arch_neg) { - my %q_arches = map { $_ => 1 } @{$q}; - my $subset = 1; - for my $arch (@{$p}) { - $subset = 0 if $q_arches{substr($arch, 1)}; - } - return 0 unless $subset; - } - return 1; -} - -# _arch_qualifier_implies($p, $q) -# -# Returns true if the arch qualifier $p and $q are compatible with the -# implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native" -# or an architecture string. -# -# Because we are handling dependencies in isolation, and the full context -# of the implications are only known when doing dependency resolution at -# run-time, we can only assert that they are implied if they are equal. -# -# For example dependencies with different arch-qualifiers cannot be simplified -# as these depend on the state of Multi-Arch field in the package depended on. -sub _arch_qualifier_implies { - my ($p, $q) = @_; - - return $p eq $q if defined $p and defined $q; - return 1 if not defined $p and not defined $q; - return 0; -} - -# _restrictions_imply($p, $q) -# -# Returns true if the restrictions $p and $q are compatible with the -# implication $p -> $q, false otherwise. -# NOTE: We don't try to be very clever here, so we may conservatively -# return false when there is an implication. -sub _restrictions_imply { - my ($p, $q) = @_; - - if (not defined $p) { - return 1; - } elsif (not defined $q) { - return 0; - } else { - # Check whether set difference is empty. - my %restr; - - for my $restrlist (@{$q}) { - my $reststr = join ' ', sort @{$restrlist}; - $restr{$reststr} = 1; - } - for my $restrlist (@{$p}) { - my $reststr = join ' ', sort @{$restrlist}; - delete $restr{$reststr}; - } - - return keys %restr == 0; - } -} - -=item $dep->implies($other_dep) - -Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies -NOT($other_dep). Returns undef when there is no implication. $dep and -$other_dep do not need to be of the same type. - -=cut - -sub implies { - my ($self, $o) = @_; - if ($o->isa('Dpkg::Deps::Simple')) { - # An implication is only possible on the same package - return if $self->{package} ne $o->{package}; - - # Our architecture set must be a superset of the architectures for - # o, otherwise we can't conclude anything. - return unless _arch_is_superset($self->{arches}, $o->{arches}); - - # The arch qualifier must not forbid an implication - return unless _arch_qualifier_implies($self->{archqual}, - $o->{archqual}); - - # Our restrictions must imply the restrictions for o - return unless _restrictions_imply($self->{restrictions}, - $o->{restrictions}); - - # If o has no version clause, then our dependency is stronger - return 1 if not defined $o->{relation}; - # If o has a version clause, we must also have one, otherwise there - # can't be an implication - return if not defined $self->{relation}; - - return Dpkg::Deps::deps_eval_implication($self->{relation}, - $self->{version}, $o->{relation}, $o->{version}); - - } elsif ($o->isa('Dpkg::Deps::AND')) { - # TRUE: Need to imply all individual elements - # FALSE: Need to NOT imply at least one individual element - my $res = 1; - foreach my $dep ($o->get_deps()) { - my $implication = $self->implies($dep); - unless (defined($implication) && $implication == 1) { - $res = $implication; - last if defined $res; - } - } - return $res; - } elsif ($o->isa('Dpkg::Deps::OR')) { - # TRUE: Need to imply at least one individual element - # FALSE: Need to not apply all individual elements - # UNDEF: The rest - my $res = undef; - foreach my $dep ($o->get_deps()) { - my $implication = $self->implies($dep); - if (defined($implication)) { - if (not defined $res) { - $res = $implication; - } else { - if ($implication) { - $res = 1; - } else { - $res = 0; - } - } - last if defined($res) && $res == 1; - } - } - return $res; - } else { - croak 'Dpkg::Deps::Simple cannot evaluate implication with a ' . - ref($o); - } -} - -=item $dep->get_deps() - -Returns a list of sub-dependencies, which for this object it means it -returns itself. - -=cut - -sub get_deps { - my $self = shift; - return $self; -} - -=item $dep->sort() - -This method is a no-op for this object. - -=cut - -sub sort { - # Nothing to sort -} - -=item $dep->arch_is_concerned($arch) - -Returns true if the dependency applies to the indicated architecture. - -=cut - -sub arch_is_concerned { - my ($self, $host_arch) = @_; - - return 0 if not defined $self->{package}; # Empty dep - return 1 if not defined $self->{arches}; # Dep without arch spec - - return debarch_is_concerned($host_arch, @{$self->{arches}}); -} - -=item $dep->reduce_arch($arch) - -Simplifies the dependency to contain only information relevant to the given -architecture. This object can be left empty after this operation. This trims -off the architecture restriction list of these objects. - -=cut - -sub reduce_arch { - my ($self, $host_arch) = @_; - if (not $self->arch_is_concerned($host_arch)) { - $self->reset(); - } else { - $self->{arches} = undef; - } -} - -=item $dep->has_arch_restriction() - -Returns the package name if the dependency applies only to a subset of -architectures. - -=cut - -sub has_arch_restriction { - my $self = shift; - if (defined $self->{arches}) { - return $self->{package}; - } else { - return (); - } -} - -=item $dep->profile_is_concerned() - -Returns true if the dependency applies to the indicated profile. - -=cut - -sub profile_is_concerned { - my ($self, $build_profiles) = @_; - - return 0 if not defined $self->{package}; # Empty dep - return 1 if not defined $self->{restrictions}; # Dep without restrictions - return evaluate_restriction_formula($self->{restrictions}, $build_profiles); -} - -=item $dep->reduce_profiles() - -Simplifies the dependency to contain only information relevant to the given -profile. This object can be left empty after this operation. This trims off -the profile restriction list of this object. - -=cut - -sub reduce_profiles { - my ($self, $build_profiles) = @_; - - if (not $self->profile_is_concerned($build_profiles)) { - $self->reset(); - } else { - $self->{restrictions} = undef; - } -} - -=item $dep->get_evaluation($facts) - -Evaluates the dependency given a list of installed packages and a list of -virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts -object given as parameters. - -Returns 1 when it's true, 0 when it's false, undef when some information -is lacking to conclude. - -=cut - -sub get_evaluation { - my ($self, $facts) = @_; - return if not defined $self->{package}; - return $facts->evaluate_simple_dep($self); -} - -=item $dep->simplify_deps($facts, @assumed_deps) - -Simplifies the dependency as much as possible given the list of facts (see -object Dpkg::Deps::KnownFacts) and a list of other dependencies that are -known to be true. - -=cut - -sub simplify_deps { - my ($self, $facts) = @_; - my $eval = $self->get_evaluation($facts); - $self->reset() if defined $eval and $eval == 1; -} - -=item $dep->is_empty() - -Returns true if the dependency is empty and doesn't contain any useful -information. This is true when the object has not yet been initialized. - -=cut - -sub is_empty { - my $self = shift; - return not defined $self->{package}; -} - -=item $dep->merge_union($other_dep) - -Returns true if $dep could be modified to represent the union of both -dependencies. Otherwise returns false. - -=cut - -sub merge_union { - my ($self, $o) = @_; - return 0 if not $o->isa('Dpkg::Deps::Simple'); - return 0 if $self->is_empty() or $o->is_empty(); - return 0 if $self->{package} ne $o->{package}; - return 0 if defined $self->{arches} or defined $o->{arches}; - - if (not defined $o->{relation} and defined $self->{relation}) { - # Union is the non-versioned dependency - $self->{relation} = undef; - $self->{version} = undef; - return 1; - } - - my $implication = $self->implies($o); - my $rev_implication = $o->implies($self); - if (defined($implication)) { - if ($implication) { - $self->{relation} = $o->{relation}; - $self->{version} = $o->{version}; - return 1; - } else { - return 0; - } - } - if (defined($rev_implication)) { - if ($rev_implication) { - # Already merged... - return 1; - } else { - return 0; - } - } - return 0; -} - -=back - -=cut - -package Dpkg::Deps::Multiple; - -=head2 OBJECT - Dpkg::Deps::Multiple - -This is the base class for Dpkg::Deps::{AND,OR,Union}. - -=head2 METHODS - Dpkg::Deps::Multiple - -=over 4 - -=cut - -use strict; -use warnings; - -use Carp; - -use Dpkg::ErrorHandling; - -use parent qw(Dpkg::Interface::Storable); - -=item $dep = Dpkg::Deps::Multiple->new(%opts); - -Creates a new object. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = { list => [ @_ ] }; - bless $self, $class; - return $self; -} +=head1 CHANGES -=item $dep->reset() +=head2 Version 1.06 (dpkg 1.18.7; module version bumped on dpkg 1.18.24) -Clears any dependency information stored in $dep so that $dep->is_empty() -returns true. +New option: Add tests_dep option to Dpkg::Deps::deps_parse(). -=cut +=head2 Version 1.05 (dpkg 1.17.14) -sub reset { - my $self = shift; - $self->{list} = []; -} +New function: Dpkg::Deps::deps_iterate(). -=item $dep->add(@deps) +=head2 Version 1.04 (dpkg 1.17.10) -Adds new dependency objects at the end of the list. +New options: Add use_profiles, build_profiles, reduce_profiles and +reduce_restrictions to Dpkg::Deps::deps_parse(). -=cut +=head2 Version 1.03 (dpkg 1.17.0) -sub add { - my $self = shift; - push @{$self->{list}}, @_; -} +New option: Add build_arch option to Dpkg::Deps::deps_parse(). -=item $dep->get_deps() +=head2 Version 1.02 (dpkg 1.17.0) -Returns a list of sub-dependencies. - -=cut - -sub get_deps { - my $self = shift; - return grep { not $_->is_empty() } @{$self->{list}}; -} - -=item $dep->sort() - -Sorts alphabetically the internal list of dependencies. - -=cut - -sub sort { - my $self = shift; - my @res = (); - @res = sort { Dpkg::Deps::deps_compare($a, $b) } @{$self->{list}}; - $self->{list} = [ @res ]; -} - -=item $dep->arch_is_concerned($arch) - -Returns true if at least one of the sub-dependencies apply to this -architecture. - -=cut - -sub arch_is_concerned { - my ($self, $host_arch) = @_; - my $res = 0; - foreach my $dep (@{$self->{list}}) { - $res = 1 if $dep->arch_is_concerned($host_arch); - } - return $res; -} - -=item $dep->reduce_arch($arch) - -Simplifies the dependencies to contain only information relevant to the -given architecture. The non-relevant sub-dependencies are simply removed. - -This trims off the architecture restriction list of Dpkg::Deps::Simple -objects. - -=cut - -sub reduce_arch { - my ($self, $host_arch) = @_; - my @new; - foreach my $dep (@{$self->{list}}) { - $dep->reduce_arch($host_arch); - push @new, $dep if $dep->arch_is_concerned($host_arch); - } - $self->{list} = [ @new ]; -} - -=item $dep->has_arch_restriction() - -Returns the list of package names that have such a restriction. - -=cut - -sub has_arch_restriction { - my $self = shift; - my @res; - foreach my $dep (@{$self->{list}}) { - push @res, $dep->has_arch_restriction(); - } - return @res; -} - -=item $dep->profile_is_concerned() - -Returns true if at least one of the sub-dependencies apply to this profile. - -=cut - -sub profile_is_concerned { - my ($self, $build_profiles) = @_; - my $res = 0; - - foreach my $dep (@{$self->{list}}) { - $res = 1 if $dep->profile_is_concerned($build_profiles); - } - return $res; -} - -=item $dep->reduce_profiles() - -Simplifies the dependencies to contain only information relevant to the -given profile. The non-relevant sub-dependencies are simply removed. - -This trims off the profile restriction list of Dpkg::Deps::Simple objects. - -=cut - -sub reduce_profiles { - my ($self, $build_profiles) = @_; - my @new; - - foreach my $dep (@{$self->{list}}) { - $dep->reduce_profiles($build_profiles); - push @new, $dep if $dep->profile_is_concerned($build_profiles); - } - $self->{list} = [ @new ]; -} - -=item $dep->is_empty() - -Returns true if the dependency is empty and doesn't contain any useful -information. This is true when a (descendant of) Dpkg::Deps::Multiple -contains an empty list of dependencies. - -=cut - -sub is_empty { - my $self = shift; - return scalar @{$self->{list}} == 0; -} - -=item $dep->merge_union($other_dep) - -This method is not meaningful for this object, and will always croak. - -=cut - -sub merge_union { - croak 'method merge_union() is only valid for Dpkg::Deps::Simple'; -} - -=back - -=cut - -package Dpkg::Deps::AND; - -=head2 OBJECT - Dpkg::Deps::AND - -This object represents a list of dependencies that must be met at the same -time. It inherits from Dpkg::Deps::Multiple. - -=head2 METHODS - Dpkg::Deps::AND - -=over 4 - -=cut - -use strict; -use warnings; - -use parent -norequire, qw(Dpkg::Deps::Multiple); - -=item $dep->output([$fh]) - -The output method uses ", " to join the list of sub-dependencies. - -=cut - -sub output { - my ($self, $fh) = @_; - my $res = join(', ', map { $_->output() } grep { not $_->is_empty() } $self->get_deps()); - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -=item $dep->implies($other_dep) - -Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies -NOT($other_dep). Returns undef when there's no implication. $dep and -$other_dep do not need to be of the same type. - -=cut - -sub implies { - my ($self, $o) = @_; - # If any individual member can imply $o or NOT $o, we're fine - foreach my $dep ($self->get_deps()) { - my $implication = $dep->implies($o); - return 1 if defined($implication) && $implication == 1; - return 0 if defined($implication) && $implication == 0; - } - # If o is an AND, we might have an implication, if we find an - # implication within us for each predicate in o - if ($o->isa('Dpkg::Deps::AND')) { - my $subset = 1; - foreach my $odep ($o->get_deps()) { - my $found = 0; - foreach my $dep ($self->get_deps()) { - $found = 1 if $dep->implies($odep); - } - $subset = 0 if not $found; - } - return 1 if $subset; - } - return; -} - -=item $dep->get_evaluation($facts) - -Evaluates the dependency given a list of installed packages and a list of -virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts -object given as parameters. - -Returns 1 when it's true, 0 when it's false, undef when some information -is lacking to conclude. - -=cut - -sub get_evaluation { - my ($self, $facts) = @_; - # Return 1 only if all members evaluates to true - # Return 0 if at least one member evaluates to false - # Return undef otherwise - my $result = 1; - foreach my $dep ($self->get_deps()) { - my $eval = $dep->get_evaluation($facts); - if (not defined $eval) { - $result = undef; - } elsif ($eval == 0) { - $result = 0; - last; - } elsif ($eval == 1) { - # Still possible - } - } - return $result; -} - -=item $dep->simplify_deps($facts, @assumed_deps) - -Simplifies the dependency as much as possible given the list of facts (see -object Dpkg::Deps::KnownFacts) and a list of other dependencies that are -known to be true. - -=cut - -sub simplify_deps { - my ($self, $facts, @knowndeps) = @_; - my @new; - -WHILELOOP: - while (@{$self->{list}}) { - my $dep = shift @{$self->{list}}; - my $eval = $dep->get_evaluation($facts); - next if defined($eval) and $eval == 1; - foreach my $odep (@knowndeps, @new) { - next WHILELOOP if $odep->implies($dep); - } - # When a dependency is implied by another dependency that - # follows, then invert them - # "a | b, c, a" becomes "a, c" and not "c, a" - my $i = 0; - foreach my $odep (@{$self->{list}}) { - if (defined $odep and $odep->implies($dep)) { - splice @{$self->{list}}, $i, 1; - unshift @{$self->{list}}, $odep; - next WHILELOOP; - } - $i++; - } - push @new, $dep; - } - $self->{list} = [ @new ]; -} - -=back - -=cut - -package Dpkg::Deps::OR; - -=head2 OBJECT - Dpkg::Deps::OR - -This object represents a list of dependencies of which only one must be met -for the dependency to be true. It inherits from Dpkg::Deps::Multiple. - -=head2 METHODS - Dpkg::Deps::OR - -=over 4 - -=cut - -use strict; -use warnings; - -use parent -norequire, qw(Dpkg::Deps::Multiple); - -=item $dep->output([$fh]) - -The output method uses " | " to join the list of sub-dependencies. - -=cut - -sub output { - my ($self, $fh) = @_; - my $res = join(' | ', map { $_->output() } grep { not $_->is_empty() } $self->get_deps()); - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -=item $dep->implies($other_dep) - -Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies -NOT($other_dep). Returns undef when there's no implication. $dep and -$other_dep do not need to be of the same type. - -=cut - -sub implies { - my ($self, $o) = @_; - - # Special case for AND with a single member, replace it by its member - if ($o->isa('Dpkg::Deps::AND')) { - my @subdeps = $o->get_deps(); - if (scalar(@subdeps) == 1) { - $o = $subdeps[0]; - } - } - - # In general, an OR dependency can't imply anything except if each - # of its member implies a member in the other OR dependency - if ($o->isa('Dpkg::Deps::OR')) { - my $subset = 1; - foreach my $dep ($self->get_deps()) { - my $found = 0; - foreach my $odep ($o->get_deps()) { - $found = 1 if $dep->implies($odep); - } - $subset = 0 if not $found; - } - return 1 if $subset; - } - return; -} - -=item $dep->get_evaluation($facts) - -Evaluates the dependency given a list of installed packages and a list of -virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts -object given as parameters. - -Returns 1 when it's true, 0 when it's false, undef when some information -is lacking to conclude. - -=cut - -sub get_evaluation { - my ($self, $facts) = @_; - # Returns false if all members evaluates to 0 - # Returns true if at least one member evaluates to true - # Returns undef otherwise - my $result = 0; - foreach my $dep ($self->get_deps()) { - my $eval = $dep->get_evaluation($facts); - if (not defined $eval) { - $result = undef; - } elsif ($eval == 1) { - $result = 1; - last; - } elsif ($eval == 0) { - # Still possible to have a false evaluation - } - } - return $result; -} - -=item $dep->simplify_deps($facts, @assumed_deps) - -Simplifies the dependency as much as possible given the list of facts (see -object Dpkg::Deps::KnownFacts) and a list of other dependencies that are -known to be true. - -=cut - -sub simplify_deps { - my ($self, $facts) = @_; - my @new; - -WHILELOOP: - while (@{$self->{list}}) { - my $dep = shift @{$self->{list}}; - my $eval = $dep->get_evaluation($facts); - if (defined($eval) and $eval == 1) { - $self->{list} = []; - return; - } - foreach my $odep (@new, @{$self->{list}}) { - next WHILELOOP if $odep->implies($dep); - } - push @new, $dep; - } - $self->{list} = [ @new ]; -} - -=back - -=cut - -package Dpkg::Deps::Union; - -=head2 OBJECT - Dpkg::Deps::Union - -This object represents a list of relationships. It inherits from -Dpkg::Deps::Multiple. - -=head2 METHODS - Dpkg::Deps::Union - -=over 4 - -=cut - -use strict; -use warnings; - -use parent -norequire, qw(Dpkg::Deps::Multiple); - -=item $dep->output([$fh]) - -The output method uses ", " to join the list of relationships. - -=cut - -sub output { - my ($self, $fh) = @_; - my $res = join(', ', map { $_->output() } grep { not $_->is_empty() } $self->get_deps()); - if (defined($fh)) { - print { $fh } $res; - } - return $res; -} - -=item $dep->implies($other_dep) - -=item $dep->get_evaluation($other_dep) - -These methods are not meaningful for this object and always return undef. - -=cut - -sub implies { - # Implication test is not useful on Union. - return; -} - -sub get_evaluation { - # Evaluation is not useful on Union. - return; -} - -=item $dep->simplify_deps($facts) - -The simplification is done to generate an union of all the relationships. -It uses $simple_dep->merge_union($other_dep) to get its job done. - -=cut - -sub simplify_deps { - my ($self, $facts) = @_; - my @new; - -WHILELOOP: - while (@{$self->{list}}) { - my $odep = shift @{$self->{list}}; - foreach my $dep (@new) { - next WHILELOOP if $dep->merge_union($odep); - } - push @new, $odep; - } - $self->{list} = [ @new ]; -} - -=back - -=cut - -package Dpkg::Deps::KnownFacts; - -=head2 OBJECT - Dpkg::Deps::KnownFacts - -This object represents a list of installed packages and a list of virtual -packages provided (by the set of installed packages). - -=head2 METHODS - Dpkg::Deps::KnownFacts - -=over 4 - -=cut - -use strict; -use warnings; - -use Dpkg::Version; - -=item $facts = Dpkg::Deps::KnownFacts->new(); - -Creates a new object. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = { - pkg => {}, - virtualpkg => {}, - }; - bless $self, $class; - return $self; -} - -=item $facts->add_installed_package($package, $version, $arch, $multiarch) - -Records that the given version of the package is installed. If -$version/$arch is undefined we know that the package is installed but we -don't know which version/architecture it is. $multiarch is the Multi-Arch -field of the package. If $multiarch is undef, it will be equivalent to -"Multi-Arch: no". - -Note that $multiarch is only used if $arch is provided. - -=cut - -sub add_installed_package { - my ($self, $pkg, $ver, $arch, $multiarch) = @_; - my $p = { - package => $pkg, - version => $ver, - architecture => $arch, - multiarch => $multiarch // 'no', - }; - $self->{pkg}{"$pkg:$arch"} = $p if defined $arch; - push @{$self->{pkg}{$pkg}}, $p; -} - -=item $facts->add_provided_package($virtual, $relation, $version, $by) - -Records that the "$by" package provides the $virtual package. $relation -and $version correspond to the associated relation given in the Provides -field (if present). - -=cut - -sub add_provided_package { - my ($self, $pkg, $rel, $ver, $by) = @_; - my $v = { - package => $pkg, - relation => $rel, - version => $ver, - provider => $by, - }; - - $self->{virtualpkg}{$pkg} //= []; - push @{$self->{virtualpkg}{$pkg}}, $v; -} - -=item ($check, $param) = $facts->check_package($package) - -$check is one when the package is found. For a real package, $param -contains the version. For a virtual package, $param contains an array -reference containing the list of packages that provide it (each package is -listed as [ $provider, $relation, $version ]). - -This function is obsolete and should not be used. Dpkg::Deps::KnownFacts -is only meant to be filled with data and then passed to Dpkg::Deps -methods where appropriate, but it should not be directly queried. - -=cut - -sub check_package { - my ($self, $pkg) = @_; - - warnings::warnif('deprecated', 'obsolete function, pass ' . - 'Dpkg::Deps::KnownFacts to Dpkg::Deps methods instead'); - - if (exists $self->{pkg}{$pkg}) { - return (1, $self->{pkg}{$pkg}[0]{version}); - } - if (exists $self->{virtualpkg}{$pkg}) { - my $arrayref = [ map { [ - $_->{provider}, $_->{relation}, $_->{version} - ] } @{$self->{virtualpkg}{$pkg}} ]; - return (1, $arrayref); - } - return (0, undef); -} - -## -## The functions below are private to Dpkg::Deps::KnownFacts. -## - -sub _find_package { - my ($self, $dep, $lackinfos) = @_; - my ($pkg, $archqual) = ($dep->{package}, $dep->{archqual}); - return if not exists $self->{pkg}{$pkg}; - my $host_arch = $dep->{host_arch} // Dpkg::Arch::get_host_arch(); - my $build_arch = $dep->{build_arch} // Dpkg::Arch::get_build_arch(); - foreach my $p (@{$self->{pkg}{$pkg}}) { - my $a = $p->{architecture}; - my $ma = $p->{multiarch}; - if (not defined $a) { - $$lackinfos = 1; - next; - } - if (not defined $archqual) { - return $p if $ma eq 'foreign'; - return $p if $a eq $host_arch or $a eq 'all'; - } elsif ($archqual eq 'any') { - return $p if $ma eq 'allowed'; - } elsif ($archqual eq 'native') { - return $p if $a eq $build_arch and $ma ne 'foreign'; - } else { - return $p if $a eq $archqual; - } - } - return; -} - -sub _find_virtual_packages { - my ($self, $pkg) = @_; - return () if not exists $self->{virtualpkg}{$pkg}; - return @{$self->{virtualpkg}{$pkg}}; -} - -=item $facts->evaluate_simple_dep() - -This method is private and should not be used except from within Dpkg::Deps. - -=cut - -sub evaluate_simple_dep { - my ($self, $dep) = @_; - my ($lackinfos, $pkg) = (0, $dep->{package}); - my $p = $self->_find_package($dep, \$lackinfos); - if ($p) { - if (defined $dep->{relation}) { - if (defined $p->{version}) { - return 1 if version_compare_relation($p->{version}, - $dep->{relation}, $dep->{version}); - } else { - $lackinfos = 1; - } - } else { - return 1; - } - } - foreach my $virtpkg ($self->_find_virtual_packages($pkg)) { - next if defined $virtpkg->{relation} and $virtpkg->{relation} ne REL_EQ; - - if (defined $dep->{relation}) { - next if not defined $virtpkg->{version}; - return 1 if version_compare_relation($virtpkg->{version}, - $dep->{relation}, - $dep->{version}); - } else { - return 1; - } - } - return if $lackinfos; - return 0; -} - -=back - -=head1 CHANGES - -=head2 Version 1.06 (dpkg 1.18.7; module version bumped on dpkg 1.18.24) - -New option: Add tests_dep option to Dpkg::Deps::deps_parse(). - -=head2 Version 1.05 (dpkg 1.17.14) - -New function: Dpkg::Deps::deps_iterate(). - -=head2 Version 1.04 (dpkg 1.17.10) - -New options: Add use_profiles, build_profiles, reduce_profiles and -reduce_restrictions to Dpkg::Deps::deps_parse(). - -New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles() -for all dependency objects. - -=head2 Version 1.03 (dpkg 1.17.0) - -New option: Add build_arch option to Dpkg::Deps::deps_parse(). - -=head2 Version 1.02 (dpkg 1.17.0) - -New function: Dpkg::Deps::deps_concat() +New function: Dpkg::Deps::deps_concat() =head2 Version 1.01 (dpkg 1.16.1) -New method: Add $dep->reset() for all dependency objects. - -New property: Dpkg::Deps::Simple now recognizes the arch qualifier "any" -and stores it in the "archqual" property when present. - -New option: Dpkg::Deps::KnownFacts->add_installed_package() now accepts 2 -supplementary parameters ($arch and $multiarch). - -Deprecated method: Dpkg::Deps::KnownFacts->check_package() is obsolete, -it should not have been part of the public API. +<Used to document changes to Dpkg::Deps::* modules before they were split.> =head2 Version 1.00 (dpkg 1.15.6) diff --git a/scripts/Dpkg/Deps/AND.pm b/scripts/Dpkg/Deps/AND.pm new file mode 100644 index 000000000..e16a2cf35 --- /dev/null +++ b/scripts/Dpkg/Deps/AND.pm @@ -0,0 +1,182 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <[email protected]> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <[email protected]> +# +# This program is free software; you may redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dpkg::Deps::AND; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::AND - list of AND dependencies + +=head1 DESCRIPTION + +This object represents a list of dependencies that must be met at the same +time. It inherits from Dpkg::Deps::Multiple. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output method uses ", " to join the list of sub-dependencies. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(', ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there's no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + # If any individual member can imply $o or NOT $o, we're fine + foreach my $dep ($self->get_deps()) { + my $implication = $dep->implies($o); + return 1 if defined $implication and $implication == 1; + return 0 if defined $implication and $implication == 0; + } + + # If o is an AND, we might have an implication, if we find an + # implication within us for each predicate in o + if ($o->isa('Dpkg::Deps::AND')) { + my $subset = 1; + foreach my $odep ($o->get_deps()) { + my $found = 0; + foreach my $dep ($self->get_deps()) { + $found = 1 if $dep->implies($odep); + } + $subset = 0 if not $found; + } + return 1 if $subset; + } + return; +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts +object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + # Return 1 only if all members evaluates to true + # Return 0 if at least one member evaluates to false + # Return undef otherwise + my $result = 1; + foreach my $dep ($self->get_deps()) { + my $eval = $dep->get_evaluation($facts); + if (not defined $eval) { + $result = undef; + } elsif ($eval == 0) { + $result = 0; + last; + } elsif ($eval == 1) { + # Still possible + } + } + return $result; +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +object Dpkg::Deps::KnownFacts) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts, @knowndeps) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $dep = shift @{$self->{list}}; + my $eval = $dep->get_evaluation($facts); + next if defined $eval and $eval == 1; + foreach my $odep (@knowndeps, @new) { + next WHILELOOP if $odep->implies($dep); + } + # When a dependency is implied by another dependency that + # follows, then invert them + # "a | b, c, a" becomes "a, c" and not "c, a" + my $i = 0; + foreach my $odep (@{$self->{list}}) { + if (defined $odep and $odep->implies($dep)) { + splice @{$self->{list}}, $i, 1; + unshift @{$self->{list}}, $odep; + next WHILELOOP; + } + $i++; + } + push @new, $dep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/KnownFacts.pm b/scripts/Dpkg/Deps/KnownFacts.pm new file mode 100644 index 000000000..95770ec00 --- /dev/null +++ b/scripts/Dpkg/Deps/KnownFacts.pm @@ -0,0 +1,244 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <[email protected]> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <[email protected]> +# +# This program is free software; you may redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dpkg::Deps::KnownFacts; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::KnownFacts - list of installed real and virtual packages + +=head1 DESCRIPTION + +This object represents a list of installed packages and a list of virtual +packages provided (by the set of installed packages). + +=cut + +use strict; +use warnings; + +our $VERSION = '1.01'; + +use Dpkg::Version; + +=head1 METHODS + +=over 4 + +=item $facts = Dpkg::Deps::KnownFacts->new(); + +Creates a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { + pkg => {}, + virtualpkg => {}, + }; + + bless $self, $class; + return $self; +} + +=item $facts->add_installed_package($package, $version, $arch, $multiarch) + +Records that the given version of the package is installed. If +$version/$arch is undefined we know that the package is installed but we +don't know which version/architecture it is. $multiarch is the Multi-Arch +field of the package. If $multiarch is undef, it will be equivalent to +"Multi-Arch: no". + +Note that $multiarch is only used if $arch is provided. + +=cut + +sub add_installed_package { + my ($self, $pkg, $ver, $arch, $multiarch) = @_; + my $p = { + package => $pkg, + version => $ver, + architecture => $arch, + multiarch => $multiarch // 'no', + }; + + $self->{pkg}{"$pkg:$arch"} = $p if defined $arch; + push @{$self->{pkg}{$pkg}}, $p; +} + +=item $facts->add_provided_package($virtual, $relation, $version, $by) + +Records that the "$by" package provides the $virtual package. $relation +and $version correspond to the associated relation given in the Provides +field (if present). + +=cut + +sub add_provided_package { + my ($self, $pkg, $rel, $ver, $by) = @_; + my $v = { + package => $pkg, + relation => $rel, + version => $ver, + provider => $by, + }; + + $self->{virtualpkg}{$pkg} //= []; + push @{$self->{virtualpkg}{$pkg}}, $v; +} + +=item ($check, $param) = $facts->check_package($package) + +$check is one when the package is found. For a real package, $param +contains the version. For a virtual package, $param contains an array +reference containing the list of packages that provide it (each package is +listed as [ $provider, $relation, $version ]). + +This function is obsolete and should not be used. Dpkg::Deps::KnownFacts +is only meant to be filled with data and then passed to Dpkg::Deps +methods where appropriate, but it should not be directly queried. + +=cut + +sub check_package { + my ($self, $pkg) = @_; + + warnings::warnif('deprecated', 'obsolete function, pass ' . + 'Dpkg::Deps::KnownFacts to Dpkg::Deps methods instead'); + + if (exists $self->{pkg}{$pkg}) { + return (1, $self->{pkg}{$pkg}[0]{version}); + } + if (exists $self->{virtualpkg}{$pkg}) { + my $arrayref = [ map { [ + $_->{provider}, $_->{relation}, $_->{version} + ] } @{$self->{virtualpkg}{$pkg}} ]; + return (1, $arrayref); + } + return (0, undef); +} + +## +## The functions below are private to Dpkg::Deps::KnownFacts. +## + +sub _find_package { + my ($self, $dep, $lackinfos) = @_; + my ($pkg, $archqual) = ($dep->{package}, $dep->{archqual}); + + return if not exists $self->{pkg}{$pkg}; + + my $host_arch = $dep->{host_arch} // Dpkg::Arch::get_host_arch(); + my $build_arch = $dep->{build_arch} // Dpkg::Arch::get_build_arch(); + + foreach my $p (@{$self->{pkg}{$pkg}}) { + my $a = $p->{architecture}; + my $ma = $p->{multiarch}; + + if (not defined $a) { + $$lackinfos = 1; + next; + } + if (not defined $archqual) { + return $p if $ma eq 'foreign'; + return $p if $a eq $host_arch or $a eq 'all'; + } elsif ($archqual eq 'any') { + return $p if $ma eq 'allowed'; + } elsif ($archqual eq 'native') { + return $p if $a eq $build_arch and $ma ne 'foreign'; + } else { + return $p if $a eq $archqual; + } + } + return; +} + +sub _find_virtual_packages { + my ($self, $pkg) = @_; + + return () if not exists $self->{virtualpkg}{$pkg}; + return @{$self->{virtualpkg}{$pkg}}; +} + +=item $facts->evaluate_simple_dep() + +This method is private and should not be used except from within Dpkg::Deps. + +=cut + +sub evaluate_simple_dep { + my ($self, $dep) = @_; + my ($lackinfos, $pkg) = (0, $dep->{package}); + + my $p = $self->_find_package($dep, \$lackinfos); + if ($p) { + if (defined $dep->{relation}) { + if (defined $p->{version}) { + return 1 if version_compare_relation($p->{version}, + $dep->{relation}, + $dep->{version}); + } else { + $lackinfos = 1; + } + } else { + return 1; + } + } + foreach my $virtpkg ($self->_find_virtual_packages($pkg)) { + next if defined $virtpkg->{relation} and + $virtpkg->{relation} ne REL_EQ; + + if (defined $dep->{relation}) { + next if not defined $virtpkg->{version}; + return 1 if version_compare_relation($virtpkg->{version}, + $dep->{relation}, + $dep->{version}); + } else { + return 1; + } + } + return if $lackinfos; + return 0; +} + +=back + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.16.1) + +New option: Dpkg::Deps::KnownFacts->add_installed_package() now accepts 2 +supplementary parameters ($arch and $multiarch). + +Deprecated method: Dpkg::Deps::KnownFacts->check_package() is obsolete, +it should not have been part of the public API. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Multiple.pm b/scripts/Dpkg/Deps/Multiple.pm new file mode 100644 index 000000000..da12f5184 --- /dev/null +++ b/scripts/Dpkg/Deps/Multiple.pm @@ -0,0 +1,250 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <[email protected]> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <[email protected]> +# +# This program is free software; you may redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dpkg::Deps::Multiple; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Multiple - base module to represent multiple dependencies + +=head1 DESCRIPTION + +The Dpkg::Deps::Multiple module provides objects implementing various types +of dependencies. It is the base class for Dpkg::Deps::{AND,OR,Union}. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.02'; + +use Carp; + +use Dpkg::ErrorHandling; + +use parent qw(Dpkg::Interface::Storable); + +=head1 METHODS + +=over 4 + +=item $dep = Dpkg::Deps::Multiple->new(%opts); + +Creates a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = { list => [ @_ ] }; + + bless $self, $class; + return $self; +} + +=item $dep->reset() + +Clears any dependency information stored in $dep so that $dep->is_empty() +returns true. + +=cut + +sub reset { + my $self = shift; + + $self->{list} = []; +} + +=item $dep->add(@deps) + +Adds new dependency objects at the end of the list. + +=cut + +sub add { + my $self = shift; + + push @{$self->{list}}, @_; +} + +=item $dep->get_deps() + +Returns a list of sub-dependencies. + +=cut + +sub get_deps { + my $self = shift; + + return grep { not $_->is_empty() } @{$self->{list}}; +} + +=item $dep->sort() + +Sorts alphabetically the internal list of dependencies. + +=cut + +sub sort { + my $self = shift; + + my @res = (); + @res = sort { Dpkg::Deps::deps_compare($a, $b) } @{$self->{list}}; + $self->{list} = [ @res ]; +} + +=item $dep->arch_is_concerned($arch) + +Returns true if at least one of the sub-dependencies apply to this +architecture. + +=cut + +sub arch_is_concerned { + my ($self, $host_arch) = @_; + + my $res = 0; + foreach my $dep (@{$self->{list}}) { + $res = 1 if $dep->arch_is_concerned($host_arch); + } + return $res; +} + +=item $dep->reduce_arch($arch) + +Simplifies the dependencies to contain only information relevant to the +given architecture. The non-relevant sub-dependencies are simply removed. + +This trims off the architecture restriction list of Dpkg::Deps::Simple +objects. + +=cut + +sub reduce_arch { + my ($self, $host_arch) = @_; + + my @new; + foreach my $dep (@{$self->{list}}) { + $dep->reduce_arch($host_arch); + push @new, $dep if $dep->arch_is_concerned($host_arch); + } + $self->{list} = [ @new ]; +} + +=item $dep->has_arch_restriction() + +Returns the list of package names that have such a restriction. + +=cut + +sub has_arch_restriction { + my $self = shift; + + my @res; + foreach my $dep (@{$self->{list}}) { + push @res, $dep->has_arch_restriction(); + } + return @res; +} + +=item $dep->profile_is_concerned() + +Returns true if at least one of the sub-dependencies apply to this profile. + +=cut + +sub profile_is_concerned { + my ($self, $build_profiles) = @_; + + my $res = 0; + foreach my $dep (@{$self->{list}}) { + $res = 1 if $dep->profile_is_concerned($build_profiles); + } + return $res; +} + +=item $dep->reduce_profiles() + +Simplifies the dependencies to contain only information relevant to the +given profile. The non-relevant sub-dependencies are simply removed. + +This trims off the profile restriction list of Dpkg::Deps::Simple objects. + +=cut + +sub reduce_profiles { + my ($self, $build_profiles) = @_; + + my @new; + foreach my $dep (@{$self->{list}}) { + $dep->reduce_profiles($build_profiles); + push @new, $dep if $dep->profile_is_concerned($build_profiles); + } + $self->{list} = [ @new ]; +} + +=item $dep->is_empty() + +Returns true if the dependency is empty and doesn't contain any useful +information. This is true when a (descendant of) Dpkg::Deps::Multiple +contains an empty list of dependencies. + +=cut + +sub is_empty { + my $self = shift; + + return scalar @{$self->{list}} == 0; +} + +=item $dep->merge_union($other_dep) + +This method is not meaningful for this object, and will always croak. + +=cut + +sub merge_union { + croak 'method merge_union() is only valid for Dpkg::Deps::Simple'; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.17.10) + +New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New method: Add $dep->reset(). + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/OR.pm b/scripts/Dpkg/Deps/OR.pm new file mode 100644 index 000000000..b2f8d03ed --- /dev/null +++ b/scripts/Dpkg/Deps/OR.pm @@ -0,0 +1,174 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <[email protected]> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <[email protected]> +# +# This program is free software; you may redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dpkg::Deps::OR; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::OR - list of OR dependencies + +=head1 DESCRIPTION + +This object represents a list of dependencies of which only one must be met +for the dependency to be true. It inherits from Dpkg::Deps::Multiple. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output method uses " | " to join the list of sub-dependencies. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(' | ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there's no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + # Special case for AND with a single member, replace it by its member + if ($o->isa('Dpkg::Deps::AND')) { + my @subdeps = $o->get_deps(); + if (scalar(@subdeps) == 1) { + $o = $subdeps[0]; + } + } + + # In general, an OR dependency can't imply anything except if each + # of its member implies a member in the other OR dependency + if ($o->isa('Dpkg::Deps::OR')) { + my $subset = 1; + foreach my $dep ($self->get_deps()) { + my $found = 0; + foreach my $odep ($o->get_deps()) { + $found = 1 if $dep->implies($odep); + } + $subset = 0 if not $found; + } + return 1 if $subset; + } + return; +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts +object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + # Returns false if all members evaluates to 0 + # Returns true if at least one member evaluates to true + # Returns undef otherwise + my $result = 0; + foreach my $dep ($self->get_deps()) { + my $eval = $dep->get_evaluation($facts); + if (not defined $eval) { + $result = undef; + } elsif ($eval == 1) { + $result = 1; + last; + } elsif ($eval == 0) { + # Still possible to have a false evaluation + } + } + return $result; +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +object Dpkg::Deps::KnownFacts) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $dep = shift @{$self->{list}}; + my $eval = $dep->get_evaluation($facts); + if (defined $eval and $eval == 1) { + $self->{list} = []; + return; + } + foreach my $odep (@new, @{$self->{list}}) { + next WHILELOOP if $odep->implies($dep); + } + push @new, $dep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Simple.pm b/scripts/Dpkg/Deps/Simple.pm new file mode 100644 index 000000000..0557c7cfc --- /dev/null +++ b/scripts/Dpkg/Deps/Simple.pm @@ -0,0 +1,659 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <[email protected]> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <[email protected]> +# +# This program is free software; you may redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dpkg::Deps::Simple; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Simple - represents a single dependency statement + +=head1 DESCRIPTION + +This object has several interesting properties: + +=over 4 + +=item package + +The package name (can be undef if the dependency has not been initialized +or if the simplification of the dependency lead to its removal). + +=item relation + +The relational operator: "=", "<<", "<=", ">=" or ">>". It can be +undefined if the dependency had no version restriction. In that case the +following field is also undefined. + +=item version + +The version. + +=item arches + +The list of architectures where this dependency is applicable. It is +undefined when there's no restriction, otherwise it is an +array ref. It can contain an exclusion list, in that case each +architecture is prefixed with an exclamation mark. + +=item archqual + +The arch qualifier of the dependency (can be undef if there is none). +In the dependency "python:any (>= 2.6)", the arch qualifier is "any". + +=item restrictions + +The restrictions formula for this dependency. It is undefined when there +is no restriction formula. Otherwise it is an array ref. + +=back + +=head1 METHODS + +=over 4 + +=cut + +use strict; +use warnings; + +our $VERSION = '1.02'; + +use Carp; + +use Dpkg::Arch qw(debarch_is_concerned debarch_list_parse); +use Dpkg::BuildProfiles qw(parse_build_profiles evaluate_restriction_formula); +use Dpkg::Version; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +use parent qw(Dpkg::Interface::Storable); + +=item $dep = Dpkg::Deps::Simple->new(%opts); + +Creates a new object. Some options can be set through %opts: + +=over + +=item host_arch + +Sets the host architecture. + +=item build_arch + +Sets the build architecture. + +=item build_dep + +Specifies whether the parser should consider it a build dependency. +Defaults to 0. + +=item tests_dep + +Specifies whether the parser should consider it a tests dependency. +Defaults to 0. + +=back + +=cut + +sub new { + my ($this, $arg, %opts) = @_; + my $class = ref($this) || $this; + my $self = {}; + + bless $self, $class; + $self->reset(); + $self->{host_arch} = $opts{host_arch}; + $self->{build_arch} = $opts{build_arch}; + $self->{build_dep} = $opts{build_dep} // 0; + $self->{tests_dep} = $opts{tests_dep} // 0; + $self->parse_string($arg) if defined $arg; + return $self; +} + +=item $dep->reset() + +Clears any dependency information stored in $dep so that $dep->is_empty() +returns true. + +=cut + +sub reset { + my $self = shift; + + $self->{package} = undef; + $self->{relation} = undef; + $self->{version} = undef; + $self->{arches} = undef; + $self->{archqual} = undef; + $self->{restrictions} = undef; +} + +=item $dep->parse($fh, $desc) + +Parses a line from a filehandle. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + my $line = <$fh>; + chomp $line; + return $self->parse_string($line); +} + +=item $dep->parse_string($dep_string) + +Parses the dependency string and modifies internal properties to match the +parsed dependency. + +=cut + +sub parse_string { + my ($self, $dep) = @_; + + my $pkgname_re; + if ($self->{tests_dep}) { + $pkgname_re = qr/[\@a-zA-Z0-9][\@a-zA-Z0-9+.-]*/; + } else { + $pkgname_re = qr/[a-zA-Z0-9][a-zA-Z0-9+.-]*/; + } + + return if not $dep =~ + m{^\s* # skip leading whitespace + ($pkgname_re) # package name + (?: # start of optional part + : # colon for architecture + ([a-zA-Z0-9][a-zA-Z0-9-]*) # architecture name + )? # end of optional part + (?: # start of optional part + \s* \( # open parenthesis for version part + \s* (<<|<=|=|>=|>>|[<>]) # relation part + \s* ([^\)\s]+) # do not attempt to parse version + \s* \) # closing parenthesis + )? # end of optional part + (?: # start of optional architecture + \s* \[ # open bracket for architecture + \s* ([^\]]+) # don't parse architectures now + \s* \] # closing bracket + )? # end of optional architecture + ( + (?: # start of optional restriction + \s* < # open bracket for restriction + \s* [^>]+ # do not parse restrictions now + \s* > # closing bracket + )+ + )? # end of optional restriction + \s*$ # trailing spaces at end + }x; + if (defined $2) { + return if $2 eq 'native' and not $self->{build_dep}; + $self->{archqual} = $2; + } + $self->{package} = $1; + $self->{relation} = version_normalize_relation($3) if defined $3; + if (defined $4) { + $self->{version} = Dpkg::Version->new($4); + } + if (defined $5) { + $self->{arches} = [ debarch_list_parse($5) ]; + } + if (defined $6) { + $self->{restrictions} = [ parse_build_profiles($6) ]; + } +} + +=item $dep->output([$fh]) + +=item "$dep" + +Returns a string representing the dependency. If $fh is set, it prints +the string to the filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = $self->{package}; + if (defined $self->{archqual}) { + $res .= ':' . $self->{archqual}; + } + if (defined $self->{relation}) { + $res .= ' (' . $self->{relation} . ' ' . $self->{version} . ')'; + } + if (defined $self->{arches}) { + $res .= ' [' . join(' ', @{$self->{arches}}) . ']'; + } + if (defined $self->{restrictions}) { + for my $restrlist (@{$self->{restrictions}}) { + $res .= ' <' . join(' ', @{$restrlist}) . '>'; + } + } + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +# _arch_is_superset(\@p, \@q) +# +# Returns true if the arch list @p is a superset of arch list @q. +# The arguments can also be undef in case there's no explicit architecture +# restriction. +sub _arch_is_superset { + my ($p, $q) = @_; + my $p_arch_neg = defined $p and $p->[0] =~ /^!/; + my $q_arch_neg = defined $q and $q->[0] =~ /^!/; + + # If "p" has no arches, it is a superset of q and we should fall through + # to the version check. + if (not defined $p) { + return 1; + } + # If q has no arches, it is a superset of p and there are no useful + # implications. + elsif (not defined $q) { + return 0; + } + # Both have arches. If neither are negated, we know nothing useful + # unless q is a subset of p. + elsif (not $p_arch_neg and not $q_arch_neg) { + my %p_arches = map { $_ => 1 } @{$p}; + my $subset = 1; + for my $arch (@{$q}) { + $subset = 0 unless $p_arches{$arch}; + } + return 0 unless $subset; + } + # If both are negated, we know nothing useful unless p is a subset of + # q (and therefore has fewer things excluded, and therefore is more + # general). + elsif ($p_arch_neg and $q_arch_neg) { + my %q_arches = map { $_ => 1 } @{$q}; + my $subset = 1; + for my $arch (@{$p}) { + $subset = 0 unless $q_arches{$arch}; + } + return 0 unless $subset; + } + # If q is negated and p isn't, we'd need to know the full list of + # arches to know if there's any relationship, so bail. + elsif (not $p_arch_neg and $q_arch_neg) { + return 0; + } + # If p is negated and q isn't, q is a subset of p if none of the + # negated arches in p are present in q. + elsif ($p_arch_neg and not $q_arch_neg) { + my %q_arches = map { $_ => 1 } @{$q}; + my $subset = 1; + for my $arch (@{$p}) { + $subset = 0 if $q_arches{substr($arch, 1)}; + } + return 0 unless $subset; + } + return 1; +} + +# _arch_qualifier_implies($p, $q) +# +# Returns true if the arch qualifier $p and $q are compatible with the +# implication $p -> $q, false otherwise. $p/$q can be undef/"any"/"native" +# or an architecture string. +# +# Because we are handling dependencies in isolation, and the full context +# of the implications are only known when doing dependency resolution at +# run-time, we can only assert that they are implied if they are equal. +# +# For example dependencies with different arch-qualifiers cannot be simplified +# as these depend on the state of Multi-Arch field in the package depended on. +sub _arch_qualifier_implies { + my ($p, $q) = @_; + + return $p eq $q if defined $p and defined $q; + return 1 if not defined $p and not defined $q; + return 0; +} + +# _restrictions_imply($p, $q) +# +# Returns true if the restrictions $p and $q are compatible with the +# implication $p -> $q, false otherwise. +# NOTE: We don't try to be very clever here, so we may conservatively +# return false when there is an implication. +sub _restrictions_imply { + my ($p, $q) = @_; + + if (not defined $p) { + return 1; + } elsif (not defined $q) { + return 0; + } else { + # Check whether set difference is empty. + my %restr; + + for my $restrlist (@{$q}) { + my $reststr = join ' ', sort @{$restrlist}; + $restr{$reststr} = 1; + } + for my $restrlist (@{$p}) { + my $reststr = join ' ', sort @{$restrlist}; + delete $restr{$reststr}; + } + + return keys %restr == 0; + } +} + +=item $dep->implies($other_dep) + +Returns 1 when $dep implies $other_dep. Returns 0 when $dep implies +NOT($other_dep). Returns undef when there is no implication. $dep and +$other_dep do not need to be of the same type. + +=cut + +sub implies { + my ($self, $o) = @_; + + if ($o->isa('Dpkg::Deps::Simple')) { + # An implication is only possible on the same package + return if $self->{package} ne $o->{package}; + + # Our architecture set must be a superset of the architectures for + # o, otherwise we can't conclude anything. + return unless _arch_is_superset($self->{arches}, $o->{arches}); + + # The arch qualifier must not forbid an implication + return unless _arch_qualifier_implies($self->{archqual}, + $o->{archqual}); + + # Our restrictions must imply the restrictions for o + return unless _restrictions_imply($self->{restrictions}, + $o->{restrictions}); + + # If o has no version clause, then our dependency is stronger + return 1 if not defined $o->{relation}; + # If o has a version clause, we must also have one, otherwise there + # can't be an implication + return if not defined $self->{relation}; + + return Dpkg::Deps::deps_eval_implication($self->{relation}, + $self->{version}, $o->{relation}, $o->{version}); + } elsif ($o->isa('Dpkg::Deps::AND')) { + # TRUE: Need to imply all individual elements + # FALSE: Need to NOT imply at least one individual element + my $res = 1; + foreach my $dep ($o->get_deps()) { + my $implication = $self->implies($dep); + unless (defined $implication and $implication == 1) { + $res = $implication; + last if defined $res; + } + } + return $res; + } elsif ($o->isa('Dpkg::Deps::OR')) { + # TRUE: Need to imply at least one individual element + # FALSE: Need to not apply all individual elements + # UNDEF: The rest + my $res = undef; + foreach my $dep ($o->get_deps()) { + my $implication = $self->implies($dep); + if (defined $implication) { + if (not defined $res) { + $res = $implication; + } else { + if ($implication) { + $res = 1; + } else { + $res = 0; + } + } + last if defined $res and $res == 1; + } + } + return $res; + } else { + croak 'Dpkg::Deps::Simple cannot evaluate implication with a ' . + ref($o); + } +} + +=item $dep->get_deps() + +Returns a list of sub-dependencies, which for this object it means it +returns itself. + +=cut + +sub get_deps { + my $self = shift; + + return $self; +} + +=item $dep->sort() + +This method is a no-op for this object. + +=cut + +sub sort { + # Nothing to sort +} + +=item $dep->arch_is_concerned($arch) + +Returns true if the dependency applies to the indicated architecture. + +=cut + +sub arch_is_concerned { + my ($self, $host_arch) = @_; + + return 0 if not defined $self->{package}; # Empty dep + return 1 if not defined $self->{arches}; # Dep without arch spec + + return debarch_is_concerned($host_arch, @{$self->{arches}}); +} + +=item $dep->reduce_arch($arch) + +Simplifies the dependency to contain only information relevant to the given +architecture. This object can be left empty after this operation. This trims +off the architecture restriction list of these objects. + +=cut + +sub reduce_arch { + my ($self, $host_arch) = @_; + + if (not $self->arch_is_concerned($host_arch)) { + $self->reset(); + } else { + $self->{arches} = undef; + } +} + +=item $dep->has_arch_restriction() + +Returns the package name if the dependency applies only to a subset of +architectures. + +=cut + +sub has_arch_restriction { + my $self = shift; + + if (defined $self->{arches}) { + return $self->{package}; + } else { + return (); + } +} + +=item $dep->profile_is_concerned() + +Returns true if the dependency applies to the indicated profile. + +=cut + +sub profile_is_concerned { + my ($self, $build_profiles) = @_; + + return 0 if not defined $self->{package}; # Empty dep + return 1 if not defined $self->{restrictions}; # Dep without restrictions + return evaluate_restriction_formula($self->{restrictions}, $build_profiles); +} + +=item $dep->reduce_profiles() + +Simplifies the dependency to contain only information relevant to the given +profile. This object can be left empty after this operation. This trims off +the profile restriction list of this object. + +=cut + +sub reduce_profiles { + my ($self, $build_profiles) = @_; + + if (not $self->profile_is_concerned($build_profiles)) { + $self->reset(); + } else { + $self->{restrictions} = undef; + } +} + +=item $dep->get_evaluation($facts) + +Evaluates the dependency given a list of installed packages and a list of +virtual packages provided. These lists are part of the Dpkg::Deps::KnownFacts +object given as parameters. + +Returns 1 when it's true, 0 when it's false, undef when some information +is lacking to conclude. + +=cut + +sub get_evaluation { + my ($self, $facts) = @_; + + return if not defined $self->{package}; + return $facts->evaluate_simple_dep($self); +} + +=item $dep->simplify_deps($facts, @assumed_deps) + +Simplifies the dependency as much as possible given the list of facts (see +object Dpkg::Deps::KnownFacts) and a list of other dependencies that are +known to be true. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + + my $eval = $self->get_evaluation($facts); + $self->reset() if defined $eval and $eval == 1; +} + +=item $dep->is_empty() + +Returns true if the dependency is empty and doesn't contain any useful +information. This is true when the object has not yet been initialized. + +=cut + +sub is_empty { + my $self = shift; + + return not defined $self->{package}; +} + +=item $dep->merge_union($other_dep) + +Returns true if $dep could be modified to represent the union of both +dependencies. Otherwise returns false. + +=cut + +sub merge_union { + my ($self, $o) = @_; + + return 0 if not $o->isa('Dpkg::Deps::Simple'); + return 0 if $self->is_empty() or $o->is_empty(); + return 0 if $self->{package} ne $o->{package}; + return 0 if defined $self->{arches} or defined $o->{arches}; + + if (not defined $o->{relation} and defined $self->{relation}) { + # Union is the non-versioned dependency + $self->{relation} = undef; + $self->{version} = undef; + return 1; + } + + my $implication = $self->implies($o); + my $rev_implication = $o->implies($self); + if (defined $implication) { + if ($implication) { + $self->{relation} = $o->{relation}; + $self->{version} = $o->{version}; + return 1; + } else { + return 0; + } + } + if (defined $rev_implication) { + if ($rev_implication) { + # Already merged... + return 1; + } else { + return 0; + } + } + return 0; +} + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.17.10) + +New methods: Add $dep->profile_is_concerned() and $dep->reduce_profiles(). + +=head2 Version 1.01 (dpkg 1.16.1) + +New method: Add $dep->reset(). + +New property: recognizes the arch qualifier "any" and stores it in the +"archqual" property when present. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Deps/Union.pm b/scripts/Dpkg/Deps/Union.pm new file mode 100644 index 000000000..62cf5c38a --- /dev/null +++ b/scripts/Dpkg/Deps/Union.pm @@ -0,0 +1,119 @@ +# Copyright © 1998 Richard Braakman +# Copyright © 1999 Darren Benham +# Copyright © 2000 Sean 'Shaleh' Perry +# Copyright © 2004 Frank Lichtenheld +# Copyright © 2006 Russ Allbery +# Copyright © 2007-2009 Raphaël Hertzog <[email protected]> +# Copyright © 2008-2009, 2012-2014 Guillem Jover <[email protected]> +# +# This program is free software; you may redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dpkg::Deps::Union; + +=encoding utf8 + +=head1 NAME + +Dpkg::Deps::Union - list of unrelated dependencies + +=head1 DESCRIPTION + +This object represents a list of relationships. It inherits from +Dpkg::Deps::Multiple. + +=cut + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use parent qw(Dpkg::Deps::Multiple); + +=head1 METHODS + +=over 4 + +=item $dep->output([$fh]) + +The output method uses ", " to join the list of relationships. + +=cut + +sub output { + my ($self, $fh) = @_; + + my $res = join(', ', map { + $_->output() + } grep { + not $_->is_empty() + } $self->get_deps()); + + if (defined $fh) { + print { $fh } $res; + } + return $res; +} + +=item $dep->implies($other_dep) + +=item $dep->get_evaluation($other_dep) + +These methods are not meaningful for this object and always return undef. + +=cut + +sub implies { + # Implication test is not useful on Union. + return; +} + +sub get_evaluation { + # Evaluation is not useful on Union. + return; +} + +=item $dep->simplify_deps($facts) + +The simplification is done to generate an union of all the relationships. +It uses $simple_dep->merge_union($other_dep) to get its job done. + +=cut + +sub simplify_deps { + my ($self, $facts) = @_; + my @new; + +WHILELOOP: + while (@{$self->{list}}) { + my $odep = shift @{$self->{list}}; + foreach my $dep (@new) { + next WHILELOOP if $dep->merge_union($odep); + } + push @new, $odep; + } + $self->{list} = [ @new ]; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 28bb4a742..d8160749b 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -79,6 +79,12 @@ nobase_dist_perllib_DATA = \ Dpkg/Control/Tests/Entry.pm \ Dpkg/Control/Types.pm \ Dpkg/Deps.pm \ + Dpkg/Deps/AND.pm \ + Dpkg/Deps/KnownFacts.pm \ + Dpkg/Deps/Multiple.pm \ + Dpkg/Deps/OR.pm \ + Dpkg/Deps/Simple.pm \ + Dpkg/Deps/Union.pm \ Dpkg/Dist/Files.pm \ Dpkg/ErrorHandling.pm \ Dpkg/Exit.pm \ diff --git a/scripts/po/POTFILES.in b/scripts/po/POTFILES.in index dea8cde0e..638fd8b97 100644 --- a/scripts/po/POTFILES.in +++ b/scripts/po/POTFILES.in @@ -46,6 +46,12 @@ scripts/Dpkg/Control/Tests.pm scripts/Dpkg/Control/Tests/Entry.pm scripts/Dpkg/Control/Types.pm scripts/Dpkg/Deps.pm +scripts/Dpkg/Deps/AND.pm +scripts/Dpkg/Deps/KnownFacts.pm +scripts/Dpkg/Deps/Multiple.pm +scripts/Dpkg/Deps/OR.pm +scripts/Dpkg/Deps/Simple.pm +scripts/Dpkg/Deps/Union.pm scripts/Dpkg/Dist/Files.pm scripts/Dpkg/ErrorHandling.pm scripts/Dpkg/Exit.pm -- Dpkg.Org's dpkg
