openSUSE Build Service

Overview Repositories Revisions Requests Users Attributes Meta

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

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);

Places

File sam of Package suse-sam

Places