File sam of Package suse-sam
#!/usr/bin/perl -w
# vim: set et ts=8 sts=4 sw=4 ai si:
#
# sam - Supportability Analysis Module
#
# Copyright (c) 2008 SuSE Linux Products GmbH, Nuernberg, Germany
#
# Author: Olaf Dabrunz <od@suse.de>
# (based on 'sammi' by Raymund Will <rw@suse.de>)
#
# 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, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# Notes:
#
# RPM epoch is not used (policy at SUSE/Novell and elsewhere), as it is sticky
# (every version upgrade must contain the right epoch value) and also not
# visible to the user.
#
# Extensions for SELinux, ACLs, capabilities and others need to be added when
# they are supported by both the SUSE Linux kernel and the SUSE version of RPM.
#
use strict;
use POSIX qw(strftime WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
# handle HUP INT PIPE TERM ABRT QUIT with die, so the END block is executed
# which unlinks temporary files
use sigtrap qw(die untrapped normal-signals ABRT QUIT);
use File::Find;
my $progname = $0; $progname =~ s{^.*/}{};
my $progspcs = $progname; $progspcs =~ s{.}{ }g;
my $invocation_cmd_line = $progname ." ". join (" ", @ARGV);
my $prog_version = 0.6;
my $tmpdir = "/tmp";
my $pubring = "$progname.pubring.$$";
my $sigfile = "$progname.sigfile.$$";
my $signedfile = "$progname.signedfile.$$";
# unlink temp files in the end (but not if the program ends before temp file
# names are known)
my $unlink_ok = 0;
END {
if (defined $unlink_ok and $unlink_ok) {
unlink($pubring, $pubring . "~", $sigfile, $signedfile);
}
}
$ENV{"LC_ALL"} = "C";
delete $ENV{"LANG"};
my $Unsupportable = 0;
my $root_dir = "/";
my $rpm_command = "/bin/rpm";
my $gpg_exe = "/usr/bin/gpg";
my $gpg_command = "$gpg_exe --no-default-keyring --keyring $pubring " .
"--trust-model always";
my $zypp_conf = defined $ENV{'ZYPP_CONF'} ?
$ENV{'ZYPP_CONF'} : "/etc/zypp/zypp.conf"; # libzypp
# caches -- for development and debugging
my $cache_dir = "sam.d";
my $rpm_qa_cache = "$cache_dir/rpm-qa";
my $rpm_Vv_cache = "$cache_dir/rpm-Vv";
my $rpm_e_cache = "$cache_dir/rpm-e";
my $cache_file_version = "0.4";
# repositories -- for gpg keys and inst source information
my $default_zypp_cache = "/var/cache/zypp";
my $repossubdir = "repos.d";
my $metadatasubdir = "raw";
my $solvfilessubdir = "solv";
my $solvfilename = "solv";
my $reposdir;
my $metadatadir;
my $solvfilesdir;
my %repoinfo = ();
# installed package information
my %package2inst_time = ();
my %package2name = ();
my %package2edition = ();
my %skipped_packages = ();
my %alien_packages = ();
my %alien2name = ();
my %alien2edition = ();
my $num_sig_ok_packs = 0;
# package signing keys
my %good_key_ids = ();
# --------------------------------------------------------------------------
# SAM configuration
my $ALLOW_MULTIHOMED_OBJECTS = 0;
my $CHECK_SIGNATURE = 1;
my $VERIFY_PACKAGES = 1;
my $FIND_DETACHED = 1;
# hex encoding of RPM header prefix used when creating/verifying the header
# signature
my $headerprefix = "8eade80100000000";
# --------------------------------------------------------------------------
# statistics
my $Tstart = time();
my ($cacheMiss, $cacheHit) = (0, 0);
my ($aInodes, $aSize, $pInodes, $pSize) = (0, 0, 0, 0);
# --------------------------------------------------------------------------
# logging
#
my $debug = 0;
my $verbose = 1;
my $writeReport = 0;
my $logCont = 0;
my $logBuffer = "";
#
# Log to LOG file and maybe also STDERR, if we are $verbose enough for the
# $level of the message. "%T" in the message are replaced with a timestamp.
#
# 0 - really useful to know in most cases
# 1 - more verbose
# - show packages
# - for which updates exist but are not installed
# - which have the same evr as a package in a repo, but are not
# identical
# - output of some external programs
# - more steps reported
# 2 - show installed packages which are newer than available packages in repos
# 3 - show installed packages which are identical with some package in repos
# and which have no newer updates
# 4 - show informative output of programs
# 5 - show when heuristics drop candidates
# - dropping pseudo-packages
# - dropping files that where considered as gpg-keys but turned out not
# to be
#
# 8 - show execution and all output of several external programs
# 9 - show fatal error message
# - FIXME: describe purpose of other Log(9,...)
#
sub Log($$@) {
my ($level, $format, @args) = @_;
my $msg = sprintf($format, @args);
my $timestamp = strftime( "%Y-%m-%d_%H:%M:%S_Z", gmtime(time()));
$msg =~ s{(\%T)}{$timestamp}g;
$logCont = ( substr( $msg, -1, 1) eq "\n" ) ? 0 : 1;
print(LOG $msg);
if ($level < $verbose) {
print(STDERR $msg);
print(STDERR (($logCont) ? "C" : "")) if $debug;
}
return($msg);
}
#
# Report at log level 0
#
sub Report($@) {
my ($format, @args) = @_;
my $msg = Log(0, $format, @args);
print(REPORT $msg);
}
#
# Report at log level 2
#
sub ReportQ($@) {
my ($format, @args) = @_;
my $msg = Log(2, $format, @args);
print(REPORT $msg);
}
# ---------------------------------------------------------------------------
# Die. Exits the program with an error return value and an optional message.
#
# Die();
# Die(1);
# Die(2, "%T %s: could not open file %s\n", $progname, $file);
# Die("%T %s: could not open file %s\n", $progname, $file);
#
# Accepts zero or more parameters.
#
# If the first parameter is a number between -999 and 999, it is masked with
# 0x7f and used as an error code. It this case, the next parameter is used as
# the format string for the error message. Otherwise, the error code is -1 and
# the first parameter is used as the format string. Any following parameters
# are used as arguments to the format string.
#
# The message is logged at level 9, and an extra message is written to STDERR
# (using warn()).
#
sub Die(@) {
my (@args) = @_;
my ($error_code, $format) = (-1, undef);
my $t = shift(@args);
if (defined($t) && $t =~ m{^(0|-?[1-9][0-9]{0,2})$}) {
$error_code = $t;
$format = shift(@args);
} else {
$format = $t;
}
if (defined($format)) {
Log(9, "FATAL: $format", @args);
warn(sprintf("$format", @args));
}
exit($error_code & 127);
}
# ---------------------------------------------------------------------------
# Print package information as HTML
#
sub initHTML() {
print(HTML
" <table id=\"SAM-list\">\n",
" <thead>\n",
" <th>Name</th><th>Version</th><th>Supported</th>",
" <th>Notes</th>\n",
" </thead>\n",
" <tbody>\n");
}
sub finishHTML() {
print(HTML
" </tbody>\n",
" </table>\n");
}
sub HTMLize($) {
return @_;
}
my $hOE = "odd ";
sub printHTML($$$) {
my ($p, $r, $n) = @_;
my ($N, $E, $c) = (HTMLize($package2name{$p}), HTMLize($package2edition{$p}), "class");
my ($s, $b) = (($r == 0) ? (" supported", "Yes") : ("unsupported", "No"));
print(HTML " "x8 . "<tr $c=\"$hOE $s\"><th>$N</th><td $c=\"edition\">",
"$E</td><td $c=\"support\">$b</td><td>$n</td></tr>\n");
$hOE = (($hOE eq "odd ") ? "even" : "odd ");
}
# ---------------------------------------------------------------------------
# Print package information as JSON
#
BEGIN() {
eval { require JSON::XS; };
if ( $@ ) {
die unless ($@ =~ m{Can't locate});
} else {
require JSON::XS;
}
}
my %J = ();
my $js_true = 1;
my $js_false = 0;
my $json;
eval { require JSON::XS; };
if ( $@ ) {
die unless ($@ =~ m{Can't locate});
$json = undef;
} else {
$js_true = JSON::XS->true;
$js_false = JSON::XS->false;
$json = JSON::XS->new->ascii->pretty->allow_nonref->canonical;
$json = $json->space_before(0)->space_after(1)->indent(1);
}
sub JSONize($) {
my ($s) = @_;
$s =~ s{([\"\\\/])}{\\$1}g;
return ( $s );
}
sub fillJSON($$$) {
my ($p, $r, $n) = @_;
#print( JSON $json( [$p2name{$p}, $p2edition{$p}, $r, $n ]), "\n");
push @{ $J{"packages"} },
{"0::name" => $package2name{$p},
"1::edition" => $package2edition{$p},
"2::support" => (($r == 0) ? $js_true : $js_false),
"3::note" => $n
};
}
sub finishJSON() {
my $j;
if ( defined( $json) ) {
$j = $json->encode( \%J);
} else {
$j = "Please install JSON::XS and cie.\n";
}
$j =~ s{ \{ \s* \" }{\{ \"}gsx;
$j =~ s{ \s+ \}, }{ \},}gsx;
$j =~ s{ ([^\}],) \s* }{$1 }gsx;
$j =~ s{ \s+ (\}) }{ $1}gsx;
$j =~ s{ (\") [0-9] \:\: (\S+\") }{$1$2}gmx;
$j =~ s{ ^ \s+ (\{) }{ $1}gmx;
$j =~ s{ ^ \s+ (\]) }{$1}gmx;
print( JSON $j, "\n");
}
# ---------------------------------------------------------------------------
# finding package source repository with libsatsolver
#
BEGIN() {
eval { require satsolver; };
if ( $@ ) {
die unless ($@ =~ m{Can't locate});
} else {
require satsolver;
}
}
my $satsolver = 0;
my %needed_methods = (
'Pool' => ['providers'],
'Repo' => ['solvables'],
'Solvable' => ['compare', 'identical'],
);
eval { require satsolver; };
if ( $@ ) {
die unless ($@ =~ m{Can't locate});
} else {
$satsolver = 1;
foreach my $subpack (keys %needed_methods) {
foreach my $sym (@{$needed_methods{$subpack}}) {
if (not (defined $satsolver::{"${subpack}::"}->{$sym} or
defined $satsolver::{$sym})) {
$satsolver = -1;
}
}
}
}
# ---------------------------------------------------------------------------
# Reading config files
#
sub simplify_path ($) {
my ($path) = @_;
# remove additional "/"
$path =~ s{//+}{/}og;
return $path;
}
sub get_repo_conf ($) {
my ($root_dir) = @_;
my $cachedir;
$zypp_conf =~ m{^(.*)/};
my $zypp_confdir = $1;
if (not open(CONF, "<", "$root_dir/$zypp_conf")) {
Log(0, " open(\"$root_dir/$zypp_conf\"): $!\n");
} else {
# get metadatadir, reposdir (fallback) and solvfilesdir from zypp.conf
while (<CONF>) {
$cachedir = $1, next if m{^\s*cachedir\s*=\s*(\S+)\s*$};
$reposdir = $1, next if m{^\s*reposdir\s*=\s*(\S+)\s*$};
$metadatadir = $1, next if m{^\s*metadatadir\s*=\s*(\S+)\s*$};
$solvfilesdir = $1, next if m{^\s*solvfilesdir\s*=\s*(\S+)\s*$};
}
close(CONF);
}
$cachedir = $default_zypp_cache if not defined $cachedir;
$reposdir = "$zypp_confdir/$repossubdir" if not defined $reposdir;
$metadatadir = "$cachedir/$metadatasubdir" if not defined $metadatadir;
$solvfilesdir = "$cachedir/$solvfilessubdir" if not defined $solvfilesdir;
$cachedir = simplify_path("$root_dir/$cachedir");
$reposdir = simplify_path("$root_dir/$reposdir");
$metadatadir = simplify_path("$root_dir/$metadatadir");
$solvfilesdir = simplify_path("$root_dir/$solvfilesdir");
}
sub get_repo_infos () {
foreach my $repofile (glob("$reposdir/*.repo")) {
if (not open(REPO, "<", $repofile)) {
Log(0, " open(\"$repofile\"): $!\n");
} else {
# get reposubdir, name, and baseurl from this *.repo file
my $subdir;
while (<REPO>) {
$subdir = $1, last if m{^\s*\[(.*)\]\s*$};
}
if (defined $subdir) {
while (<REPO>) {
$repoinfo{$subdir}->{'name'} = $1, next if m{^\s*name\s*=\s*(.+)\s*$};
$repoinfo{$subdir}->{'baseurl'} = $1, next if m{^\s*baseurl\s*=\s*(\S+)\s*$};
}
}
close(REPO);
}
}
foreach my $subdir (keys %repoinfo) {
my $info_ref = $repoinfo{$subdir};
my $solvfile = "$solvfilesdir/$subdir/$solvfilename";
if ( -r $solvfile ) {
$repoinfo{$subdir}->{'solvfile'} = $solvfile;
} else {
# delete repositories without solv file
Log(0, " skipping repository without solv file %s\n" .
" name: %s\n baseurl: %s\n",
"$subdir:",
$info_ref->{'name'} . ",",
$info_ref->{'baseurl'});
delete $repoinfo{$subdir};
next;
}
my $contentfile = "$metadatadir/$subdir/content";
if (not open(CF, "<", $contentfile)) {
Log(0, " open(\"$contentfile\"): $!\n");
} else {
# get label from this content file
while (<CF>) {
$info_ref->{'label'} = $1, last if m{^\s*LABEL\s*(.+?)\s*$};
}
close(CF);
}
}
# make duplicate names and labels unique
foreach my $subdir (keys %repoinfo) {
my $info_ref = $repoinfo{$subdir};
my $name = $info_ref->{'name'};
my $label = $info_ref->{'label'};
my $next_name_cnt = 2;
my $next_label_cnt = 2;
foreach my $subdir2 (keys %repoinfo) {
next if ($subdir eq $subdir2);
if ($name eq $repoinfo{$subdir2}->{'name'}) {
$repoinfo{$subdir2}->{'name'} = "$name (" . ($next_name_cnt++) . ")";
}
if ($label eq $repoinfo{$subdir2}->{'label'}) {
$repoinfo{$subdir2}->{'label'} = "$label (" . ($next_label_cnt++) . ")";
}
}
$info_ref->{'name'} = "$name (1)" if $next_name_cnt > 2;
$info_ref->{'label'} = "$label (1)" if $next_label_cnt > 2;
}
# assign number and print found repos
my $cnt = 0;
foreach my $subdir (sort (keys %repoinfo)) {
my $info_ref = $repoinfo{$subdir};
$info_ref->{'number'} = ++$cnt;
Log(0, " found repository #%d: %s\n" .
" name: %s\n label: %s\n baseurl: %s\n",
$info_ref->{'number'},
"$subdir:",
$info_ref->{'name'} . ",",
$info_ref->{'label'} . ",",
$info_ref->{'baseurl'});
}
}
# ---------------------------------------------------------------------------
# Setting up a keyring with SUSE/Novell build keys
#
# SUSE/Novell vendors of supported packages
my $Vendors = qr((?:
SuSE\ GmbH |
SuSE\ AG |
SuSE\ Linux\ AG |
SUSE\ LINUX\ Products\ GmbH |
UnitedLinux\ LLC |
Novell
))ixo;
# SUSE/Novell build key of supported packages
my $Buildkeys = qr((?:
(?:SuSE|$Vendors)\ Package\ Signing\ Key |
(?:SuSE|$Vendors)\ Security\ Team |
Novell Provo Build |
Open Enterprise Server
))ixo;
# SUSE/Novell repository content file labels for supported installation sources
my $Labels = qr((?:
SUSE |
Novell
))ixo;
sub setup_key () {
my $cmd;
my ($key_id_string, $date, $pub_comment, $pub_line);
# only consider *.key and *.asc files
return if not m{\.(key|asc)$}io;
# find public keys and check comment string against SUSE/Novell vendor
# strings
$cmd = "$gpg_command $File::Find::name";
open(FH, "$cmd 2>&1 |") || Die("$cmd: failed to execute: $!\n");
while (<FH>) {
chomp;
if (m{^pub\s+(\S+)\s+(\S+)\s+(.*)$}) {
($key_id_string, $date, $pub_comment) = ($1, $2, $3);
$pub_line = $_;
}
Log(8, " $_\n");
}
close(FH);
if (not defined $pub_comment) {
Log(5, " gpg: not a public key file: %s\n",
$File::Find::name);
} elsif ($pub_comment =~ m{^$Buildkeys}) {
if (not defined $good_key_ids{$key_id_string}) {
Log(1, " gpg: using SUSE/Novell public key file: %s: %s\n",
$File::Find::name, $pub_line);
$good_key_ids{$key_id_string} ++;
$cmd = "$gpg_command --import $File::Find::name";
System($cmd);
} else {
Log(4, " gpg: already imported SUSE/Novell public key file: %s: %s\n",
$File::Find::name, $pub_line);
}
} else {
Log(4, " gpg: not using foreign public key file: %s: %s\n",
$File::Find::name, $pub_line);
}
}
# ---------------------------------------------------------------------------
# Is the package from us?
#
sub is_our_package ($$$$$) {
my ($rsaheadersig, $dsaheadersig, $rpmheader, $package_name, $vendor) = @_;
my $headersig;
my $cmd;
my $is_ours = 0;
# user asked to skip sig check or
# no SUSE/Novell keys we could use for checking?
if (not $CHECK_SIGNATURE or scalar (keys %good_key_ids) == 0) {
# cannot check, so fall back on the vendor string in the RPM DB and
# continue anyway, hoping for the best
return $vendor =~ m(^$Vendors)o;
}
# does the RPM DB have a signature for the header?
# use RSAHEADER (more hash bits) if available, or fall back to DSAHEADER
$headersig = ($rsaheadersig =~ m{(none)}) ? $dsaheadersig : $rsaheadersig;
if ($headersig =~ m{(none)}) {
# cannot check, use fallback
if ($vendor =~ m(^$Vendors)o) {
$is_ours = 1;
}
# log at level 0 if one of "our" packages had no signature (should not happen),
# log at level 4 if it is a "foreign" package without signature
Log($is_ours ? 0 : 4,
" rpm: no header signature, using vendor: %-45s %s\n",
"$package_name:", $vendor);
return $is_ours;
}
# convert hex strings to binary
my $rpmheader_bin = pack("H*H*", $headerprefix, $rpmheader);
my $headersig_bin = pack("H*", $headersig);
# save RPM header and signature
open(FH, ">", "$signedfile") || Die( "open($signedfile): $!\n");
print(FH $rpmheader_bin);
close(FH);
open(FH, ">", "$sigfile") || Die( "open($sigfile): $!\n");
print(FH $headersig_bin);
close(FH);
# check the signature of the RPM header with our selected keys
$cmd = "$gpg_command --verify $sigfile $signedfile";
open(FH, "$cmd 2>&1 |") || Die( "command failed: $cmd: $!\n");
while (<FH>) {
chomp;
if (m{^gpg:\s*Good\s+signature}io) {
Log(4, " $_: $package_name: $vendor\n");
$is_ours = 1;
} elsif (m{^gpg:\s*(?:Can't|Cannot)\s+check\s+signature}io) {
Log(5, " $_: $package_name: $vendor\n");
}
}
close(FH);
$num_sig_ok_packs += $is_ours;
return $is_ours;
}
my %prettyR =
(
"S" => "size",
"M" => "mode",
"5" => "checksum",
"D" => "device-node",
"L" => "sym-link",
"U" => "owner",
"G" => "group",
"T" => "mod-time",
"?" => "cannot-read",
);
#
# return pretty-printed result
#
sub prettyR($) {
my ($result) = @_;
my ($pretty) = ("'$result'");
$_ = $result;
if ( m{^U\:miss\s*(.)(\s+(.*))?$} ) {
$pretty = "missing" . (defined $3 ? " $3" : "");
} elsif ( m{^U\:mod (.):([SM5?DLUGT]+)(?: (.*)|)$} ) {
my ($kind, $summary_result, $R) = ($1, $2, $3);
my @L = map( $prettyR{$_}, split(//, $summary_result));
$pretty = "modified: " . join(", ", @L);
}
return $pretty;
}
#
# Create pretty-printed string for a size in bytes
#
sub prettyK($) {
my ($n) = @_;
my ($f, $p);
my @P = ("M", "G", "T");
if ( $n < 0 ) {
return sprintf( "%3dk??", $n);
} elsif ( $n < 1000 ) {
return sprintf( "%3d kB", $n);
}
while ( $n > 999 ) {
$p = shift(@P);
$f = $n % 1024;
$n = $n >> 10;
}
if ( $n > 9 ) {
return sprintf("%3d %sB", $n, $p);
}
$f = int(($f * 10 ) / 1024);
return sprintf("%d.%d %sB", $n, $f, $p);
}
#
# Execute program and die on errors with appropriate message
# Program output is logged at log level 2
# Also logs the command at log level 8
#
sub System ($) {
my ($cmd) = @_;
my @C = split(/ /, $cmd);
Log(8, "+$cmd\n");
# open a pipe to catch output as well
open(FH, "$cmd 2>&1 |") || Die("$C[0]: failed to execute: $!\n");
while (<FH>) {
Log(4, " " . $_);
}
close(FH);
if (WIFSIGNALED($?)) {
Die(sprintf( "$C[0]: died with signal %d, %s coredump\n",
(WTERMSIG($?)), ($? & 128) ? 'with' : 'without'));
} elsif ( WEXITSTATUS($?) != 0 ) {
Die("$C[0]: failed with error code %d\n", WEXITSTATUS($?));
}
}
# ---------------------------------------------------------------------------
# Find files that do not belong to any RPM package
#
# TODO: handle exclusion of directories
#
my @orphans = ("undef");
my %dirpath2devinode;
my %dircontents;
sub findOrphans($) {
our ($rootdir) = @_;
our ($rootlen, $rootdev, $ignoredir);
# based on 'airbag,v 1.2 2001/10/02 15:04:30'
# created by Torsten Duwe
# modified by Raymund Will
# "find" of additional files; more precisely files and directories that
# do not come from installed RPMs.
# We take a fsck-like approach: %dirpath2devinode holds a [dev:inode]
# pair for given directory path(s) and %dircontents stores the
# directory content's names, as if they had been received via
# opendir() and readdir().
# First we fill the %dirpath2devinode / %dircontents cache with
# list info from "rpm -qal", then we do a "find /" and report all new
# files and dirs encountered, pruning dirs, of course. A few
# well-known candidates are suppressed, for convenience.
# subroutine pathhash: make sure [dev:inode] pair for this path is
# known as well as those of all of its parents. Argument is a path
# string.
sub pathhash($);
sub pathhash($){
my($path) = @_;
print STDERR "pathhash($path): " if ($debug & 0x1);
my($dev,$ino,$mode,@rest,$parent,$myname);
# defensive programming: make sure our path string has exactly
# one slash at the beginning and for subdir separation, and no
# slash at the end.
$path =~ s,/+,/,g;
#$path =~ s,/$,,g;
$path =~ s,^/,,g;
$path = "/$path";
print STDERR "-> '$path'" if ($debug & 0x1);
if (defined $dirpath2devinode{$path}) {
print STDERR "=> known\n" if ($debug & 0x1);
return;
} # already known
print STDERR ": stat\n" if ($debug & 0x1);
($dev,$ino,$mode,@rest) = stat($rootdir . $path);
if (@rest < 10) {
print STDERR "cannot stat($rootdir,$path): $!\n"; return;
}
# if we stat()ed a directory, let's remember it.
if (($mode & 0xf000) == 0x4000) {
$dirpath2devinode{$path} = "$dev:$ino";
$dircontents{"$dev:$ino"} = "" unless defined($dircontents{"$dev:$ino"});
}
# so this one was new. how about the parent dir ? recursion will
# stop at "/" (provided it's the real root!), which is its own
# parent and will be "already known" above.
return if ( $path eq "/" );
$parent = $path;
$parent =~ s,/([^/]*)/?$,,;
$myname = "$1";
$parent =~ s,^/,,;
$parent = "/$parent";
# print(STDERR "parent='$parent' myname='$myname' %> ");
pathhash($parent);
# back from recursion -- ensure this path's name is listed in
# parent's contents.
if ($dircontents{$dirpath2devinode{$parent}} =~ m,/\Q$myname/, ){
# print " already have $parent##/##$myname\n";
} else {
$dircontents{$dirpath2devinode{$parent}} .= "/$myname/";
# print " $parent##/##$myname\n";
}
# print "$dirpath2devinode{$dir} <= $dir\n";
# $dirpath2devinode{$dir};
}
$rootlen = length($rootdir);
$rootdev = (lstat($rootdir))[0];
$ignoredir = 1;
$debug = 0;
$| = 1;
if ( $> == 0 && ( -x "./bin/rpm" ) ) {
open(FLIST, "chroot '$rootdir' ./bin/rpm -qal |") ||
Die( "open( chroot rpm -qa): $!\n");
} else {
open(FLIST, "/bin/rpm -qal --root '$rootdir'|") ||
Die( "open( rpm -qa): $!\n");
}
while(<FLIST>){
my($dir, $fname, $inode);
chomp;
s,/$,,; # doesn't ever happen, anyway.
s,/+,/,g;
m,^(.*/)([^/]+)$, || next;
$dir = $1; $fname = $2;
$dir =~ s,^/,,;
$dir = "/$dir";
next unless ( -d "$rootdir$dir" );
pathhash($dir);
$inode = $dirpath2devinode{$dir};
$dircontents{$inode} .= "/$fname/";
}
close( FLIST);
# subroutine wanted: called by the file tree walk for every node, with
# the basename() of the current node as string argument.
sub wanted() {
my($dir) = "/" . substr($File::Find::dir, $rootlen) . "/";
$dir =~ s,/+,/,g;
print STDERR "wanted: $_, dir='$dir'\n" if ($debug & 0x2);
# omit dot and dotdot, backup files, and well-known boring paths.
m/^\.\.?$/ && return;
m/~$/ && return;
# m/\.rpmorig$/ && return;
# m/\.rpmnew$/ && return;
# m,^/vmlinu, && return;
# m,^/initrd, && return;
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,@rest) = lstat($_);
$aInodes++;
$aSize += ($size + 512) / 1024;
if ($dev != $rootdev ) { $File::Find::prune = 1; return; }
if ($File::Find::name =~ m,^/vmlinu, ) { return; }
if ($File::Find::name =~ m,^/initrd, ) { return; }
if ($File::Find::name =~ m,/man/whatis$, ) { return; }
if ($File::Find::name =~ m,^/proc, ) { $File::Find::prune = 1; return; }
if ($File::Find::name =~ m,^/etc/rc\.d/rc[0-6]\.d, )
{ $File::Find::prune = 1; return; }
# if (!defined $dirpath2devinode{$dir}) {
# print " XXX $dir XXX no match in hash table !\n";
# return;
# }
# see if we know the dir we're in
pathhash($dir);
my $inode = $dirpath2devinode{$dir};
# does it know about the file/dir we're examining at this invocation ?
if ( $dircontents{$inode} =~ m,/\Q$_/, ) { # yes, ok.
print STDERR "known: ($dir) $_\n" if ($debug&0x4);
return;
} elsif ( $dir eq "/home/httpd/icons/" ) {
print STDERR "UNknown: ($dir) $_\n" if ($debug&0x4);
print STDERR "$inode=>'$dircontents{$inode}'\n" if ($debug&0x4);
}
# if not, let's have a closer look.
# we're not interested in symlinks at all.
if (($mode & 0xf000) == 0xa000) { return; }
my $isdir = "";
if (($mode & 0xf000) == 0x4000) {
return if ( $ignoredir );
$isdir = "/";
# maybe we know this directory, but by another name, if
# the installation has followed symlinks like /opt -> /usr/opt
if (defined $dircontents{"$dev:$ino"}) { return; }
}
$File::Find::prune = 1;
# the rare case of a l&f directory under a mount point. Checked here
# because of its low probability and because we want prune=1 for it.
if ($isdir eq "/" && $_ eq "lost+found" && $inode =~ /:2$/) { return; }
#print" $File::Find::name$isdir\n";
push @orphans, "$dir$_$isdir";
}
#$debug = 0x4;
find(\&wanted, $rootdir); # Launch !
}
# ---------------------------------------------------------------------------
# Return filehandle for the list of RPMs with ancillary data.
# May use cached data or pipe directly from the rpm command.
#
sub rpm_qa($) {
my ($root_dir) = @_;
my $FH;
my $rpmQ = "$rpm_command -qa --qf " .
"'%{NAME} %{VERSION}-%{RELEASE} %{ARCH} %{INSTALLTIME} " .
"%{VENDOR:shescape} %{RSAHEADER} %{DSAHEADER} %{HEADERIMMUTABLE}\n'";
# Either use cache if available...
if ( -d $cache_dir && -r $rpm_qa_cache ) {
open( $FH, "< $rpm_qa_cache") || Die( "open(rpm -qa): $!\n");
$_ = <$FH>;
if ( ! m{^# (\S+) -- (.*)$} ) {
Die("$progname: unknown cache format! Please remove.\n" .
"(e.g. with 'rm -rf $cache_dir/rpm-{qa,Vv})'\n");
} else {
my ($wrong_vers, $wrong_root) =
($cache_file_version ne $1, $root_dir ne $2);
if ( $wrong_vers or $wrong_root ) {
Die("$progname: invalid cache: %s%s%s. Please remove.\n" .
"(e.g. with 'rm -rf $cache_dir/rpm-{qa,Vv})'\n",
( $wrong_vers ? "wrong version" : "" ),
( $wrong_vers and $wrong_root ? " and" : "" ),
( $wrong_root ? "different root dir checked" : "" ));
# or should we only warn and "refresh" it automagically?
} else {
##$cacheHit ++;
#return $FH;
close($FH);
}
}
}
# rpm -qa is usually so fast, that we only cache to "record" the list
# of installed packages => no "cache accounting"
##$cacheMiss ++;
Log(8, "+%s\n", $rpmQ);
# ... or read directly from rpm command (and recreate cache if possible)
open($FH, "$rpmQ |") || Die( "rpm: $!\n");
if (-d $cache_dir) {
if (open(OUT, "> $rpm_qa_cache") ) {
print OUT "# $cache_file_version -- $root_dir\n";
while (<$FH>) {
print OUT;
}
close(OUT);
close($FH);
open($FH, "< $rpm_qa_cache") || Die( "reopen: $rpm_qa_cache: $!\n");
# skip version / root_dir string
$_ = <$FH>;
# pre-create directory for rpm_V()
if (! -d $rpm_Vv_cache) {
mkdir($rpm_Vv_cache) || warn "mkdir $rpm_Vv_cache: $!\n";
}
# pre-create directory for rpm_e()
if (! -d $rpm_e_cache ) {
mkdir($rpm_e_cache) || warn "mkdir $rpm_e_cache: $!\n";
}
} else {
warn("create: $rpm_qa_cache: $!\n");
}
}
return $FH;
}
#
# return filehandle for the output of "rpm -V..." on a package
# may use cached data or pipe directly from the rpm command
#
sub rpm_V($$) {
my ($root_dir, $package) = @_;
my $FH;
my $cache_file = "$rpm_Vv_cache/$package";
my $rpmV = "$rpm_command -Vv '$package' 2> /dev/null";
if (-r $cache_file) {
$cacheHit ++;
open($FH, "< $cache_file") || Die( "open($cache_file): $!\n");
return $FH;
}
$cacheMiss ++;
open($FH, "$rpmV |") || Die( "rpm -V: $!\n");
if (-d $rpm_Vv_cache) {
if (open(OUT, "> $cache_file")) {
while (<$FH>) {
print OUT;
}
close(OUT);
close($FH);
open($FH, "< $cache_file") || Die( "reopen($cache_file): $!\n");
} else {
warn("create: $cache_file: $!\n");
}
}
return $FH;
}
#
# return filehandle for the output of "rpm -e --test ..." on a package
# may use cached data or pipe directly from the rpm command
#
sub rpm_e($$) {
my ($root_dir, $package) = @_;
my $FH;
my $cache_file = "$rpm_e_cache/$package";
my $rpme = "$rpm_command -e --test '$package' 2> /dev/null";
if ( -r $cache_file ) {
$cacheHit ++;
open($FH, "< $cache_file") || Die( "open($cache_file): $!\n");
return $FH;
}
$cacheMiss ++;
open($FH, "$rpme |") || Die( "rpm -e: $!\n");
if (-d $rpm_e_cache) {
if (open(OUT, "> $cache_file") ) {
while (<$FH>) {
print OUT;
}
close(OUT);
close($FH);
open($FH, "< $cache_file") || Die( "reopen($cache_file): $!\n");
} else {
warn("create: $cache_file: $!\n");
}
}
return $FH;
}
# ---------------------------------------------------------------------------
# Assess if this file was changed in an unsupportable way. Return descriptive
# string for the supportability information based on the evaluation of the
# "rpm -V..." output for a single file from some package.
#
# assessment results:
# O: OK (miss/mod: no, supportability problem: no, report: lvl 4)
# H: Harmless (miss/mod: yes, supportability problem: no, report: lvl 3)
# T: Tolerable (miss/mod: yes, supportability problem: no, report: lvl 2)
# U: Unsupportable (miss/mod: yes, supportability problem: yes, report: lvl 1)
#
# change state of files:
# OK OK, no changes
# miss missing
# mod modified
#
# TODO: check report levels are well chosen and documented corrrectly
#
sub assess($$$$$) {
my ($rpm, $file, $kind, $result, $error) = @_;
my $summary_result = $result;
$summary_result =~ s{\.}{}g;
$error = (defined $error ? " ($error)" : "");
if ( $result =~ m{^\.{8}$} ) {
# file is not modified at all: OK
return "O:OK";
} elsif ( $result eq "missing " && $kind eq "d" ) {
# missing documentation: Harmless
return "H:miss doc" . $error;
} elsif ( $result eq "missing " ) {
# missing non-documentation file: Unsupportable
return "U:miss $kind" . $error;
} elsif ( $kind eq "c" ) {
# existing config file with any kind of changes:
# Harmless
return "H:mod c:$summary_result";
} elsif ( $result =~ m{^[UG.]{8}$} ) {
# existing (non-config) file with ownership change only:
# Tolerable
return "T:mod $kind:$summary_result";
} elsif ( $result =~ m{^[MUG.]{8}$} ) {
# existing (non-config) file with exactly some kind of
# ownership change and file mode change: Unsupportable
return "U:mod $kind:$summary_result";
} elsif ( $result =~ m{^[T.]{8}$} ) {
# existing (non-config) file with some kind of metadata
# change that does not affect ownership or file mode (and
# no other changes): Tolerable
return "T:mod $kind:$summary_result";
} else {
# existing (non-config) file
# - has a change in file size
# - has a content change
# - is a device node and major/minor has changed
# - is a softlink that has changed
# -> Unsupportable
return "U:mod $kind:$summary_result";
}
}
sub max($$) {
my ($a, $b) = @_;
return ($a > $b) ? $a : $b;
}
# Usage message
sub Usage($$) {
my( $rv, $msg) = @_;
print( STDERR $msg . "\n") if ( $msg );
print STDERR <<"EOF";
$progname $prog_version
Supportability Analysis Module
$progname [-v|--verbose] [-q|--quiet] [-d|--debug] [-t|--tmpdir <tmpdir>]
$progspcs [--no-header-sig-check] [--no-rpm-verify] [--no-orphan-search]
$progspcs [-w|--write] [root_path]
$progname [-h|--help]
If <root_path> is specified, it will be used as the path to the root of the
installation to verify.
Options:
-w|--write write reports to sam.* files
-t|--tmpdir write temporary files to <tmpdir> (default: $tmpdir)
$progname needs about 100KB for temporary files
--no-header-sig-check skip checking RPM header signature of installed packs
--no-rpm-verify skip verifying installed files against the RPM db
--no-orphan-search skip searching for orphaned files
-h|--help print this help message
-v|--verbose increase verbosity level
-q|--quiet decrease verbosity level
-d|--debug increase debug level
EOF
Die( $rv);
}
# ---------------------------------------------------------------------------
# Main program
#
{
use Getopt::Long;
$Getopt::Long::debug = 0;
$Getopt::Long::ignorecase = 0;
$Getopt::Long::bundling = 1;
$Getopt::Long::passthrough = 0;
my %Opt = ();
Usage( -1, "") unless ( GetOptions( \%Opt,
'help|h', , 'verbose|v+', 'quiet|q+', 'debug|d+',
'write|w', 'tmpdir|t:s', 'no-header-sig-check',
'no-rpm-verify', 'no-orphan-search'));# && ! $Opt{'help'} );
Usage(0, "") if ( $Opt{'help'} );
$debug += $Opt{'debug'} if ( $Opt{'debug'} );
$verbose += $Opt{'verbose'} if ( $Opt{'verbose'} );
$verbose -= $Opt{'quiet'} if ( $Opt{'quiet'} );
$writeReport = 1 if ( $Opt{'write'} );
$tmpdir = $Opt{'tmpdir'} if ( $Opt{'tmpdir'} );
$CHECK_SIGNATURE = 0 if ( $Opt{'no-header-sig-check'} );
$VERIFY_PACKAGES = 0 if ( $Opt{'no-rpm-verify'} );
$FIND_DETACHED = 0 if ( $Opt{'no-orphan-search'} );
}
$verbose = ($verbose < 0) ? 0 : $verbose;
$debug = ($debug <= 0) ? 0 : (1 << $debug) - 1;
if ( exists( $ARGV[0]) && -d $ARGV[0] ) {
$root_dir = $ARGV[0];
$rpm_command .= " --root '$root_dir'";
}
#
# set up temp file names and delete stale temp files
#
Die("$tmpdir is not a writeable directory\n") if ( not (-d $tmpdir and -w $tmpdir) );
$pubring = "$tmpdir/$pubring";
$sigfile = "$tmpdir/$sigfile";
$signedfile = "$tmpdir/$signedfile";
$unlink_ok = 1;
unlink($pubring, $sigfile, $signedfile);
#
# write reports if we have the $cache_dir directory
#
$writeReport++ if ( -d $cache_dir );
if ( $writeReport ) {
open( LOG, "> sam.log") || Die("open(LOG): $!\n");
open( REPORT, "> sam.report") || Die("open(REPORT): $!\n");
open( HTML, "> sam.html") || Die("open(HTML!\n");
open( JSON, "> sam.json") || Die("open(JSON!\n");
} else {
open( LOG, ">> /dev/null") || Die("open(/dev/null): $!\n");
open( REPORT, ">& LOG") || Die("dup(LOG, REPORT): $!\n");
Log( 1, "$progname: $cache_dir: no such directory.\n" .
" sam.{log,report,html.json} will not be written.\n\n");
}
# ---------------------------------------------------------------------------
Log(0, "%%T: MS00: started %s\n", $invocation_cmd_line);
Log(0, "%%T: MS01: Find metadata and set up GPG\n");
#
# read available configuration and repository infos
#
# get (configured) locations of repository files
get_repo_conf($root_dir);
# get infos about all repositories
get_repo_infos();
if (not $CHECK_SIGNATURE) {
Log(0, " rpm header signature check disabled: will not check package authenticity\n");
} elsif (not -x $gpg_exe) {
Log(0, " GPG executable \"$gpg_exe\" not found: will not check package authenticity\n");
} else {
# setup keyring
find(\&setup_key, $metadatadir);
if (scalar (keys %good_key_ids) > 0) {
Log(0, " found %d SUSE/Novell build keys: will check package authenticity\n",
scalar (keys %good_key_ids));
} else {
Log(0, " no SUSE/Novell build keys found: cannot check package authenticity\n");
}
}
# ---------------------------------------------------------------------------
# Enumerate packages
#
my $max_pack_name_length = 0;
my $max_filename_length = 0;
Log(0, "%%T: MS02: enumerate packages (1a)\n");
my $IN = rpm_qa($root_dir);
while ( <$IN> ) {
chomp();
if ( ! m{^(\S+) (\S+) (\S+) ([0-9]+) '(.*?)' (\S+) (\S+) (\S+)$} ) {
Log(0, " rpm: unexpected query response: '$_'\n");
next;
}
my ($name, $vers_rel, $arch, $inst_time, $vendor,
$rsaheadersig, $dsaheadersig, $rpmheader) =
($1, $2, $3, $4, $5, $6, $7, $8);
my $package_name = "$name-$vers_rel.$arch";
$vendor ||= "undef";
if ( $arch eq '(none)' and $package_name =~ m{^gpg-pubkey-} ) {
# "silently" drop verification keys
Log(5, " rpm: dropping: $package_name\n");
next;
}
# check for SUSE/Novell package
my $is_ours = is_our_package($rsaheadersig, $dsaheadersig, $rpmheader,
$package_name, $vendor);
if ( $arch eq '(none)' and $is_ours ) {
#if ( $vendor =~ m(^$Vendors)o ) {
# ignore SUSE/Novell packages without architecture info
Log(0, " rpm: ignoring: $package_name\n");
$skipped_packages{$package_name} = "$inst_time $vendor";
next;
}
#if ( $vendor !~ m(^$Vendors)o ) {
if ( not $is_ours ) {
# remember packages from other vendors
Log(0, " rpm: foreign vendor package: $package_name: $vendor\n");
$alien_packages{$package_name} = "$inst_time $vendor";
$alien2name{$package_name} = $name;
$alien2edition{$package_name} = "$vers_rel";
next;
}
$package2inst_time{$package_name} = $inst_time;
$package2name{$package_name} = $name;
$package2edition{$package_name} = "$vers_rel";
$max_pack_name_length = max($max_pack_name_length, length($package_name));
}
close($IN);
# ---------------------------------------------------------------------------
# Verify installed files against package headers:
# first "our" packages, then "foreign" packages
#
my $num_packages = scalar(keys(%package2inst_time));
my $num_foreign = scalar(keys(%alien_packages));
my %inodes;
my %file2rpm;
my %file2kind;
my %file2type;
my %file2res;
my %unsatisfied;
my %foreign_unsatisfied;
my %depends_on_alien;
my @file_modified;
my @file_tolerated;
my @file_missing;
my @file_dispensable;
my @foreign_file_modified;
my @foreign_file_tolerated;
my @foreign_file_missing;
my @foreign_file_dispensable;
my %unsupportable;
my %tolerable;
my %harmless;
my %ok;
my $is_ours = 0;
# have we seen this filename already?
# -> handle duplicates
#
sub check_and_log_duplicate_file ($$$$$$) {
my ($logBuffer_ref, $rpm, $file, $kind, $vrfy_result, $error) = @_;
if ($ALLOW_MULTIHOMED_OBJECTS) {
# if multihomed files are allowed, all the packages for such a file are
# remembered
push @{ $file2rpm{$file} }, $rpm;
if ( exists( $file2kind{$file}) && $file2kind{$file} ne $kind ) {
Die( "$file: conflicting attributes: $file2kind{$file} <> $kind\n");
} else {
$file2kind{$file} = $kind;
#Log( 0, "$file\n") if $kind eq "d" && $vrfy_result eq "missing ";
}
} else {
# if multihomed files are not allowed, log entries will be generated
if ( exists($file2rpm{$file}) ) {
# file is multihomed
$_ = $file2res{$file};
$$logBuffer_ref = " "x4 . "$file: duplicate $file2rpm{$file}\n";
if ( m{^[UTH]:miss} ) {
# a duplicate of a missing object hardly makes it worse...
$$logBuffer_ref .= " "x6 ."dupe: miss\n";
$file2res{$file} .= " && U:dup :$rpm";
push @{ $unsupportable{$rpm} }, $file;
} elsif ( m{^U:} ) {
if ( $file2type{$file} eq "dir" ) {
# packaging directories multiple times is OK...
$$logBuffer_ref .= " "x6 ."dup: U: dir => H\n";
$file2res{$file} .= " && H:dupe:$rpm";
} else {
# ...but not other objects
$$logBuffer_ref .= " "x6 ."dup: U: !dir => U\n";
$file2res{$file} .= " && U:dupe:$rpm";
push @{ $unsupportable{$rpm} }, $file;
}
} elsif ( $file2type{$file} eq "dir" ) {
# again, packaging directories multiple times is OK...
$$logBuffer_ref .= " "x6 ."dup: H: dir => H\n";
$file2res{$file} .= "H:dupe: $rpm";
} else {
$_ = assess($rpm, $file, $kind, $vrfy_result, $error);
if ( ! m{^U:} ) {
# ...if it verifies OK, only note
$$logBuffer_ref .= " "x6 ."dup: H: same => H\n";
$file2res{$file} .= "H:dupe: $rpm";
} else {
# ...otherwise promote to "Unsupportable"
$$logBuffer_ref .= " "x6 ."dup: H: !dir => U\n";
$file2res{$file} = "$_ && U:dupe: $rpm && $file2res{$file}";
if ( ! exists $unsupportable{$file2rpm{$file}} ) {
push @{ $unsupportable{$file2rpm{$file}} }, $file;
}
# FIXME: why push $file twice on @{$unsupportable{$file2rpm{$file}}}
# if it does not exist? (see above and below): the above
# should be unnecessary
push @{ $unsupportable{$file2rpm{$file}} }, $file;
push @{ $unsupportable{$rpm} }, $file;
}
}
return 1;
}
# not multihomed: record package for this file
$file2rpm{$file} = $rpm;
$file2kind{$file} = $kind;
}
return 0;
}
sub evaluate_supportability_and_record_results ($$$$$) {
my ($rpm, $file, $kind, $vrfy_result, $error) = @_;
# is the result for the file a supportability problem? classify...
$_ = assess($rpm, $file, $kind, $vrfy_result, $error);
#$packinfo{$rpm}->{file}->{$file}->{res} = $_;
$file2res{$file} = $_;
if ( m{^U:miss} ) {
if ($is_ours) {
push @file_missing, $file;
push @{ $unsupportable{$rpm} }, $file;
} else {
push @foreign_file_missing, $file;
}
return;
} elsif ( m{^T:miss} ) {
if ($is_ours) {
push @file_dispensable, $file;
push @{ $tolerable{$rpm} }, $file;
} else {
push @foreign_file_dispensable, $file;
}
return;
} elsif ( m{^H:miss} ) {
if ($is_ours) {
push @file_dispensable, $file;
push @{ $harmless{$rpm} }, $file;
} else {
push @foreign_file_dispensable, $file;
}
return;
} elsif ( m{^U} ) {
if ($is_ours) {
push @file_modified, $file;
push @{ $unsupportable{$rpm} }, $file;
} else {
push @foreign_file_modified, $file;
}
} elsif ( m{^T} ) {
if ($is_ours) {
push @file_tolerated, $file;
push @{ $tolerable{$rpm} }, $file;
} else {
push @foreign_file_tolerated, $file;
}
} elsif ( m{^H} ) {
if ($is_ours) {
push @{ $harmless{$rpm} }, $file;
}
} elsif ( m{^O} ) {
if ($is_ours) {
push @{ $ok{$rpm} }, $file;
}
} else {
Die("$progname: internal error. $_\n");
}
# when we see the file for the first time, add to total size of all files,
# increase number of different files and remember type of file (file, dir,
# link, special)
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks) =
lstat( $root_dir . $file);
if ( -f _ ) {
$file2type{$file} = "file";
if (! exists $inodes{"$dev:$ino"}) {
$pSize += ($size + 512) / 1024;
}
} elsif ( -d _ ) {
$file2type{$file} = "dir";
} elsif ( -l _ ) {
$file2type{$file} = "link";
} else {
$file2type{$file} = "special";
}
if (! exists $inodes{"$dev:$ino"}) {
$inodes{"$dev:$ino"} = 1;
$pInodes++;
}
}
sub verify_packages ($$$) {
my ($packhash_ref, $unsatisfied_ref, $msg) = (@_);
foreach my $rpm ( sort(keys(%$packhash_ref)) ) {
$logBuffer = "";
Log(1, " %%T: $msg: $rpm\n");
$IN = rpm_V($root_dir, $rpm);
while ( <$IN> ) {
chomp();
if (m{^([S.][M.][5?.][D.][L.][U.][G.][T.]|missing ) ([cdglr ]) (\S.+)$}) {
# note: rpm(8) calls the file kind (%config, %doc, ...) an
# "attribute" of the file
my ($vrfy_result, $kind, $file, $error) = ($1, $2, $3, undef);
if ($vrfy_result =~ /missing/ and $file =~ /^(\S.+) \(([^\(\)]*)\)$/) {
$file = $1;
$error = $2;
}
$max_filename_length = max($max_filename_length, length($file));
next if check_and_log_duplicate_file(\$logBuffer, $rpm, $file,
$kind, $vrfy_result, $error);
evaluate_supportability_and_record_results($rpm, $file, $kind,
$vrfy_result, $error);
} elsif ( m{^Unsatisfied dependencies for ([^:]+)\: (\S.+)$} ) {
my ($pkg, $deps) = ($1, $2);
$$unsatisfied_ref{$pkg} = $deps;
} else {
Die( "$progname: rpm: unexpected query response:\n $_\n");
}
}
close( $IN);
Log(3, $logBuffer) if $logBuffer;
}
}
Log(0, "%%T: MS03: verify");
if (not $VERIFY_PACKAGES) {
Log(0, "%d packages: skipped\n", $num_packages);
} elsif ( $num_packages == 0 ) {
Log(0, "%%T: Panic: no packages to verify!?\n");
Die(-1);
} else {
Log(0, " %d packages\n", $num_packages);
# first, verify "our" packages
$is_ours = 1;
verify_packages(\%package2inst_time, \%unsatisfied, "verify");
# then verify "foreign" packages
$is_ours = 0;
verify_packages(\%alien_packages, \%foreign_unsatisfied, "verify foreign");
}
# ---------------------------------------------------------------------------
Log(0, "%%T: MS04: find packages that depend on foreign packages\n");
foreach my $rpm ( sort(keys(%alien_packages)) ) {
Log(1, " find dependents on: $rpm\n");
$IN = rpm_e($root_dir, $rpm);
while ( <$IN> ) {
chomp();
if (m{^error: Failed dependencies:$}) {
Log(4, " rpm: found dependents on: $rpm\n");
} elsif (m{^\s+(.*)\s+is needed by(?: \(installed\))? (\S+)$}) {
my ($provided, $dependant_pack) = ($1, $2);
# remember if the dependant package is one of ours
if (exists $package2inst_time{$dependant_pack}) {
push @{$depends_on_alien{$dependant_pack}->{$rpm}}, $provided;
Log(4, " rpm: our package $dependant_pack needs $provided from $rpm\n");
}
} else {
Die("$progname: rpm: unexpected query response:\n $_\n");
}
}
close( $IN);
}
# ---------------------------------------------------------------------------
# Find SUSE/Novell source repos for installed packages, compare versions
#
my %newer_exists = ();
Log(0, "%%T: MS05: Identify package sources (2i)");
if ($satsolver == 0) {
Log(0, ": skipped: no satsolver\n");
} elsif ($satsolver == -1) {
Log(0, ": skipped: no usable satsolver (missing functions)\n");
} elsif ((scalar keys %repoinfo) == 0) {
Log(0, ": skipped: no repositories\n");
} else {
Log(0, "\n");
# create pool
my $pool = new satsolver::Pool;
# set architecture: only compatible packages are considered
my $sysarch = `uname -m` || Die("uname -m\n");
chomp $sysarch;
$pool->set_arch($sysarch);
# create repo with RPM database
my $installed = $pool->create_repo('installed') || Die("create_repo('installed')\n");
$installed->add_rpmdb("/");
# create a repo each for SUSE/Novell installation sources
my @repos = ();
foreach my $subdir (keys %repoinfo) {
my $name = $repoinfo{$subdir}->{'name'};
my $label = $repoinfo{$subdir}->{'label'};
next if $label !~ m($Labels)o;
Log(0, " using repository %s\n", $name);
push @repos, $pool->create_repo($subdir) || Die("create_repo($subdir)\n");
$repos[$#repos]->add_solv($repoinfo{$subdir}->{'solvfile'});
}
# create dependencies to provides table
$pool->prepare();
# find providers for each installed package
foreach my $inst_solvable ($installed->solvables()) {
Die "inst_solvable not defined\n" if not defined $inst_solvable;
my $inst_solvname = $inst_solvable->name();
my $inst_solvevr = $inst_solvable->evr();
my $inst_solvstring = $inst_solvable->string();
my %found = ();
foreach my $solvable ($pool->providers($inst_solvable->name())) {
next if (not defined $solvable);
my $subdir = $solvable->repo()->name();
# do not use matches on the 'installed' repo
next if $subdir eq "installed";
my $reponame = $repoinfo{$subdir}->{name};
my $reponumber = $repoinfo{$subdir}->{number};
# identical package? (name, arch, evr, vendor, build time,
# requires, ...)
if ($solvable->identical($inst_solvable)) {
Log(3, " = %-69s (repo has same package: %s)\n",
$inst_solvstring, $reponame);
$found{identical}++;
} else {
# find out if the repository provides an older or newer package
my $result = $solvable->compare($inst_solvable);
my $solv_evr = $solvable->evr();
if ($result < 0) {
Log(2, " + %-35s %-15s > %-15s (repo has older evr: %s)\n",
$inst_solvname, $inst_solvevr, $solv_evr, $reponame);
$found{older}++;
} elsif ($result > 0) {
Log(1, " - %-35s %-15s < %-15s (repo has newer evr: %s)\n",
$inst_solvname, $inst_solvevr, $solv_evr, $reponame);
$found{newer}++;
push @{$newer_exists{$inst_solvstring}}, "repo #$reponumber: $solv_evr";
} else {
# identical evr, different package: strange
# (manual rebuild installed or in repo?)
Log(1, " ! %-35s %-15s ~ %-15s (repo has same evr: %s)\n",
$inst_solvname, $inst_solvevr, $solv_evr, $reponame);
$found{similar}++;
}
}
}
if ((scalar(keys %found)) == 0) {
Log(0, " m %-69s (no package with this name exists in SUSE/Novell repos)\n",
$inst_solvname);
} elsif (not exists $found{identical}) {
Log(0, " ? %-69s (not found in SUSE/Novell repos)\n",
$inst_solvstring);
}
}
}
# ---------------------------------------------------------------------------
Log( 0, "%%T: MS06: find 'detached' files (1e)");
if ( not $FIND_DETACHED ) {
Log( 0, ": skipped\n");
shift @orphans;
$aSize = $aInodes = -1;
} else {
Log( 0, "\n");
findOrphans($root_dir);
}
# ---------------------------------------------------------------------------
Log( 0, "%%T: MS90: Reporting Results...\n");
# ===========================================================================
Report("*** Report by %s\n", $invocation_cmd_line);
Report("*** Considered Packages (1a): %d (sig ok: %s), foreign: %d (excluded: %d)\n",
$num_packages, $CHECK_SIGNATURE ? $num_sig_ok_packs : "OFF",
$num_foreign, scalar( keys( %skipped_packages)));
my $unsupportable = scalar( keys( %unsupportable));
my $tolerable = scalar( keys( %tolerable));
Report("*** Packages with Verification Anomalies (1b): ");
if (not $VERIFY_PACKAGES) {
Report( "NOT CHECKED.\n");
} elsif ( $unsupportable + $tolerable > 0 ) {
Report( "%d (+%d minor)\n", $unsupportable, $tolerable);
} else {
Report( "NONE.\n");
}
my $unsat = scalar( keys( %unsatisfied));
Report("*** Violated Package Dependencies (1c): ");
if (not $VERIFY_PACKAGES) {
Report( "NOT CHECKED.\n");
} elsif ( $unsat > 0 ) {
Report("%d\n", $unsat);
foreach my $package ( sort( keys( %unsatisfied)) ) {
Report(" %s\n %s\n", $package, $unsatisfied{$package});
}
} else {
Report("NONE.\n");
}
my $aliendeps = scalar( keys( %depends_on_alien));
Report("*** Packages Depending on Foreign Packages (2l): ");
if ( $aliendeps > 0 ) {
Report("%d\n", $aliendeps);
foreach my $package ( sort( keys( %depends_on_alien)) ) {
Report( " %s\n %s\n", $package, join (" ", sort( keys( %{$depends_on_alien{$package}}))) );
}
} else {
Report("NONE.\n");
}
if ( $unsupportable + $unsat + $aliendeps > 0 ) {
$Unsupportable = 1;
}
# ---------------------------------------------------------------------------
Report("*** Found Package Repositories (2h): ");
my $num_repos = (keys %repoinfo);
if ( $num_repos == 0 ) {
Report("NONE.\n");
} else {
Report("%d\n", $num_repos);
foreach my $subdir (sort (keys %repoinfo)) {
my $info_ref = $repoinfo{$subdir};
Report(" Repository #%d:\n", $info_ref->{number});
Report(" %s\n",
join("\n ", map(sprintf("%-12s %s", "$_:", $info_ref->{$_}),
(sort (keys %$info_ref)))));
}
}
# ---------------------------------------------------------------------------
Report("*** Package Version Checks (2i): ");
my $num_old_packages = (keys %newer_exists);
if ($satsolver <= 0) {
Report("NOT CHECKED.\n");
} elsif ( $num_old_packages > 0 ) {
Report("updates available for %d packages\n", $num_old_packages);
foreach my $pack (sort(keys(%newer_exists))) {
Report(" %-55s %s\n", "$pack:", join(", ", @{$newer_exists{$pack}}));
}
} else {
Report("NONE.\n");
}
# ---------------------------------------------------------------------------
Report("*** Modified filesystem objects (1d): ");
if (not $VERIFY_PACKAGES) {
Report("NOT CHECKED.\n");
} elsif ( ($#file_modified + $#file_tolerated) > 0 ) {
Report("%d (+%d ignored)\n", $#file_modified + 1, $#file_tolerated + 1);
foreach my $pack ( sort( keys(%unsupportable)) ) {
Report(" %s\n", $pack);
my $num_files = 0;
foreach my $pfile ( @{ $unsupportable{$pack} } ) {
my $res = prettyR($file2res{$pfile});
# if ( length($pfile) + length($res) > 72 ) {
# ReportQ(" "x4 ."%s\n" ." "x6 ."%s\n", $pfile, $res);
# } else {
## ReportQ(" "x4 ."%s %s\n", $pfile, $res);
# ReportQ(" "x4 ."%-*s %s\n", 55 - max((72 - 55), length($res)), $pfile, $res);
# }
ReportQ(" "x4 ."%-55s %s\n", $pfile, $res);
Log(9, " "x6 ."%s %s\n", $file2kind{$pfile}, $file2res{$pfile});
if ( $num_files++ >= 10 ) {
ReportQ(" "x4 ."and %d more\n", $#{ $unsupportable{$pack} } - 10);
last;
}
}
}
} else {
Report("NONE.\n");
}
# ---------------------------------------------------------------------------
Report("*** Accrued filesystem objects (1e): ");
if (not $FIND_DETACHED) {
Report( "NOT CHECKED.\n");
} elsif ( $#orphans == 0 ) {
Report("* s k i p p e d *.\n");
} elsif ( $#orphans >= 0 ) {
Report("%d (+%d ignored)\n", $#orphans, 0);
shift @orphans;
Log(1, " %s\n", join( "\n ", @orphans));
} else {
Report("NONE.\n");
}
Report("*** Preliminary Conclusion: %ssupportable.\n",
(($Unsupportable) ? "NOT " : ""));
Report(" %d (%.2f%%) OK, %d (%.2f%%) dubious, %d (%.2f%%) fail\n",
($num_packages - $unsupportable - $unsat - $aliendeps),
($num_packages - $unsupportable - $unsat - $aliendeps) * 100.0 / $num_packages,
$unsupportable,
$unsupportable * 100.0 / $num_packages,
($unsat + $aliendeps),
($unsat + $aliendeps) * 100.0 / $num_packages);
if ($Unsupportable) {
Report(" This is a preliminary interpretation.\n");
Report(" A detailed analysis of the report or the log file\n");
Report(" may show that this system is supportable.\n");
}
# ===========================================================================
if ( $writeReport ) {
my ($user, $system, $cuser, $csystem) = times();
my $Telapsed = time() - $Tstart;
Log( 1, "%%T: MS92: Generate reports...\n");
initHTML();
foreach my $p ( sort( keys( %package2inst_time)) ) {
my ($r, $n, $t) = ( 0, "", "");
$t = $unsatisfied{$p};
if (defined( $t) ) {
$r = 1;
$n .= "unsatisfied dependencies: $t";
}
if (defined( @{ $unsupportable{$p} }) ) {
$r = 1;
$n .= "; " if ( $n );
$t = $#{ $unsupportable{$p} } + 1;
$n .= sprintf( "%d object%s modified", $t,
($t != 1) ? "s were" : " was");
}
printHTML($p, $r, $n);
fillJSON($p, $r, $n);
}
finishHTML();
finishJSON();
Log(1, "%%T: MS95: Log statistics...\n");
Log(1, " Filesystem: %s, %d inodes over all\n",
prettyK($aSize), $aInodes);
Log(1, " rpmDB: %s, %d inodes from %d packages (hit %d, miss %d)\n",
prettyK($pSize), $pInodes, scalar( keys( %package2inst_time)),
$cacheHit, $cacheMiss);
Log(1, " Runtime (in secs): %.2f user, %.2f system, %.2f elapsed\n",
$user, $system, $Telapsed);
open( IN, "< /proc/self/status")|| Die( "open(status): $!\n");
Log(1, " Memory: ");
while ( <IN> ) {
next unless ( m{^(Vm(Size|RSS|Data))} );
chomp; s{\s+}{}g; s{\:}{=}g;
Log(1, " %s", $_);
}
Log(1, "\n");
close( IN);
}
exit($Unsupportable);
