diff options
author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 15:53:52 +0000 |
---|---|---|
committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-07 15:53:52 +0000 |
commit | efe47381c599b07e4c7bbdb2e91e8090a541c887 (patch) | |
tree | 05cf57183f5a23394eca11b00f97a74a5dfdf79d /lib/Devscripts/PackageDeps.pm | |
parent | Initial commit. (diff) | |
download | devscripts-upstream/2.23.4+deb12u1.tar.xz devscripts-upstream/2.23.4+deb12u1.zip |
Adding upstream version 2.23.4+deb12u1.upstream/2.23.4+deb12u1upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
-rw-r--r-- | lib/Devscripts/PackageDeps.pm | 307 |
1 files changed, 307 insertions, 0 deletions
diff --git a/lib/Devscripts/PackageDeps.pm b/lib/Devscripts/PackageDeps.pm new file mode 100644 index 0000000..8bad0d7 --- /dev/null +++ b/lib/Devscripts/PackageDeps.pm @@ -0,0 +1,307 @@ +# Based vaguely on the deprecated dpkg-perl package modules +# Dpkg::Package::List and Dpkg::Package::Package. +# This module creates an object which holds package names and dependencies +# (just Depends and Pre-Depends). +# It can also calculate the total set of subdependencies using the +# fulldepends method. +# +# Copyright 2002 Julian Gilbey <jdg@debian.org> +# +# This program is free software; you can 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 program 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 Devscripts::PackageDeps; +use strict; +use Carp; +use Dpkg::Control; +use Dpkg::IPC; +use FileHandle; +require 5.006_000; + +# This reads in a package file list, such as /var/lib/dpkg/status, +# and parses it. Using /var/lib/dpkg/status is deprecated in favor of +# fromStatus(). + +# Syntax: Devscripts::PackageDeps->new($filename) + +sub new ($$) { + my $this = shift; + my $class = ref($this) || $this; + my $filename = shift; + + my $self = {}; + + if (!defined $filename) { + croak("requires filename as parameter"); + } + + bless($self, $class); + + my $fh = FileHandle->new($filename, 'r'); + unless (defined $fh) { + croak("Unable to load $filename: $!"); + } + $self->parse($fh, $filename); + $fh->close or croak("Problems encountered reading $filename: $!"); + + return $self; +} + +# This reads in dpkg's status information and parses it. + +# Syntax: Devscripts::PackageDeps->fromStatus() + +sub fromStatus ($) { + my $this = shift; + my $class = ref($this) || $this; + + my $self = {}; + + bless($self, $class); + + my $fh = FileHandle->new; + my $pid = spawn( + exec => ['dpkg', '--status'], + to_pipe => $fh + ); + unless (defined $pid) { + croak("Unable to run 'dpkg --status': $!"); + } + + $self->parse($fh, 'dpkg --status'); + + wait_child($pid, cmdline => 'dpkg --status', nocheck => 1); + + return $self; +} + +# Internal functions + +my $multiarch; + +sub multiarch () { + if (!defined $multiarch) { + $multiarch + = (system('dpkg --assert-multi-arch >/dev/null 2>&1') >> 8) == 0; + } + return $multiarch; +} + +sub parse ($$$) { + my $self = shift; + my $fh = shift; + my $filename = shift; + + my $ctrl; + PACKAGE_ENTRY: + while (defined($ctrl = Dpkg::Control->new(type => CTRL_FILE_STATUS)) + && $ctrl->parse($fh, $filename)) { + + # So we've got a package + my $pkg = $ctrl->{Package}; + my @deps = (); + + if ($ctrl->{Status} =~ /^\S+\s+\S+\s+(\S+)$/) { + my $status = $1; + unless ($status eq 'installed' or $status eq 'unpacked') { + undef $ctrl; + next PACKAGE_ENTRY; + } + } + + for my $dep (qw(Depends Pre-Depends)) { + if (exists $ctrl->{$dep}) { + my $value = $ctrl->{$dep}; + $value =~ s/\([^)]+\)//g; # ignore versioning information + $value =~ tr/ \t//d; # remove spaces + my @dep_pkgs = split /,/, $value; + foreach my $dep_pkg (@dep_pkgs) { + my @dep_pkg_alts = split /\|/, $dep_pkg; + if (@dep_pkg_alts == 1) { push @deps, $dep_pkg_alts[0]; } + else { push @deps, \@dep_pkg_alts; } + } + } + } + + $self->{$pkg} = \@deps; + if ($ctrl->{Architecture} ne 'all' && multiarch) { + my $arch = $ctrl->{Architecture}; + @deps = map { "$_:$arch" } @deps; + $self->{"$pkg:$arch"} = \@deps; + } + undef $ctrl; + } +} + +# Get direct dependency information for a specified package +# Returns an array or array ref depending on context + +# Syntax: $obj->dependencies($package) + +sub dependencies ($$) { + my $self = shift; + my $pkg = shift; + + if (!defined $pkg) { + croak("requires package as parameter"); + } + + if (!exists $self->{$pkg}) { + return undef; + } + + return wantarray ? @{ $self->{$pkg} } : $self->{$pkg}; +} + +# Get full dependency information for a specified package or packages, +# including the packages themselves. +# +# This only follows the first of sets of alternatives, and ignores +# dependencies on packages which do not appear to exist. +# Returns an array or array ref + +# Syntax: $obj->full_dependencies(@packages) + +sub full_dependencies ($@) { + my $self = shift; + my @toprocess = @_; + my %deps; + + return wantarray ? () : [] unless @toprocess; + + while (@toprocess) { + my $next = shift @toprocess; + $next = $$next[0] if ref $next; + # Already seen? + next if exists $deps{$next}; + # Known package? + next unless exists $self->{$next}; + # Mark it as a dependency + $deps{$next} = 1; + push @toprocess, @{ $self->{$next} }; + } + + return wantarray ? keys %deps : [keys %deps]; +} + +# Given a set of packages, find a minimal set with respect to the +# pre-partial order of dependency. +# +# This is vaguely based on the dpkg-mindep script by +# Bill Allombert <ballombe@debian.org>. It only follows direct +# dependencies, and does not attempt to follow indirect dependencies. +# +# This respects the all packages in sets of alternatives. +# Returns: (\@minimal_set, \%dependencies) +# where the %dependencies hash is of the form +# non-minimal package => depending package + +# Syntax: $obj->min_dependencies(@packages) + +sub min_dependencies ($@) { + my $self = shift; + my @pkgs = @_; + my @min_pkgs = (); + my %dep_pkgs = (); + + return (\@min_pkgs, \%dep_pkgs) unless @pkgs; + + # We create a directed graph: the %forward_deps hash records arrows + # pkg A depends on pkg B; the %reverse_deps hash records the + # reverse arrows + my %forward_deps; + my %reverse_deps; + + # Initialise + foreach my $pkg (@pkgs) { + $forward_deps{$pkg} = {}; + $reverse_deps{$pkg} = {}; + } + + foreach my $pkg (@pkgs) { + next unless exists $self->{$pkg}; + my @pkg_deps = @{ $self->{$pkg} }; + while (@pkg_deps) { + my $dep = shift @pkg_deps; + if (ref $dep) { + unshift @pkg_deps, @$dep; + next; + } + if (exists $forward_deps{$dep}) { + $forward_deps{$pkg}{$dep} = 1; + $reverse_deps{$dep}{$pkg} = 1; + } + } + } + + # We start removing packages from the tree if they have no dependencies. + # Once we have no such packages left, we must have mutual or cyclic + # dependencies, so we pick a random one to remove and then start again. + # We continue this until there are no packages left in the graph. + PACKAGE: + while (scalar keys %forward_deps) { + foreach my $pkg (keys %forward_deps) { + if (scalar keys %{ $forward_deps{$pkg} } == 0) { + # Great, no dependencies! + if (scalar keys %{ $reverse_deps{$pkg} }) { + # This package is depended upon, so we can remove it + # with care + foreach my $dep_pkg (keys %{ $reverse_deps{$pkg} }) { + # take the first mentioned package for the + # recorded list of depended-upon packages + $dep_pkgs{$pkg} ||= $dep_pkg; + delete $forward_deps{$dep_pkg}{$pkg}; + } + } else { + # This package is not depended upon, so it must + # go into our mindep list + push @min_pkgs, $pkg; + } + # Now remove this node + delete $forward_deps{$pkg}; + delete $reverse_deps{$pkg}; + next PACKAGE; + } + } + + # Oh, we didn't find any package which didn't depend on any other. + # We'll pick a random one, then. At least *some* package must + # be depended upon in this situation; let's pick one of these. + foreach my $pkg (keys %forward_deps) { + next unless scalar keys %{ $reverse_deps{$pkg} } > 0; + + foreach my $dep_pkg (keys %{ $forward_deps{$pkg} }) { + delete $reverse_deps{$dep_pkg}{$pkg}; + } + foreach my $dep_pkg (keys %{ $reverse_deps{$pkg} }) { + # take the first mentioned package for the + # recorded list of depended-upon packages + $dep_pkgs{$pkg} ||= $dep_pkg; + delete $forward_deps{$dep_pkg}{$pkg}; + } + + # Now remove this node + delete $forward_deps{$pkg}; + delete $reverse_deps{$pkg}; + # And onto the next package + goto PACKAGE; + } + + # Ouch! We shouldn't ever get here + croak("Couldn't determine mindeps; this can't happen!"); + } + + return (\@min_pkgs, \%dep_pkgs); +} + +1; |