summaryrefslogtreecommitdiffstats
path: root/lib/Devscripts/Packages.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Devscripts/Packages.pm')
-rw-r--r--lib/Devscripts/Packages.pm313
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-02 21:14:21 +0000