path: root/lib/Devscripts/PackageDeps.pm

# 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;