From efe47381c599b07e4c7bbdb2e91e8090a541c887 Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Sun, 7 Apr 2024 17:53:52 +0200 Subject: Adding upstream version 2.23.4+deb12u1. Signed-off-by: Daniel Baumann --- lib/Devscripts/Packages.pm | 313 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 313 insertions(+) create mode 100644 lib/Devscripts/Packages.pm (limited to 'lib/Devscripts/Packages.pm') 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 2001. +# Modifications copyright 2002 Julian Gilbey + +# 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 . + +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 () { + 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 () { + # 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 + +=head1 COPYING + +Copyright 2001 Bill Allombert +Modifications copyright 2002 Julian Gilbey +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 -- cgit v1.2.3