#!/usr/bin/perl -w
#
# $Id: newrpms,v 1.5 2005/06/29 00:17:43 bernie Exp $
# Copyright 2001, 2002, 2003, 2005 Bernardo Innocenti <bernie@codewiz.org>
#
# 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.
#

use strict;

sub usage
{
	print <<END
Usage: $0 [OPTIONS] [dir]
 dir - directory to scan for rpm packages (defaults to current directory)

 -d  Delete obsolete files
 -m  List installed packages that are missing in the directory
 -o  List obsolete packages
 -u  List packages that are present in the directory but not installed
 -s  Sort output
 -q  Don't print old package name (quiet mode) 
END
}

sub splitrpm($)
{
	my ($pkgname) = @_;
	my @fields;
	my ($base, $ver, $rev, $arch, $parts);

	@fields = split(/-/, $pkgname);

	$base = join('-', @fields[0 .. $#fields - 2]);
	$ver = $fields[$#fields - 1];
	$rev = $fields[$#fields];

	# Remove .rpm suffix
	$rev =~ s/\.rpm$//;

	# Parse arch
	if ($rev =~ s/\.(noarch|\(none\)|i\d86|athlon|x86_64|ia64|ppc|ppc64|s390|s390x|m68k|sparc|sparc64)$//)
	{
		$arch = $1;
	}
	else
	{
		$arch = "";
		print STDERR "UNKNOWN ARCH: $pkgname\n";
	}

	if (!($rev =~ s/\.[^.]*\.rpm$//))
	{
		# some distros (notably SuSE) don't use an arch suffix
		$rev =~ s/\.rpm$//;
	}

	$parts = $#fields - 1;

	#DEBUG
	#print "base=$base ver=$ver rev=$rev arch=$arch parts=$parts\n";

	return ($base,$ver,$rev,$arch,$parts);
}

sub ltver($$)
{
	my @x = split(/\./, $_[0]);
	my @y = split(/\./, $_[1]);
	my $parts;

	if ($#x < $#y)
	{
		$parts = $#x;
	}
	else
	{
		$parts = $#y;
	}

	for (my $i = 0; $i <= $parts; $i++)
	{
		my $xi = $x[$i];
		my $yi = $y[$i];

		# both numberic?
		if ($xi =~ /^\d+$/ && $yi =~ /^\d+$/)
		{
			return 1 if ($xi < $yi);
			return 0 if ($xi > $yi);
		}
		else
		{
			return 1 if ($xi lt $yi);
			return 0 if ($xi gt $yi);
		}
	}

	# shorter is lesser
	return 1 if ($#x < $#y);

	# very same version
	return 0;
}

my $opt_delete = 0;
my $opt_quiet = 0;
my $opt_obsolete = 0;
my $opt_missing = 0;
my $opt_uninstalled = 0;
my ($dir) = ".";

foreach my $arg (@ARGV)
{
	if ($arg eq "-d")
	{
		$opt_delete = 1;
	}
	elsif ($arg eq "-q")
	{
		$opt_quiet = 1;
	}
	elsif ($arg eq "-o")
	{
		$opt_obsolete = 1;
	}
	elsif ($arg eq "-m")
	{
		$opt_missing = 1;
	}
	elsif ($arg eq "-u")
	{
		$opt_uninstalled = 1;
	}
	elsif ($arg eq "-s")
	{
		open(NEWOUT, "|sort");
		select NEWOUT;
	}
	elsif ($arg eq "-h" || $arg eq "--help")
	{
		usage;
		exit;
	}
	elsif ($arg =~ /^-./)
	{
		die "unrecognized argument: $arg";
	}
	else
	{
		($dir) = $arg;
	}
}

#
# scan package directory
#
opendir(DIR, $dir);
my @rpms = grep { /.*\.rpm/ } readdir(DIR);
closedir DIR;

#
# match list with installed versions
#
my %installed;
my $pkgfound;
open(PKGS, 'rpm -qa --queryformat "%{NAME}-%{VERSION}-%{RELEASE}.%{ARCH}\n" |');
while (my $pkg = readline(PKGS))
{
	chomp $pkg;
	my ($base, $ver, $rev, $arch, $parts) = splitrpm($pkg);
	my $baseq = quotemeta($base);
	my @newpkgs = grep(/^$baseq-.*\.rpm/, @rpms);
	$pkgfound = 0;
	foreach my $newpkg (@newpkgs)
	{
		my ($newbase, $newver, $newrev, $newarch, $newparts) = splitrpm($newpkg);

		# DEBUG
		#if ($newbase =~ /.*kdelibs.*/)
		#{
		#	print "$base $ver $rev $parts $arch\n";
		#	print "$newbase $newver $newrev $newparts $newarch\n";
		#}
		if ($base eq $newbase && $arch eq $newarch && $parts == $newparts)
		{
			# flag package as installed
			$installed{$newpkg}++;

			$pkgfound = 1;
			if (ltver($ver, $newver) || (($ver eq $newver) && ltver($rev, $newrev)))
			{
				if ($opt_quiet)
				{
					print "$newpkg\n";
				}
				else
				{
					print "$pkg -> $newpkg\n";
				}
			}
			elsif ($opt_obsolete && (ltver($newver, $ver) || (($newver eq $ver) && ltver($newrev, $rev))))
			{
				print "OBSOLETE: $newpkg\n";
				unlink $newpkg if $opt_delete;
			}
		}
	}

	print "MISSING: $pkg\n" unless !$opt_missing || $pkgfound;
}
close(PKGS);

# list uninstalled packages
if ($opt_uninstalled)
{
	foreach my $pkg (@rpms)
	{
		print "UNINSTALLED: $pkg\n" unless $installed{$pkg};
	}
}