Adding upstream version 2.23.7.upstream/2.23.7upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 313 insertions, 0 deletions

diff --git a/lib/Devscripts/Packages.pm b/lib/Devscripts/Packages.pm
new file mode 100644
index 0000000..75acb45
--- /dev/null
+++ b/lib/Devscripts/Packages.pm
@@ -0,0 +1,313 @@
+#! /usr/bin/perl
+
+# Copyright Bill Allombert <ballombe@debian.org> 2001.
+# Modifications 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::Packages;
+
+use strict;
+use warnings;
+use Carp;
+use Dpkg::Control;
+use Dpkg::IPC;
+use FileHandle;
+
+BEGIN {
+    use Exporter ();
+    use vars     qw(@EXPORT @ISA %EXPORT_TAGS);
+    @EXPORT
+      = qw(PackagesToFiles FilesToPackages PackagesMatch InstalledPackages);
+    @ISA         = qw(Exporter);
+    %EXPORT_TAGS = ();
+}
+
+=head1 NAME
+
+Devscript::Packages - Interface to the dpkg package database
+
+=head1 SYNOPSIS
+
+use Devscript::Packages;
+
+@files=PackagesToFiles(@packages);
+
+@packages=FilesToPackages(@files);
+
+@packages=PackagesMatch($regexp);
+
+$packages_hashref=InstalledPackages($sources);
+
+=head1 DESCRIPTION
+
+
+PackagesToFiles: Return a list of files contained in a list of packages.
+
+FilesToPackages: Return a list of packages containing at least
+one file in a list of files, taking care to handle diversions correctly.
+
+PackagesMatch: list of packages whose status match regexp.
+
+InstalledPackages: ref to hash with keys being installed packages
+(status = install ok installed).  If $sources is true, then include
+the corresponding source packages as well in the list.
+
+=cut
+
+my $multiarch;
+
+sub multiarch () {
+    if (!defined $multiarch) {
+        $multiarch
+          = (system('dpkg --assert-multi-arch >/dev/null 2>&1') >> 8) == 0;
+    }
+    return $multiarch;
+}
+
+# input: a list of packages names.
+# output: list of files they contain.
+
+sub PackagesToFiles (@) {
+    return () if @_ == 0;
+
+    my %files = ();
+
+    # We fork and use an exec, so that we don't have to worry how long an
+    # input string the shell can handle.
+
+    my $pid;
+    my $sleep_count = 0;
+    do {
+        $pid = open(DPKG, "-|");
+        unless (defined $pid) {
+            carp("cannot fork: $!");
+            croak("bailing out") if $sleep_count++ > 6;
+            sleep 10;
+        }
+    } until defined $pid;
+
+    if ($pid) {    # parent
+        while (<DPKG>) {
+            chomp;
+            next if /^package diverts others to: / or -d $_;
+            $files{$_} = 1;
+        }
+        close DPKG or croak("dpkg -L failed: $!");
+    } else {       # child
+            # We must use C locale, else diversion messages may be translated.
+        $ENV{'LC_ALL'} = 'C';
+        exec('dpkg', '-L', @_)
+          or croak("can't exec dpkg -L: $!");
+    }
+
+    return keys %files;
+}
+
+# This basically runs a dpkg -S with a few bells and whistles
+#
+# input:  a list of files.
+# output: list of packages they belong to.
+
+sub FilesToPackages (@) {
+    return () if @_ == 0;
+
+    # We fork and use an exec, so that we don't have to worry how long an
+    # input string the shell can handle.
+
+    my @dpkg_out;
+    my $pid;
+    my $sleep_count = 0;
+    do {
+        $pid = open(DPKG, "-|");
+        unless (defined $pid) {
+            carp("cannot fork: $!");
+            croak("bailing out") if $sleep_count++ > 6;
+            sleep 10;
+        }
+    } until defined $pid;
+
+    if ($pid) {    # parent
+        while (<DPKG>) {
+            # We'll process it later
+            chomp;
+            push @dpkg_out, $_;
+        }
+        if (!close DPKG) {
+            # exit status of 1 just indicates unrecognised files
+            if ($? & 0xff || $? >> 8 != 1) {
+                carp(   "warning: dpkg -S exited with signal "
+                      . ($? & 0xff)
+                      . " and status "
+                      . ($? >> 8));
+            }
+        }
+    } else {    # child
+            # We must use C locale, else diversion messages may be translated.
+        $ENV{'LC_ALL'} = 'C';
+        open STDERR, '>& STDOUT';    # Capture STDERR as well
+        exec('dpkg', '-S', @_)
+          or croak("can't exec dpkg -S: $!");
+    }
+
+    my %packages = ();
+    foreach my $curfile (@_) {
+        my $pkgfrom;
+        foreach my $line (@dpkg_out) {
+            # We want to handle diversions nicely.
+            # Ignore local diversions
+            if ($line =~ /^local diversion from: /) {
+                # Do nothing
+            } elsif ($line =~ /^local diversion to: (.+)$/) {
+                if ($curfile eq $1) {
+                    last;
+                }
+            } elsif ($line =~ /^diversion by (\S+) from: (.+)$/) {
+                if ($curfile eq $2) {
+                    # So the file we're looking has been diverted
+                    $pkgfrom = $1;
+                }
+            } elsif ($line =~ /^diversion by (\S+) to: (.+)$/) {
+                if ($curfile eq $2) {
+                    # So the file we're looking is a diverted file
+                    # We shouldn't see it again
+                    $packages{$1} = 1;
+                    last;
+                }
+            } elsif ($line =~ /^dpkg: \Q$curfile\E not found\.$/) {
+                last;
+            } elsif ($line
+                =~ /^dpkg-query: no path found matching pattern \Q$curfile\E\.$/
+            ) {
+                last;
+            } elsif ($line =~ /^(.*): \Q$curfile\E$/) {
+                my @pkgs = split /,\s+/, $1;
+                if (@pkgs == 1 || !grep /:/, @pkgs) {
+                    # Only one package, or all Multi-Arch packages
+                    map { $packages{$_} = 1 } @pkgs;
+                } else {
+                    # We've got a file which has been diverted by some package
+                    # or is Multi-Arch and so is listed in two packages.  If it
+                    # was diverted, the *diverting* package is the one with the
+                    # file that was actually used.
+                    my $found = 0;
+                    foreach my $pkg (@pkgs) {
+                        if ($pkg eq $pkgfrom) {
+                            $packages{$pkgfrom} = 1;
+                            $found = 1;
+                            last;
+                        }
+                    }
+                    if (!$found) {
+                        carp(
+"Something wicked happened to the output of dpkg -S $curfile"
+                        );
+                    }
+                }
+                # Prepare for the next round
+                last;
+            }
+        }
+    }
+
+    return keys %packages;
+}
+
+# Return a list of packages whose status entries match a given pattern
+
+sub PackagesMatch ($) {
+    my $match   = $_[0];
+    my @matches = ();
+
+    my $fout = FileHandle->new;
+    my $pid  = spawn(
+        exec    => ['dpkg', '--status'],
+        to_pipe => $fout
+    );
+    unless (defined $pid) {
+        croak("Unable to run \"dpkg --status\": $!");
+    }
+
+    my $ctrl;
+    while (defined($ctrl = Dpkg::Control->new())
+        && $ctrl->parse($fout, 'dpkg --status')) {
+        if ("$ctrl" =~ m/$match/m) {
+            my $package = $ctrl->{Package};
+            if ($ctrl->{Architecture} ne 'all' && multiarch) {
+                $package .= ":$ctrl->{Architecture}";
+            }
+            push @matches, $package;
+        }
+        undef $ctrl;
+    }
+
+    wait_child($pid, cmdline => 'dpkg --status', nocheck => 1);
+    return @matches;
+}
+
+# Which packages are installed (Package and Source)?
+
+sub InstalledPackages ($) {
+    my $source = $_[0];
+
+    my $fout = FileHandle->new;
+    my $pid  = spawn(
+        exec    => ['dpkg', '--status'],
+        to_pipe => $fout
+    );
+    unless (defined $pid) {
+        croak("Unable to run \"dpkg --status\": $!");
+    }
+
+    my $ctrl;
+    my %matches;
+    while (defined($ctrl = Dpkg::Control->new(type => CTRL_FILE_STATUS))
+        && $ctrl->parse($fout, 'dpkg --status')) {
+        if ($ctrl->{Status} !~ /^install\s+ok\s+installed$/) {
+            next;
+        }
+        if ($source) {
+            if (exists $ctrl->{Source}) {
+                $matches{ $ctrl->{Source} } = 1;
+            }
+        }
+        if (exists $ctrl->{Package}) {
+            $matches{ $ctrl->{Package} } = 1;
+            if ($ctrl->{Architecture} ne 'all' && multiarch) {
+                $matches{"$ctrl->{Package}:$ctrl->{Architecture}"} = 1;
+            }
+        }
+        undef $ctrl;
+    }
+
+    wait_child($pid, cmdline => 'dpkg --status', nocheck => 1);
+
+    return \%matches;
+}
+
+1;
+
+=head1 AUTHOR
+
+Bill Allombert <ballombe@debian.org>
+
+=head1 COPYING
+
+Copyright 2001 Bill Allombert <ballombe@debian.org>
+Modifications copyright 2002 Julian Gilbey <jdg@debian.org>
+dpkg-depcheck is free software, covered by the GNU General Public License, and
+you are welcome to change it and/or distribute copies of it under
+certain conditions.  There is absolutely no warranty for dpkg-depcheck.
+
+=cut