Adding upstream version 2.25.15.
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
This commit is contained in:
parent
10737b110a
commit
b543f2e88d
GPG key ID:
BCC918A2ABD66424
485 changed files with 191459 additions and 0 deletions
307
lib/Devscripts/PackageDeps.pm
Normal file
307
lib/Devscripts/PackageDeps.pm
Normal file
|
|
@ -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;
|
||||
Loading…
Add table
Add a link
Reference in a new issue