horok/devscripts
1
0
Fork 0
Code Activity

Adding upstream version 2.25.15.

Browse source 
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
This commit is contained in:
Daniel Baumann 2025-06-21 11:04:07 +02:00
parent 10737b110a
commit b543f2e88d
Signed by: daniel.baumann
GPG key ID: BCC918A2ABD66424
485 changed files with 191459 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

313
lib/Devscripts/Packages.pm Normal file
View file

@ -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