| Current File : //bin/X11/debsums |
#!/usr/bin/perl
#
# Check installed files against package md5sums or debs.
#
use strict;
use warnings;
use File::Find 'find';
use File::Temp 'tempdir';
use File::Path 'rmtree';
use File::Copy 'copy';
use Fcntl qw/O_RDONLY O_NONBLOCK O_NOATIME/;
use Getopt::Long qw/:config bundling/;
use Digest::MD5;
use constant ELF_MAGIC => "\177ELF";
use Errno;
use POSIX;
use File::Basename;
use File::Spec;
use Dpkg::Conf;
use File::FnMatch qw(:fnmatch);
sub version {
my $changelog = File::Spec->catfile(dirname($0), "debian", "changelog");
my $cmd;
if (-f $changelog) {
$cmd = qq(dpkg-parsechangelog -SVersion '-l$changelog');
} else {
$cmd = q(dpkg-query -W -f '${Version}' debsums);
}
my $res = `$cmd`;
chomp($res);
if ($res !~ /^[0-9.~a-z+]+$/) {
$res = "";
}
return $res;
}
(my $self = $0) =~ s!.*/!!;
sub version_info {
my $version_number = version();
my $version = <<"EOT";
$self $version_number
Copyright (c) 2002, 2004, 2005, 2006, 2007 Brendan O'Dea <bod\@debian.org>
This is free software, licensed under the terms of the GNU General Public
License. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.
Written by Brendan O'Dea <bod\@debian.org>, based on a program by
Christoph Lameter <clameter\@debian.org> and Petr Cech <cech\@debian.org>.
EOT
return $version;
}
my $help = <<"EOT";
$self checks the MD5 sums of installed debian packages.
Usage: $self [OPTIONS] [PACKAGE|DEB] ...
Options:
-a, --all check configuration files (normally excluded)
-e, --config check only configuration files
-c, --changed report changed files (implies -s)
-l, --list-missing list packages which don't have an md5sums file
-s, --silent only report errors
-m, --md5sums=FILE read list of deb checksums from FILE
-x, --report-mismatches report errors and print the md5sums mismatch
-r, --root=DIR root directory to check (default /)
-d, --admindir=DIR dpkg admin directory (default /var/lib/dpkg)
-p, --deb-path=DIR[:DIR...] search path for debs
-g, --generate=[all][,keep[,nocheck]]
generate md5sums from deb contents
--no-locale-purge report missing locale files even if localepurge
is configured
--no-prelink report changed ELF files even if prelink is
configured
--ignore-obsolete ignore obsolete conffiles.
--help print this help, then exit
--version print version number, then exit
EOT
my $gen_opt;
GetOptions (
'a|all' => \my $all,
'e|config' => \my $config,
'c|changed' => \my $changed,
'l|list-missing' => \my $missing,
's|silent' => \my $silent,
'x|report-mismatches' => \my $report,
'm|md5sums=s' => \my $md5sums,
'r|root=s' => \my $root,
'd|admindir=s' => \my $admindir,
'p|deb-path=s' => \my $debpath,
'generate=s' => \$gen_opt,
'locale-purge!' => \my $localepurge,
'prelink!' => \my $prelink,
'ignore-permissions' => \my $ignore_permissions,
'ignore-obsolete!' => \my $ignore_obsolete,
g => sub { $gen_opt = 'missing' },
help => sub { print $help; exit },
version => sub { print version_info(); exit },
) or die "Try '$self --help' for more information.\n";
sub can_ignore {
return $!{EACCES} && $ignore_permissions && getuid();
}
my $my_noatime = 0;
eval { $my_noatime = O_NOATIME };
sub warn_or_die {
if (can_ignore()) {
unless ($silent) {
warn $_[0];
}
} else {
die $_[0];
}
}
sub parse_dpkg {
my ($command_cb, $field_names) = @_;
local $/ = "\n\n"; # Separator that cannot appear in dpkg status format
my @command = &$command_cb('--showformat=' .
(join '', map {"\${$_}$/"} @$field_names));
open DPKG, '-|', @command
or die "$self: can't run " . $command[0] . " ($!)\n";
my @ret;
while (!eof DPKG)
{
my %field = map {$_, scalar <DPKG>} @$field_names;
chomp @field{@$field_names};
push @ret, \%field;
}
close DPKG or die "$self: @command failed (",
$! ? $! : $? >> 8 ? "exit status " . ($? >> 8) : "signal " . ($? & 127),
")\n";
return @ret;
}
$root ||= '';
$admindir ||= '/var/lib/dpkg';
my $DPKG = $root . $admindir;
my $is_path_pattern_opt = sub {
return shift =~ /^--path-(?:exclude|include)=/;
};
my $dpkg_conf = Dpkg::Conf->new();
foreach (glob($root . "/etc/dpkg/dpkg.cfg.d/[0-9a-zA-Z_-]*"),
($root . "/etc/dpkg/dpkg.cfg", $root . glob("~/.dpkg.cfg"))) {
if (-f $_) {
my $name = "$_";
$dpkg_conf->load($name);
}
}
$dpkg_conf->filter(keep => $is_path_pattern_opt);
my @dpkg_opts = $dpkg_conf->get_options;
my @dpkg_patterns = ();
foreach my $opt(@dpkg_opts) {
my @res = ($opt =~ /^--path-(exclude|include)=(.+)/);
push @dpkg_patterns, \@res;
}
sub excluded_by_dpkg {
my $file = "/" . shift;
my $excluded = 0;
foreach my $rule(@dpkg_patterns) {
my ($type, $pattern) = @{$rule};
if (fnmatch($pattern, $file)) {
$excluded = $type eq 'exclude' ? 1 : 0;
}
}
return $excluded;
}
my %locales;
my $nopurge = '/etc/locale.nopurge';
# default is to ignore purged locale files if /etc/locale.nopurge exists
$localepurge = -e $nopurge unless defined $localepurge;
if ($localepurge and -e $nopurge)
{
open L, $nopurge or die "$self: can't open $nopurge ($!)\n";
while (<L>)
{
$locales{$1}++ if /^(\w.+)/;
}
close L;
}
# default is to use prelink to fetch the original checksums if installed
if (!defined $prelink or $prelink)
{
# use the binary in preference to the wrapper which asks questions
# interactively
($prelink) = grep -x, map +("$_.bin", $_), '/usr/sbin/prelink';
}
$silent++ if $changed;
my @debpath = '.';
@debpath = map +(length) ? $_ : '.', split /:/, $debpath, -1 if $debpath;
my $arch;
chomp ($arch = `/usr/bin/dpkg --print-architecture`);
my %generate;
if ($gen_opt)
{
for (split /,/, $gen_opt)
{
if (/^(missing|all|keep|nocheck)$/)
{
$generate{$1}++;
}
else
{
die "$self: invalid --generate value '$_'\n";
}
}
die "$self: --generate values 'all' and 'missing' are mutually exclusive\n"
if $generate{all} and $generate{missing};
$generate{missing}++ unless $generate{all} or $generate{missing};
# ensure generated files are world readable
umask 022;
}
my %installed;
my %package_name;
my %replaced;
{
for my $fields (parse_dpkg(
sub {'dpkg-query', "--admindir=$DPKG", @_, '--show'},
[qw(Package PackageSpec binary:Package Version
Status Conffiles Replaces)])) {
my %field = %$fields;
$field{"binary:Package"} = $field{PackageSpec}
if $field{"binary:Package"} eq '';
$field{"binary:Package"} = $field{Package}
if $field{"binary:Package"} eq '';
next unless $field{"binary:Package"} ne ''
and $field{Version} ne ''
and $field{Status} =~ /\s(installed|half-configured)$/;
$installed{$field{"binary:Package"}}{Version} = $field{Version};
if ($field{"binary:Package"} ne $field{"Package"} &&
$field{"binary:Package"} eq ($field{"Package"} . ":" . $arch))
{
$package_name{$field{"Package"}} = $field{"binary:Package"};
}
$installed{$field{"binary:Package"}}{Conffiles} = {
map m!^\s*/(\S+)\s+([\da-f]+)!,
grep { not ($ignore_obsolete and / obsolete$/) }
split /\n/, $field{Conffiles}
} if $field{Conffiles};
for (split /,\s*/, $field{Replaces})
{
my ($pack, $ver) = /^(\S+)(?:\s+\(([^)]+)\))?$/;
unless ($pack)
{
warn "$self: invalid Replaces for " .
$field{"binary:Package"} . " '$_'\n";
next;
}
push @{$replaced{$pack}{$ver || 'all'}}, $field{"binary:Package"};
}
}
}
my %diversion;
for (`LC_ALL=C dpkg-divert --list --admindir $DPKG`)
{
my ($by) = /^(local) diversion/ ? $1 : / by (\S+)$/;
$diversion{$1} = [$2, $by]
if m!diversion of /(.*) to /(.*?)\s!;
}
my %debsum;
if ($md5sums)
{
open F, $md5sums
or warn_or_die "$self: can't open sums file '$md5sums' ($!)\n";
if (fileno(F)) {
while (<F>)
{
my ($sum, $deb) = split;
$debsum{$deb} = $sum;
}
close F;
}
}
my $digest = Digest::MD5->new;
my $tmp;
my $status = 0;
@ARGV = sort keys %installed unless @ARGV;
sub dpkg_cmp
{
my $ver = shift;
my ($op, $testver) = split ' ', shift;
$op .= '=' if $op =~ /^[<>]$/; # convert old <, >
return 0 unless grep $op eq $_, qw/<< <= = => >>/;
return $op =~ /=/ if $ver eq $testver; # short cut equivalence
!system '/usr/bin/dpkg', '--compare-versions', $ver, $op, $testver;
}
sub md5sums_path
{
# Calling dpkg-query --control-path for every package is too slow,
# so we cheat a little bit.
my ($pack) = @_;
my $path = '';
if (-e "$DPKG/info/$pack.list") {
$path = "$DPKG/info/$pack.md5sums";
} elsif ($pack !~ /:/ and -e "$DPKG/info/$pack:$arch.list") {
$path = "$DPKG/info/$pack:$arch.md5sums";
} elsif ($pack =~ /^(.*):/ and -e "$DPKG/info/$1.list") {
$path = "$DPKG/info/$1.md5sums";
} else {
die "Cannot find md5sums path for $pack\n";
}
if (-e $path and -z _) {
# Empty .md5sums file: check if that's ok, either print a warning
my $list_file = $path;
$list_file =~ s/md5sums$/list/;
unless (-e $list_file) {
warn "$path is empty and $list_file does not exist!\n";
$status |= 2;
} else {
my $rc = open(my $lffd, '<', $list_file);
unless ($rc) {
warn "Couldn't open $list_file for reading: $!";
$status |= 2;
} else {
my $found_a_file = 0;
while (my $line = <$lffd>) {
chomp($line);
next if -l "$root$line";
next if -d _;
if (-f _) {
warn "$path is empty but shouldn't!\n";
$status |= 2;
last;
}
}
close($lffd);
}
}
}
return $path;
}
sub is_replaced
{
my ($pack, $path, $sum) = @_;
unless ($installed{$pack}{ReplacedBy})
{
(my $name = $pack) =~ s/:[^:]*$//;
return 0 unless $replaced{$name};
while (my ($ver, $p) = each %{$replaced{$name}})
{
next unless $ver eq 'all'
or dpkg_cmp $installed{$pack}{Version}, $ver;
push @{$installed{$pack}{ReplacedBy}}, @$p;
}
}
for my $p (@{$installed{$pack}{ReplacedBy} || []})
{
open S, md5sums_path($p) or next;
while (<S>)
{
if ($_ eq "$sum $path\n")
{
close S;
return 1;
}
}
close S;
}
0;
}
sub is_localepurge_file {
my $path = shift;
my $locale = "";
if ($path =~ m!usr/share/(locale|man|gnome/help|omf|doc/kde/HTML|tcltk|aptitude|calendar|cups/templates|cups/locale|cups/doc-root|help|vim/vim[^/]+/lang|X11/locale)/!) {
my $type = $1;
if ($type eq "man" || $type eq "locale" || $type eq "doc/kde/HTML") {
$path =~ m!^usr/share/(?:man|locale|doc/kde/HTML)/([^/]+)/!;
$locale = $1;
} elsif ($type eq "gnome/help") {
$path =~ m!^usr/share/gnome/help/[^/]+/([^/]+)/!;
$locale = $1;
} elsif ($type eq "omf") {
$path =~ m!^usr/share/omf/([^/]+)/\1-([^/]+).omf$!;
$locale = $2;
} elsif ($type eq "tcltk") {
$path =~ m!^usr/share/tcltk/t[^/]+/msgs/([^/]+).msg$!;
$locale = $1;
} elsif ($type eq "aptitude") {
$path =~ m!^usr/share/aptitude/aptitude-defaults\.(.+)$!;
$locale = $1;
} elsif ($type eq "calendar") {
$path =~ m!^usr/share/calendar/([\w]{2}_.+)$!;
$locale = $1;
} elsif ($type eq "cups/locale") {
$path =~ m!^usr/share/cups/locale/([^/]+)!;
$locale = $1;
} elsif ($type eq "cups/templates") {
$path =~ m!^usr/share/cups/templates/([^/]+)/!;
$locale = $1;
} elsif ($type eq "cups/doc-root") {
$path =~ m!^usr/share/cups/doc-root/([^/]+)/!;
$locale = $1;
} elsif ($type eq "help") {
$path =~ m!^usr/share/help/([^/]+)$!;
$locale = $1;
} elsif ($type =~ /^vim/) {
$path =~ m!^usr/share/vim/vim[^/]+/lang/([^/]+)/LC_MESSAGES/vim\.mo$!;
$locale = $1;
} elsif ($type eq "X11/locale") {
$path =~ m!^usr/share/X11/locale/([^/]+)/!;
$locale = $1;
}
}
return length($locale) && !$locales{$locale};
}
# resolve symlinks without escaping $root
sub resolve_path {
my $path = shift;
my $package = shift;
my @tokens = split(/\//, $path);
my @parts = ();
my %seen;
while (@tokens) {
my $token = shift @tokens;
next if $token eq '.' || $token eq '';
if ($token eq '..') {
pop @parts;
next;
}
my $fp = $root . '/' . join('/', @parts) . '/' . $token;
if ($seen{$fp}) {
# better die now with a clear error message then later
# with a sysopen fails
die "$self: Error: symlink loop detected in path '$path'. ",
"Please file a bug against $package.\n";
}
$seen{$fp} = 1;
if (-l $fp) {
my $link = readlink($fp);
@parts = () if $link =~ /^\//;
unshift @tokens, split(/\//, $link);
} else {
push @parts, $token;
}
}
return join('/', @parts);
}
{
my $width = ($ENV{COLUMNS} || 80) - 3;
$width = 6 if $width < 6;
sub check
{
my ($pack, $path, $sum) = @_;
$path = $diversion{$path}[0] if exists $diversion{$path}
and $diversion{$path}[1] ne $pack
and $diversion{$path}[1] ne $pack =~ s/:.*//r;
my $resolved = resolve_path($path,$pack);
if ((!sysopen F, "$root/$resolved", O_RDONLY|O_NONBLOCK|$my_noatime) &&
(!sysopen F, "$root/$resolved", O_RDONLY|O_NONBLOCK))
{
return 0 if $localepurge
and is_localepurge_file($path);
return 0 if excluded_by_dpkg($path);
my $err = "$self: can't open $pack file $root/$path ($!)\n";
if (can_ignore()) {
warn $err unless ($silent);
return 0;
} else {
if ($!{ENOENT}) {
warn "$self: missing file $root/$path (from $pack package)\n";
} else {
warn $err;
}
return 2;
}
}
unless (-f F) {
warn "$self: can't check $pack file $root/$path ",
"(not a regular file)\n";
close F;
return 2;
}
my $magic = '';
eval {
defined read F, $magic, length ELF_MAGIC or die $!;
$digest->add($magic);
$digest->addfile(\*F);
};
close F;
if ($@) {
$@ =~ s/ at \S+ line.*\n//;
warn "$self: can't check $pack file $root/$path ($@)\n";
return 2;
}
my $s = $digest->hexdigest;
if ($s ne $sum and $prelink and $magic eq ELF_MAGIC) {
if (open P, '-|', $prelink, '--verify', '--md5', "$root/$path")
{
my ($prelink_s) = map /^([\da-f]{32})\s/, <P>;
close P;
$s = $prelink_s if $prelink_s;
}
}
# Good cases
if ($s eq $sum) {
printf "%-*s OK\n", $width, "$root/$path" unless ($silent || $report);
return 0;
}
if (is_replaced $pack, $path, $s) {
printf "%-*s REPLACED\n", $width - 6, "$root/$path" unless ($silent || $report);
return 0;
}
my $correct_package =
`dpkg-query "--admindir=$DPKG" -S "/$path" | awk -F': ' '{print \$1}'`;
chomp($correct_package);
if ($pack ne $correct_package) {
#print "$pack != $correct_package\n";
return 0;
}
# Bad cases
if ($changed) {
print "$root/$path\n";
return 2;
}
if ($report) {
warn "$self: changed file $root/$path (observed:$s expected:$sum) (from $pack package)\n";
return 2;
}
if ($silent) {
warn "$self: changed file $root/$path (from $pack package)\n";
return 2;
}
printf "%-*s FAILED\n", $width - 4, "$root/$path";
return 2;
}
}
for (@ARGV)
{
my $sums;
my $pack;
my $conffiles;
# looks like a package name
unless (/[^a-z\d+.:-]/ or /\.deb$/)
{
$pack = $_;
unless (exists $installed{$pack})
{
if (exists $package_name{$pack}) {
$pack = $package_name{$pack};
}
unless (exists $installed{$pack})
{
warn "$self: package $pack is not installed\n";
$status |= 1;
next;
}
}
my $deb;
if (%generate)
{
my @v = $installed{$pack}{Version};
if ($v[0] =~ s/(\d+):/$1%3a/)
{
push @v, $installed{$pack}{Version};
$v[1] =~ s/\d+://;
}
for my $dir (@debpath)
{
# look for <pack>_<ver>_<arch>.deb or <pack>_<ver>.deb
# where <ver> may or may not contain an epoch
my ($debname, $debarch);
($debname, $debarch) = ($pack =~ /^(.*):([^:]*)$/)
or ($debname, $debarch) = ($pack, $arch);
if (($deb) = grep -f, map +(glob "$dir/${debname}_$_.deb"),
map +("${_}_$debarch", "${_}_all", $_), @v)
{
$deb =~ s!^\./+!!;
last;
}
}
}
if ($generate{all})
{
unless ($deb)
{
warn "$self: no deb available for $pack\n";
$status |= 1;
next;
}
$_ = $deb;
}
else
{
$sums = md5sums_path($pack);
unless (-f $sums or $config)
{
if ($missing)
{
print "$pack\n";
next;
}
unless ($generate{missing})
{
warn "$self: no md5sums for $pack\n";
next;
}
unless ($deb)
{
warn "$self: no md5sums for $pack and no deb available\n"
unless $generate{nocheck} and $silent;
next;
}
undef $sums;
$_ = $deb;
}
}
next if $missing;
}
unless ($sums)
{
unless (-f and /\.deb$/)
{
warn "$self: invalid package name '$_'\n";
$status |= 1;
next;
}
my $deb = $_;
my ($fields) = parse_dpkg(sub {'dpkg-deb', @_, '--show', $deb},
[qw(Package PackageSpec binary:Package
Version Conffiles)])
or do {
warn "$self: $deb does not seem to be a valid debian archive\n";
$status |= 1;
next;
};
my %field = %$fields;
$field{"binary:Package"} = $field{PackageSpec}
if $field{"binary:Package"} eq '';
$field{"binary:Package"} = $field{Package}
if $field{"binary:Package"} eq '';
unless ($field{"binary:Package"} ne '' and $field{Version} ne '')
{
warn "$self: $deb does not seem to be a valid debian archive\n";
$status |= 1;
next;
}
$pack = $field{"binary:Package"};
unless (exists $installed{$pack})
{
if (exists $package_name{$pack}) {
$pack = $package_name{$pack};
}
unless (exists $installed{$pack})
{
warn "$self: package $pack is not installed\n";
$status |= 1;
next;
}
}
unless ($installed{$pack}{Version} eq $field{Version})
{
warn "$self: package $pack version $field{Version} !=",
" installed version $installed{$pack}{Version}\n";
$status |= 1;
next;
}
if ($md5sums)
{
if (exists $debsum{$deb})
{
open F, $deb or warn_or_die "$self: can't open $deb ($!)\n";
if (fileno(F)) {
$digest->addfile(\*F);
close F;
}
unless ($digest->hexdigest eq $debsum{$deb})
{
warn "$self: checksum mismatch for $deb; not checked\n";
$status |= 2;
next;
}
}
else
{
warn "$self: no checksum available for $deb\n";
}
}
unless ($tmp)
{
my $catch = sub { exit 1 };
$SIG{$_} = $catch for qw/HUP INT QUIT TERM/;
$tmp = tempdir CLEANUP => 1
or die "$self: can't create temporary directory ($!)\n";
}
my $control = "$tmp/DEBIAN";
$sums = "$control/md5sums";
rmtree ($control, {safe => 1}) if -d $control;
system 'dpkg', '--control', $deb, $control
and die "$self: can't extract control info from $deb\n";
if ($missing)
{
print "$deb\n" unless -s $sums;
next;
}
my %conf;
if (open F, "$control/conffiles")
{
while (<F>)
{
chomp;
$conf{$1}++ if m!^/?(.+)!;
}
close F;
}
if (!-s $sums)
{
my $unpacked = "$tmp/$pack";
print "Generating missing md5sums for $deb..." unless $silent;
system 'dpkg', '--extract', $deb, $unpacked
and die "$self: can't unpack $deb\n";
$conffiles = {};
open SUMS, ">$sums" or die "$self: can't create $sums ($!)\n";
my $skip = (length $unpacked) + 1;
find sub {
return if -l or ! -f;
open F, $_ or warn_or_die "$self: can't open $_ ($!)\n";
if (fileno(F)) {
$digest->addfile(\*F);
close F;
}
my $md5 = $digest->hexdigest;
my $path = substr $File::Find::name, $skip;
if (delete $conf{$path})
{
$conffiles->{$path} = $md5;
}
else
{
print SUMS "$md5 $path\n";
}
}, $unpacked;
close SUMS;
rmtree ($unpacked, {safe => 1});
print "done.\n" unless $silent;
warn "$self: extra conffiles listed in $deb: (",
(join ', ', keys %conf), ")\n" if %conf;
}
if ($generate{keep})
{
warn "$self: the --generate=keep option has been removed and does nothing."
}
}
next if $generate{nocheck};
$conffiles = $installed{$pack}{Conffiles} || {}
unless $conffiles;
unless ($config)
{
open SUMS, $sums or warn_or_die "$self: can't open $sums ($!)\n";
if (fileno(SUMS)) {
while (<SUMS>)
{
chomp;
my ($sum, $path) = split ' ', $_, 2;
unless ($path and $sum =~ /^[0-9a-f]{32}$/)
{
warn "$self: invalid line ($.) in md5sums for $pack: $_\n";
next;
}
$path =~ s!^\./!!;
next if exists $conffiles->{$path};
$status |= check $pack, $path, $sum;
}
close SUMS;
}
}
next unless ($all or $config) and %$conffiles;
while (my ($path, $sum) = each %$conffiles)
{
$status |= check $pack, $path, $sum;
}
}
exit $status;