summaryrefslogtreecommitdiffstats
path: root/lib/Devscripts/PackageDeps.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Devscripts/PackageDeps.pm')
-rw-r--r--lib/Devscripts/PackageDeps.pm307
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..299c03b
--- /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;