Gecko [ fernandoquevedodop.com ]

Name	Size	Permission
MkOrigtargz	[ DIR ]	drwxr-xr-x
Salsa	[ DIR ]	drwxr-xr-x
Uscan	[ DIR ]	drwxr-xr-x
Compression.pm	3.1 KB	-rw-r--r--
Config.pm	10.9 KB	-rw-r--r--
DB_File_Lock.pm	10.79 KB	-rw-r--r--
Debbugs.pm	11.57 KB	-rw-r--r--
JSONCache.pm	1.61 KB	-rw-r--r--
MkOrigtargz.pm	20.68 KB	-rw-r--r--
Output.pm	1.49 KB	-rw-r--r--
PackageDeps.pm	9.14 KB	-rw-r--r--
Packages.pm	8.93 KB	-rw-r--r--
Salsa.pm	9.39 KB	-rw-r--r--
Set.pm	2.87 KB	-rw-r--r--
Utils.pm	482 B	-rw-r--r--
Versort.pm	2.05 KB	-rw-r--r--

Code Editor : 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);
}

${this.title}

Code Editor : PackageDeps.pm