mirror of
https://git.dpkg.org/git/dpkg/dlocate.git
synced 2025-04-26 20:20:26 +00:00
116 lines
2.8 KiB
Perl
Executable File
116 lines
2.8 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use File::Basename;
|
|
|
|
my $program = basename($0);
|
|
|
|
my %packages = ();
|
|
|
|
my $myarch = qx(dpkg --print-architecture);
|
|
chomp $myarch;
|
|
|
|
# pre-declare subroutines (see below for implementation)
|
|
use subs qw(parse_pkg);
|
|
|
|
# get details for all packages known by dpkg
|
|
open my $dpkg_fh, '-|', 'dpkg -l "*"';
|
|
while (<$dpkg_fh>) {
|
|
next unless (m/^[uihrp][ncHUFWti]/);
|
|
chomp;
|
|
|
|
my ($status, $pkg, $version, $arch, $desc) = split /\s+/, $_, 5;
|
|
$pkg =~ s/:.*//;
|
|
|
|
$packages{$pkg}->{$arch}->{status} = sprintf('%-3s', $status);
|
|
$packages{$pkg}->{$arch}->{version} = $version;
|
|
$packages{$pkg}->{$arch}->{desc} = $desc;
|
|
}
|
|
close $dpkg_fh;
|
|
|
|
# now get missing details for uninstalled packages
|
|
$/ = '';
|
|
open my $dctrl_fh, '-|',
|
|
"grep-available -e . -s Package,Description,Architecture,Version";
|
|
while (<$dctrl_fh>) {
|
|
parse_pkg('DCTRL', $_);
|
|
}
|
|
close $dctrl_fh;
|
|
|
|
|
|
my $dlist = '/var/lib/dlocate/dpkg-list';
|
|
|
|
open my $dpkglist_fh, '>', "$dlist.new"
|
|
or die "$program: couldn't open $dlist.new for write: $!\n";
|
|
foreach (sort keys %packages) {
|
|
foreach my $arch (sort keys %{$packages{$_}}) {
|
|
next if ($arch eq '<none>');
|
|
my $pkg = ($arch =~ m/^($myarch|all)$/io) ? $_ : "$_:$arch";
|
|
|
|
printf { $dpkglist_fh } "%s\t%s\t%s:%s\t%s\n",
|
|
#printf DPKGLIST "%s\t%s\t%s\t%s\t%s\n",
|
|
$packages{$_}->{$arch}->{status},
|
|
$pkg,
|
|
$packages{$_}->{$arch}->{version}, $arch,
|
|
$packages{$_}->{$arch}->{desc};
|
|
}
|
|
}
|
|
close $dpkglist_fh;
|
|
rename("$dlist.new", $dlist);
|
|
|
|
|
|
###
|
|
### subroutines
|
|
###
|
|
|
|
sub parse_pkg {
|
|
my $calltype = shift;
|
|
my ($pkg, $desc, $status, $version, $arch) = (
|
|
'',
|
|
'(no description available)',
|
|
'un ',
|
|
'',
|
|
'',
|
|
);
|
|
|
|
# split package details by newline
|
|
foreach (split /\n/, $_) {
|
|
next unless (m/^(Package|Description(?:-..)?|Architecture|Version):/o);
|
|
|
|
my ($field, $val) = split /: /, $_, 2;
|
|
if ($field eq 'Package') {
|
|
$pkg = $val ;
|
|
} elsif ($field =~ m/Description(?:-..)?/io) {
|
|
$desc = $val;
|
|
} elsif ($field eq 'Version') {
|
|
$version = $val;
|
|
} elsif ($field eq 'Architecture') {
|
|
$arch = $val;
|
|
}
|
|
}
|
|
|
|
#$desc = "$calltype $desc";
|
|
|
|
return unless ($pkg && $arch);
|
|
return if ($arch ne $myarch && !defined($packages{$pkg}->{$arch}));
|
|
|
|
$packages{$pkg}->{$arch}->{desc} = $desc;
|
|
|
|
if (! defined($packages{$pkg}->{$arch}->{status})) {
|
|
$packages{$pkg}->{$arch}->{status} = 'un ';
|
|
}
|
|
|
|
if (! defined($packages{$pkg}->{$arch}->{version}) ||
|
|
$packages{$pkg}->{$arch}->{version} eq '<none>') {
|
|
$packages{$pkg}->{$arch}->{version} = $version;
|
|
}
|
|
|
|
if (! defined($packages{$pkg}->{$arch})) {
|
|
$packages{$pkg}->{$arch}->{arch} = $arch;
|
|
}
|
|
|
|
return;
|
|
}
|