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;