#!/usr/bin/perl
#
#    rpmuncovered  --  small RPM management helper for Linux console
#
#    Reads list of filenames:
#      * from command line
#      * and from stdin, if command line contains "-".
#
#    Displays only names of files:
#      * modified after installation,
#      * or not owned by any package.
#
#    Requires Perl::RPM package.
#
#    Written by evseev@ucvt.ru at Jan 2003 as helper for MicroBackup.
#    Continued by ilya_evseev@mail.ru at Nov 2004 as standalone utility.
#
#    Distributed under terms of GNU GPL.
#

use RPM::Database;
use RPM::Header;
use RPM::Error;
use RPM::Constants;

use strict vars;
use warnings;

our $MY_NAME = "rpmuncovered";
our $MY_VERSION = "0.3";

tie %RPM::RPM, "RPM::Database" or die "$RPM::err";
our $rpmdb = tied %RPM::RPM;

our $debug_mode = 0;

our $around_mode = 0;   # 0=only this file, 1=only in this dir, 2=all package

our %checked_packages;
our %checked_dirs; # { path => (mode1: bool | mode2: ref to {path => bool} ) }

sub debug_print(*) {
	return unless $debug_mode;
	print " (debug) @_\n";
}

sub error_print(*) {
	print STDERR "@_\n";
}

sub ferror_print(*) {
	print STDERR "@_(", $!, "\n";
}

sub my_version() {
	print "$MY_NAME $MY_VERSION\n";
}

sub usage() {
	print "Usage: $MY_NAME [-f|-d|-a|-?] file...\n"
	    . "Check file is not owned by any RPM package, or is modified after install.\n"
	    . "Displays filename when it is not owned or modified.\n"
	    . "Special filename \"-\" means that filenames are readed from standard input.\n"
	    . " -a   check also all files in package containing given file\n"
	    . " -s   check also all files in the same package and same directory\n"
	    . " -f   (default) check given file only\n"
	    . " -V, --version    display helper version\n"
	    . " -?, --help       display this usage\n";
}

sub dirname($)
{
	my $fpath = shift;
	my $lastSlash = rindex($fpath,"/");
	substr($fpath, 0, $lastSlash);
}

sub dircontains($$)
{
	my $dirname = shift;
	my $fpath   = shift;
	my $dirlen  = length($dirname);
	my $fnlen   = length($fpath);
	
	return 0 if substr($fpath, 0, $dirlen) ne $dirname;
	return 1 if $dirlen == $fnlen;
	return 1 if substr($fpath, $dirlen, 1) eq "/";
	0;
}

sub check_one_file($)
{
	my $fname = shift;
	my $header;
	unless ($header = $rpmdb->find_by_file($fname)) {
		print "$fname\n";
		return;
	}
	my $basedir = dirname($fname);
	
	#
	#   Store information about package to %checked_packages{}
	#   Don't continue if package or directory is already processed
	#
	
	my $must_be_skipped = 0;
	if ($around_mode == 0) {
		#----  only this file  ----#
	} elsif ($around_mode == 1) {
		#----  all files in the same dir+package  ----#
		my $n = $header->{NAME};
		$checked_packages{$n} = {} unless $checked_packages{$n};
		my $d = $checked_packages{$n};
		debug_print "already checked dirs = " . join(" ",keys(%$d));
		$must_be_skipped = 1 if $$d{$basedir};
		$$d{$basedir} = 1;
	} elsif ($around_mode == 2) {
		#----  all files in the same package  ----#
		$must_be_skipped = $checked_packages{$header->{NAME}} || 0;
	#	$must_be_skipped = 0 unless defined $must_be_skipped;
		$checked_packages{$header->{NAME}} = 1;
	}
#	debug_print "must_be_skipped = $must_be_skipped";
	debug_print "$fname: "
		. "dir=" . $basedir . ", "
		. "pkg=" . $header->{NAME} . ": "
		. ("ok", "skipped")[$must_be_skipped];
	next if $must_be_skipped;
	
	my $fnames = \@{$header->filenames};
	my $ftimes = \@{$header->{FILEMTIMES}};
	my $flinks = \@{$header->{FILELINKTOS}};
	my $dirindexes = \@{$header->{DIRINDEXES}};
	my $i = 0;

	debug_print "files count = $#{$fnames}, mtimes count = $#{$ftimes}, indexes count = $#{$dirindexes}";
#	debug_print "fnames = @$fnames";
#	debug_print "mtimes = @$ftimes";
#	debug_print "indexs = @$dirindexes";
	
	for my $fn (@$fnames) {
		next if -d $fn;
		next if ($around_mode == 0) && ($fn ne $fname);
	  ##	debug_print "basedir=$basedir, bd=$bd";
		next if ($around_mode < 2) && !dircontains($basedir, $fn);
		debug_print "check $fn";
		unless ( -e $fn ) {
			ferror_print "$fn: not found!";
			next;
		}
		if ( -l $fn ) {
		#	debug_print "$fn is symlink";
			my ($pkg_target, $fs_target);
			unless ($pkg_target = $$flinks[$i]) {
				error_print "$fn: fs=symlink, pkg=file";
				next;
			}
			unless ($fs_target = readlink $fn) {
				ferror_print "$fn: cannot readlink";
				next;
			}
		#	debug_print "check fs=$fs_target, pkg=$pkg_target";
			if ($pkg_target ne $fs_target) {
				error_print "$fn: fs=$fs_target, pkg=$pkg_target";
			}
			next;
		}
		my $dindex = $$dirindexes[$i];
		if (my ( $dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
		     $atime,$mtime,$ctime,$blksize,$blocks ) = lstat($fn) )
		{
    			debug_print "file $i = \"$fn\", time = " . $$ftimes[$i];
			if ($mtime != $$ftimes[$i]) {
				print $fn, "\n";
				debug_print "$i, $dindex, rpm(i) = $$ftimes[$i], rpm(index) = $$ftimes[$dindex], actual = $mtime";
			}
		} else {
			ferror_print "$fn: cannot stat!";
		}
	} continue {
		$i++;
	}
}

sub MAIN {

if (defined $ARGV[0] and $ARGV[0] eq "-d") {
	shift @ARGV;
	$debug_mode = 1;
}

unless (defined $ARGV[0]) {
	usage();
	return;
}

if ($ARGV[0] eq "-a") {
	$around_mode = 2; shift @ARGV;
} elsif ($ARGV[0] eq "-s") {
	$around_mode = 1; shift @ARGV;
} elsif ($ARGV[0] eq "-f") {
	$around_mode = 0; shift @ARGV;
} elsif ($ARGV[0] eq "-?" || $ARGV[0] eq "--help") {
	usage();
	return;
} elsif ($ARGV[0] eq "-V" || $ARGV[0] eq "--version") {
	my_version();
	return;
}

for my $arg (@ARGV) {
	if ($arg eq "-") {
		while (my $line = <STDIN>) {
			chomp $line;
			foreach my $w (split(/ /, $line)) {
				check_one_file $w;
			}
		}
	} else {
		check_one_file $arg;
	}
}

}  # MAIN

MAIN

## EOF ##
