#!/usr/bin/perl
# RCS: $Id: rpmlevel,v 1.3 2000/12/15 22:46:49 root Exp $
#-----------------------------------------------------------------------
#	rpmlevel (c)1999-2000 Didimo Emilio Grimaldo Tunon
#-----------------------------------------------------------------------
# AUTHOR: D. Emilio Grimaldo T.		grimaldo@coralys.com
# USAGE: rpmlevel {mode} [options] [database]
# DESCRIPTION:
#	  Other Un*x have the capability of using a command to find
#	out the current patch levels and updates applied to the
#	system. On the Linux variants that use RPM it is possible
#	to do lots of different queries but not the above one.
#	  This capability allows the administrator to check its
#	current upgrades against the OS provider as well as keep
#	track of 3rd party (RPM) packages.
#         RpmLevel does just that. The first time the distribution
#	CD is scanned for 'official' RPMs and a small flat file
#	database is built. Periodically (every night or so) RpmLevel
#	can be invoked to resync this database and detect what has
#	changed.
#	  RpmLevel also allows to perform the following high-level
#	queries:
#		* Non-istalled packages
#		* Upgraded packages
#		* Downgraded packages
#		* Extra packages (not from the original distro)
#   modes:
#	--help	        Help
#	--init          Initialize (from CD listing) and check
#	--report [nude] Which reports are wanted (one or more). If
#                       none specified all (nude) is assumed.
#	--sync          Check system and synchronize DB
#	--regroup WHAT  Used to populate group field using a reference
#	--compare [amrs] Compare two releases of the same distro
#			and list Additions, Mutations, Removals & Same
#   modifiers:
#	--nosync        Can be used at --init to prevent syncing
#	--nosave	Don't write changes to DB (--init, --sync)
#	--append	Append to DB (--init, useful for SuSE)
#	--quiet		Don't notify of what I am about to do
#	--cdpath WHAT	Where the distribution RPMs are located (override)
#
#   If no database is specified 'default' is assumed, which could
#   actually be a symbolic link to the current one.
# Examples:
#	First time, say we just installed Red Hat 6.0
#	    atlantis$ rpmlevel --init redhat60 [--nosync]
#	Then every night (in a cron job)
#	    atlantis$ rpmlevel --sync redhat60
#       Check what has been upgraded with respect to the distro
#	    atlantis$ rpmlevel --report {nude} redhat60
#	Compare Red Hat 6.0 to 6.1
#	    atlantis$ rpmlevel --compare ./redhat60 ./redhat61
#	Regroup suse61 using redhat60
#	    atlantis$ rpmlevel --regroup suse61 redhat60
# NOTE: Does not keep track of removals
# ---------------------------------------------------------------------
# I should really stop writing free stuff and utilities, it does
# not pay the bills! besides I didn't even get one share of Red Hat
# stock...
# ---------------------------------------------------------------------
# ********** I N C L U D E S    **********
#use strict;
use DirHandle;
use Getopt::Long;
# ********* ********************* *********

# ********* CONFIGURATION SECTION *********
my %Cfg = ( 'rpm-dist-dir' => '/mnt/cdrom/RedHat/RPMS',  # see --cdpath
	    'mandrake-cd'  => '/mnt/cdrom/Mandrake/RPMS',
	    'redhat-cd'    => '/mnt/cdrom/RedHat/RPMS',
	    'suse-cd'      => '/cdrom/full-names/i386',
	    'lib-dir'	   => '/usr/local/lib/rpmlevel',
	    'level-dir'	   => '/var/local/rpmlevel');
# ********* ********************* *********
# ********** LOCAL DATA SECTION **********
my $cvsId = '$Revision: 1.3 $';
my $build = 1;

use constant FLAG_ACTION_SET     => 1;
use constant FLAG_ACTION_UPDATE  => 2;
use constant FLAG_NONE           => 0x00;
use constant FLAG_SRC            => 0xfc;
use constant FLAG_SRC_DISTRO     => 0x01;
use constant FLAG_SRC_EXTRA      => 0x02;
use constant FLAG_STA            => 0x03;
use constant FLAG_STA_ORIGINAL   => 0x04;
use constant FLAG_STA_UPGRADED   => 0x08;
use constant FLAG_STA_DOWNGRADED => 0x10;
use constant FLAG_STA_NOTAVAIL   => 0x20;

use constant PKG_UNKNOWN   => 0x00;
use constant PKG_UNCHANGED => 0x01;
use constant PKG_DOWNGRADE => 0x02;
use constant PKG_UPGRADE   => 0x03;
use constant PKG_EXTRA     => 0x04;
use constant PKG_REMOVED   => 0x05;

use constant DB_UPDATE_VER => 1;
my ($optHelp, $optInit, $optReport, $optSync, $optStats, $optIdentify);
my ($optRegroup, $optCompare, $optRT, $modNoSave, $modAppend, $modQuiet);
my ($modNoSync, $modCdPath, $modLines, $version);
my $VersionComparePtr;
# ********* ********************* *********
# <<<<<<<<<<<<<<<< U T I L I T Y   F U N C T I O N S >>>>>>>>>>>>>>
sub splitname {
    my $fqn = shift;
    my $rName = shift;
    my (@attr, $pos);
    
    $$rName{'name'} = '';
    $$rName{'version'} = '';
    $$rName{'release'} = '';
    # Remove all known architecture qualifiers and the extension
    $fqn =~ s/\.noarch\.rpm//;
    $fqn =~ s/\.i386\.rpm//;
    # Split into name-version-release
    $pos = rindex($fqn, '-') + 1;
    $$rName{'release'} = substr($fqn, $pos);
    $fqn = substr($fqn, 0, $pos - 1);
    $pos = rindex($fqn, '-') + 1;
    $$rName{'version'} = substr($fqn, $pos);
    $fqn = substr($fqn, 0, $pos - 1);
    $$rName{'name'} = $fqn;
    return $fqn;
}

# Convert a raw data to something we can handle more easily
sub convert2hash {
    my $raw = shift;
    my %rec;
    my @d = split(/;/, $raw);
    $rec{'name'}    = $d[0];
    $rec{'version'} = $d[1];
    $rec{'release'} = $d[2];
    $rec{'size'}    = $d[3];
    $rec{'time'}    = $d[4];
    $rec{'group'}   = $d[5];
    $rec{'flgsrc'}  = $d[6];
    $rec{'flgsta'}  = $d[7];
    return %rec;
}

# Convert the program representation into a raw format to
# store in the DB file
sub convert2raw {
    my $rep = shift;
    my (%rec, $raw);
    %rec = %$rep;
    $raw = join(';', $rec{'name'}, $rec{'version'}, $rec{'release'},
                     $rec{'size'}, $rec{'time'}, $rec{'group'},
    		     $rec{'flgsrc'}, $rec{'flgsta'});
    return $raw;
}

# Get all the information we need from the RPM file
# whether installed or not
sub getRpmInfo {
    my $name = shift;
    my ($otheropt, $option, $result);

    # We can query for an installed package or from an uninstalled one
    $option = '-q';
    $option .= 'p' if ($name =~ m/\.rpm$/i);

    $otheropt = '--queryformat "%{NAME};%{VERSION};%{RELEASE};%{SIZE};%{INSTALLTIME};%{GROUP};0;0"';
    open(RPM, "rpm $option $otheropt $name 2>&1 |");
    $result = <RPM>;
print $result
    chomp($result);
    close(RPM);
    return "" if ($result =~ m/^package\s+/i);
    
    return $result;
}

# Just get the 'installedtime' information from an RPM file
sub getRpmTime {
    my $name = shift;
    my ($otheropt, $result);
    $otheropt = '--queryformat "%{INSTALLTIME}"';
    open(RPM, "rpm -q $otheropt $name 2>&1 |");
    $result = <RPM>;
    close(RPM);
    chomp($result);
    return 0 if ($result =~ m/^package\s+/i);
    return $result;
}

sub getRpmTimeSize {
    my $name = shift;
    my $rtime = shift;
    my $rsize = shift;
    my ($otheropt, $result);
    $otheropt = '--queryformat "%{INSTALLTIME};%{SIZE}"';
    open(RPM, "rpm -q $otheropt $name 2>&1 |");
    $result = <RPM>;
    close(RPM);
    chomp($result);
    $$rtime = 0; $$rsize = 0;  # Defaults if it goes wrong
    if (!($result =~ m/^package\s+/i)) {
	($$rtime, $$rsize) = split(/;/, $result, 2);
    }
}

sub versionNormalize {
    my $overs1 = shift;
    my $overs2 = shift;
    my ($i, @v1, @v2, $rsmall, $rbig, $n1, $n2, $isfirst);
    @v1 = split(/\./, $$overs1);
    @v2 = split(/\./, $$overs2);
    if ($#v1 > $#v2) {
        $rsmall = \@v2;
	$rbig   = \@v1;
	$isfirst= 0;
    } else {
        $rsmall = \@v1;
	$rbig   = \@v2;
	$isfirst= 1;
    }
    # Make them have the same amount of branches
    while ($#$rsmall < $#$rbig) {
        push(@$rsmall, '.0');
    }
    # Make sure each branch has the same length
    foreach $i (0 .. $#$rsmall) {
        my $l1 = length $$rsmall[$i];
        my $l2 = length $$rbig[$i];
	my $diff;
     	if ($l1 < $l2) {
	    $$rsmall[$i] = ' ' x ($l2 - $l1) . $$rsmall[$i];
	} else {
	    $$rbig[$i] = ' ' x ($l1 - $l2) . $$rbig[$i];
	}
    }
    # Now both must have the same length!
    $n1 = join('.', @$rsmall);
    $n2 = join('.', @$rbig);
    if (!$isfirst) {
        $i = $n1; $n1 = $n2; $n2 = $i;
    }
#    print "$$overs1 --> $n1\n$$overs2 --> $n2\n";
    $$overs1 = $n1;
    $$overs2 = $n2;
}

# ======================================================================
# Just checks to see if both start with regular digit version numbers
# If they do, this means we should probably do a digit compare on it
# We are going to make single digit versions into string compares
# 
# Returns -1 if this is purely a string
# Returns 0 if this starts with a digit version
# Return 1 if this is all digits

sub areDigitVersions {
    my $num1 = shift;
    my $num2 = shift;

    # I am going to say that if a num starts with a decimal number
    # then this should be used as a starting point
    my $retValue = -1;
    if (($num1 =~ /^\d+[\.]\d+/) && 
        ($num2 =~ /^\d+[\.]\d+/)) {
      $retValue = 0;
    }

    my @tmp = split(/\./, $num1);
 
    # ===============================
    # Check to see if all values
    # are digits
    # If not then return 0;

    foreach (@tmp) {
        if (/^\d+(.*)/) {
            if ($1 ne "") {
		return $retValue;
            }
        } else {
            return $retValue;
        }
    }

    @tmp = split(/\./, $num2);
    foreach (@tmp) {
        if (/^\d+(.*)/) {
          if ($1 ne "") {
	    return $retValue;
          }
        } else {
            return $retValue;
        }
    }
    # if we get here then all are digits
    return 1;
}

# versionCompare
#	A simple string comparison is not good enough, for example
#	with string compare 1.0.8-8 -> 1.0.53-1 is seen as a
#	downgrade because '.8' gt '.53'. We must take care all
#	branches have the same length.
#       versionCompare($v1, $v2) checks the transition v1 -> v2
# Returns:
#	-1 Downgrade
#	 0 No change
#	+1 Upgrade
sub versionCompare {
    my $v1 = shift;
    my $v2 = shift;
    my $rule = shift;
    my (%hv1, %hv2);

    if ($v1 eq 'ident' || $v2 eq 'ident') {
        return "DEGT 1.2";
    }

    $$rule = 0;
    if ($v1 eq $v2) { return 0; } 			   # Rule 0
    &splitname("dummy-$v1", \%hv1);
    &splitname("dummy-$v2", \%hv2);
    &versionNormalize(\$hv1{'version'}, \$hv2{'version'});
    $$rule++;
    if ($hv1{'version'} gt $hv2{'version'}) { return -1; } # Rule 01
    $$rule++;
    if ($hv1{'version'} lt $hv2{'version'}) { return +1; } # Rule 02
    # The battle of releases
    $$rule = 50;
    if ($hv1{'release'} gt $hv2{'release'}) { return -1; } # Rule 50
    $$rule = 51;
    return +1;						   # Rule 51
}

sub newVersionCompare {
  my $v1 = shift;
  my $v2 = shift;
  my $rule = shift;
  my (%hv1, %hv2);
  
    if ($v1 eq 'ident' || $v2 eq 'ident') {
        return "AG 0.9";
    }

  $$rule = 0;
  if ($v1 eq $v2) { return 0; } 			   # Rule 0
  &splitname("dummy-$v1", \%hv1);
  &splitname("dummy-$v2", \%hv2);
  my $retValue = areDigitVersions($hv1{version}, $hv2{version});
  if ($retValue >= 0) {
    my $version1 = $hv1{version};
    my $version2 = $hv2{version};
    my $rest1 = 0;
    my $rest2 = 0;
    my $found1 = 0;
    my $found2 = 0;
    my $found3 = 0;
    my $found4 = 0;
    if (!$retValue) {
      if ((($found1,$found2) = $version1 =~ /^(\d+[\.]\d+)(.*)/) && 
	  (($found3, $found4) = $version2 =~ /^(\d+[\.]\d+)(.*)/)) {
	$version1 = $found1;
	$version2 = $found3;
	$rest1 = $found2;	# non-digit parts of the version
	$rest2 = $found4;
      }
    }
    # ===========================================
    # we have well behaved version numbers
    # So the case of these version number is:
    # 3.3.1 < 3.3.1.1
    # 3.3.3.3.3.3 < 3.4
    #

    my @tmp1 = split(/\./, $version1);
    my @tmp2 = split(/\./, $version2);
    my $smallerCount = 0;

    # ==============================================
    # We want to use the smaller count of digits
    # when comparing the values.
    # if they are equal then just use the tmp2 count
    # 
    
    if ($#tmp1 < $#tmp2) {
      $smallerCount = $#tmp1
    } else { 
      $smallerCount = $#tmp2;
    }
#    print "Got $smallerCount for @tmp1 and @tmp2\n";
    my $i = 0;
    for ($i = 0; $i <= $smallerCount; $i++) {
      if ($tmp1[$i] > $tmp2[$i]) { $$rule = 3; return -1; } # Rule 03
      if ($tmp1[$i] < $tmp2[$i]) { $$rule = 4; return +1; } # Rule 04
    }
    # =================================================================
    # if we got here then it could mean that the counts are different
    # if they are then the longer count wins
    # of course if the counts are the same, then check the release
    #

    if ($#tmp1 > $#tmp2) {
      $$rule = 5;
      return -1; # Downgrade Rule 05
    } elsif ($#tmp1 < $#tmp2) {
      $$rule = 6;
      return +1; # Upgrade   Rule 06
    }

    # ========================================
    # This means that the counts are the same
    # Check the $rest variables to see if they are equal
    if ($rest1 && !$rest2) {
      # Assume that rest1 is not as good
      $$rule = 7;
      return +1; # Upgrade	Rule 07
    } 
    if (!$rest1 && $rest2) {
      # Assume that rest1 is better
      $$rule = 8;
      return -1; # Downgrade (+2?) Rule 08
    } 
    if ($rest1 && $rest2) {
      $$rule = 9;
      if ($rest1 gt $rest2) { return -1; } # Rule 09
      if ($rest1 lt $rest2) { return +1; } # Rule 09
    }
    
    # Wow, everything is equal now check releases
    
    # The battle of releases
    if (areDigitVersions($hv1{release}, $hv2{release})) {
      $$rule = 52;
      if ($hv1{release} > $hv2{release}) { return -1; } # Rule 52
    } else {
      $$rule = 50;
      if ($hv1{'release'} gt $hv2{'release'}) { return -1; } # Rule 50
    }
  } else {
    # Do the normal version compare using string compares
    &versionNormalize(\$hv1{'version'}, \$hv2{'version'});
      $$rule = 1;
    if ($hv1{'version'} gt $hv2{'version'}) { return -1; } # Rule 01
      $$rule = 2;
    if ($hv1{'version'} lt $hv2{'version'}) { return +1; } # Rule 02
    # The battle of releases
      $$rule = 50;
     if ($hv1{'release'} gt $hv2{'release'}) { return -1; } # Rule 50
  }
      $$rule = 51;
    return +1; # Rule 51
}

# notify
#	  Show a short message taking into account the --quiet option
sub notify {
    my $msg = shift;

    print "$msg" if !$modQuiet;
}

# getType
#	  Find out whether it hasn't changed, or whether it is an
#	upgrade/downgrade/extra. Update the record if necessary.
sub getType {
    my $rCache = shift;
    my $id     = shift;
    my $action = shift;
    my ($key, %h, $type, $msg);
    my ($ver_inst, $ver_db, $rel_inst, $rel_db);
    $key = &splitname($id, \%h);
    $ver_inst = $h{'version'};
    $rel_inst = $h{'release'};

    if (exists($$rCache{$key})) {
        my $whatisit;
	my %insversion;		# The one we got from the RPM query
	%insversion = %h;	# Before we lose it
	%h = &convert2hash($$rCache{$key});
	if ($action == FLAG_ACTION_SET) {
	    $h{'flgsrc'} = FLAG_SRC_DISTRO;
	    $h{'flgsta'} = FLAG_STA_NOTAVAIL;
	}
	$ver_db = $h{'version'};
    	$rel_db = $h{'release'};
	$msg = "$key $ver_db-$rel_db -> $ver_inst-$rel_inst";
	my $rule;
	$whatisit = &$VersionComparePtr("$ver_db-$rel_db", "$ver_inst-$rel_inst", \$rule);
	if ($whatisit == 0) {	# There was no change
	    # If we are here the package _is_ installed, so take care
	    # that we don't revert an upgrade/downgrade status and
	    # that a notavail becomes original. At this point remember
	    # %h has the cached version, while %insversion has the
	    # one we got out of the real rpm query!
	    if ($action == FLAG_ACTION_SET) {
		$h{'flgsta'} = FLAG_STA_ORIGINAL;
	    } else {	# FLAG_ACTION_UPDATE
		if ($h{'flgsta'} == FLAG_STA_NOTAVAIL) {
		    $h{'flgsta'} = FLAG_STA_ORIGINAL;
		}
	    }
	    $h{'flgsta'} = FLAG_STA_ORIGINAL unless ($action == FLAG_ACTION_UPDATE);
	    $type = PKG_UNCHANGED;
	} elsif ($whatisit > 0) {
	    $h{'flgsta'} = FLAG_STA_UPGRADED;
	    # Find out when it was done
	    &getRpmTimeSize($key, \$h{'time'}, \$h{'size'});
	    &dbUpdate(DB_UPDATE_VER, \%h, $ver_inst, $rel_inst);
	    print "\t$msg (upgrade)\n";
	    $type = PKG_UPGRADE;
	} else {
	    $h{'flgsta'} = FLAG_STA_DOWNGRADED;
	    # Find out when it was done
	    &getRpmTimeSize($key, \$h{'time'}, \$h{'size'});
	    &dbUpdate(DB_UPDATE_VER, \%h, $ver_inst, $rel_inst);
	    print "\t$msg (downgrade)\n";
	    $type = PKG_DOWNGRADE;
	}
	# Write the record into the cache
	$$rCache{$key} = &convert2raw(\%h);
    } else {
	&dbInsert($rCache, $key, FLAG_SRC_EXTRA, FLAG_STA_ORIGINAL);
	print "\t$key $ver_inst-$rel_inst (extra)\n";
 	$type = PKG_EXTRA;
    }
    return $type;
}
    
sub dbLoad {
    my $dbfile = shift;
    my $rDbCache = shift;
    my ($key, $rest);

    die "$dbfile: $!\n" if (ref($rDbCache) ne 'HASH');
    open(DBREFERENCE, "< $dbfile") || die "$dbfile: $!\n";
    while (<DBREFERENCE>) {
        chomp;
	($key, $rest) = split(/;/, $_, 2);
	$$rDbCache{$key} = $_;
    }
    close(DBREFERENCE);
}

sub dbUpdate {
    my $fld = shift;  # DB_UPDATE*
    my $rData = shift; # \$cache{'name'} or \%cache_entry
    my @pars = @_;
    my %h;
    
    if (ref($rData) ne 'SCALAR' && ref($rData) ne 'HASH') {
        die "dbUpdate() par2 is wrong type\n";
    }
    if (ref($rData) eq 'SCALAR') { %h = &convert2hash($$rData); }
    else { %h = %$rData; }
    # Which field(s) are we updating?
    if ($fld == DB_UPDATE_VER) {
        $h{'version'} = $pars[0];
	$h{'release'} = $pars[1];
    } else { die "dbUpdate() unsupported field\n"; }
	
    # Write the record into the cache
    if (ref($rData) eq 'SCALAR') { $$rData = &convert2raw(\%h); }
    else { %$rData = %h; }
}

sub dbInsert {
    my $rCache = shift;
    my $name = shift;
    my $src  = shift;
    my $sta  = shift;
    my (%h, $raw);
    $raw = &getRpmInfo($name);
    %h = &convert2hash($raw);
    $h{'flgsrc'} = $src;
    $h{'flgsta'} = $sta;
    $$rCache{$name} = &convert2raw(\%h);
    return "$name $h{'version'}-$h{'release'}";
}

sub dbCommit {
    my $dbname = shift;
    my $rPkgs  = shift;

    if ($modNoSave) {
        &notify("Not saving to the db file (per request)\n");
	return;
    }
    &notify("Writing gathered data/changes to db file\n");
    if ($optInit && $modAppend) {
	open(LEVELDB, ">> $dbname") || die "$dbname: $!\n";
    } else {
	open(LEVELDB, "> $dbname") || die "$dbname: $!\n";
    }
    for (sort keys %$rPkgs) {
        print LEVELDB "$$rPkgs{$_}\n";
    }
    close(LEVELDB);
}

# Get all the packages from the original distribution
sub getFromCD {
    my $rAttr = shift;
    my ($name, %attr, $dbrecord);
    my $d = new DirHandle $Cfg{'rpm-dist-dir'};
    if (!defined($d)) { 
        die "getFromCD: perhaps CDROM is not mounted - $!\n"; 
    }
    while (defined($_ = $d->read)) {
        next if (/^\.{1,2}/);
        next if (!($_ =~ m/\.rpm$/i));
	chomp;
	# Get RawInfo
	$name = &splitname($_, \%attr);
	$dbrecord = &getRpmInfo("$Cfg{'rpm-dist-dir'}/$_");
	if (ref($rAttr) eq 'HASH') {
	    %attr = &convert2hash($dbrecord);
	    $attr{'flgsrc'} = FLAG_SRC_DISTRO;
	    $attr{'flgsta'} = FLAG_STA_NOTAVAIL;
	    $$rAttr{$name} = &convert2raw(\%attr);
	}
    }
    undef $d;
}

sub showReport {
    my $dbfile   = shift;
    my $pkgstate = shift;
    my $r = shift;
    my (%h, $pkgversion, $footer);
    my $i;

    format STDOUT_TOP = 
                             Page @<<<<
			     $%
Distribution: @<<<<<<<<<<<<<<        Category: @<<<<<<<<<<<<<<<<<<<<<
              $dbfile		               $pkgstate
Package name           Version       Size        Date
--------------------   ------------- ----------- ------------------------
.
    format STDOUT =
@<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<@>>>>>>>>>>>>>> @<<<<<<<<<<<<<<<<<<<<<<
$h{'name'}             $pkgversion   $h{'size'}   $h{'time'}
.
    $= = 20;
    $= = $modLines if defined($modLines);
    $- = 0;
    # $^L is causing problems when used as a footer...
    $footer = '_' x 75 . "\n\tRpmLevel v$version-$build\n\t" .
          "Copyright (c)1999 Didimo Grimaldo\n\t" .
	  "http://www.coralys.com/\n\n";
    $^L = $footer;

    $pkgstate = "Not Installed" if ($pkgstate eq 'n');
    $pkgstate = "Upgraded" if ($pkgstate eq 'u');
    $pkgstate = "Downgraded" if ($pkgstate eq 'd');
    $pkgstate = "Third Party" if ($pkgstate eq 'e');
    
    foreach $i (0 .. $#$r) {
	%h = &convert2hash($$r[$i]);
	$pkgversion = "$h{'version'}-$h{'release'}";
	$h{'time'} = localtime($h{'time'}) if ($h{'time'} ne '(none)');
	write();
    }
    if ($-) { print $footer; }
}

# <<<<<<<<<<<<<<<< T O P   L E V E L   H A N D L E R S >>>>>>>>>>>>
sub Help {
    my $onerror = shift;
    print "\n\tRpmLevel version $version-$build\n";
    print "\tCopyright (c)1999 Didimo Emilio Grimaldo Tunon\n";
    print "\t-----------------------------------------------\n";
    print "Usage: rpmlevel { mode } [modifier] DB\n";
    print "Modes:\n";
    print "\t-h|--help      This help\n";
    print "\t-i|--init      Create and initialize DB for new distr.\n";
    print "\t--sync         Resync DB with current installation\n";
    print "\t--stats        Show per-group statistics\n";
    print "\t-r|--report [] Report options for spe\n";
    print "\t\tn   Packages that were Not Installed\n";
    print "\t\tu   Packages that were Upgraded\n";
    print "\t\td   Packages that were Downgraded\n";
    print "\t\te   Extra packages (Third Party)\n";
    print "\t--identify     Check which system this is\n";
    print "\t--compare {AMRS} Compare two releases of a distribution and,\n";
    print "\t\ta   Additions\n";
    print "\t\tm   Mutations (version/release)\n";
    print "\t\tr   Removals (discontinued packages)\n";
    print "\t\ts   Sames (identical packages)\n";
    print "Modifiers:\n";
    print "\t--nosync       Do not synchronize during --init\n";
    print "\t--nosave       Don't save during --init/--sync\n";
    print "\t--append       Append to existing DB during --init\n";
    print "\t--quiet        Don't show status/notification messages\n";
    print "\t--cdpath PATH  Alternate path where to find RPMs for --init\n";
    print "Examples:\n";
    print "\t\trpmlevel --init redhat60 \[--nosync\]\n";
    print "\t\trpmlevel --sync redhat60\n";
    print "\t\trpmlevel --report [nude] redhat60\n";
    print "\t\trpmlevel --stats redhat60\n";
    print "Exiting with status $onerror\n" if $onerror;
    exit($onerror);
}

# Create and initialize the RPMLEVEL database. It will report on
# any package that has been up/downgraded with respect to the
# original distribution. The same applies for those that were
# not part of the original distro (3rd party).
sub Init {
    my $dbname = shift;
    my %pkgs;
    my ($i, $type, @names);

    # Get original distribution contents
    &notify("Getting information from distribution CD\n");
    &Identify(0);	# Find out where CDROM RPMs are mounted
    &getFromCD(\%pkgs);

    # See what has been installed and immediately determine
    # whether it is the same, an upgrade, downgrade or an
    # extra package. 
    if (!defined($modNoSync)) {
	&notify("Getting information from installed packages\n");
	open(RPM, "rpm -qa |") || die "Cannot query rpm $!\n";
	while (<RPM>) {
	    chomp;
	    push(@names, $_);
	}
	close(RPM);

	foreach $i (0 .. $#names) {
	    $type = &getType(\%pkgs, $names[$i], FLAG_ACTION_SET);
	}
    } else { 
        &notify("Auto synchronization disabled (by you)\n");
    }
    # Get information of each of the installed packages. If it is
    # known to be part of the distribution then only fetch the
    # install-time, otherwise get all the info and mark it as extra.
    &dbCommit($dbname, \%pkgs);
    exit(0);
}

sub Synchronize {
    my $dbfile = shift;
    my %dbcache;
    my %dbrecord;
    my ($key, $v, $type, $changed, @names, $i);
    # Read the current db into memory
    &notify("Loading DB...\n");
    open(LEVELDB, "< $dbfile") || die "$dbfile: $!\n";
    while (<LEVELDB>) {
        chomp;
	($key, $v) = split(/;/, $_, 2);
	$dbcache{$key} = $_;
    }
    close(LEVELDB);

    # Check for all currently installed packages
    # - Anything extra?
    # - Any new upgrades or downgrades?
    &notify("Checking currently installed packages\n");
    $changed = 0;
    open(RPM, "rpm -qa |") || die "Cannot query rpm $!\n";
    while (<RPM>) {
	chomp;
	push(@names, $_);
    }
    close(RPM);

    foreach $i (0 .. $#names) {
	$type = &getType(\%dbcache, $names[$i], FLAG_ACTION_UPDATE);
	$changed = 1 if ($type != PKG_UNCHANGED);
    }

    # Save into db
    if ($changed) {
	&dbCommit($dbfile, \%dbcache);
    } else {
        &notify("No further action needed (no changes)\n");
    }
    exit(0);
}

sub Status {
    my $dbfile = shift;
    my $distro = shift;
    my $report = shift;
    my $repNot = 0;
    my $repUpgrade = 0;
    my $repDowngrade = 0;
    my $repExtra = 0;
    my (%h, @n, @u, @d, @e);
    
    if ($report eq '') { $report = 'nude'; }
    $repNot = 1 if (index($report, 'n') > -1);
    $repUpgrade = 1 if (index($report, 'u') > -1);
    $repDowngrade = 1 if (index($report, 'd') > -1);
    $repExtra = 1 if (index($report, 'e') > -1);

    # Spread the various categories
    open(LEVELDB, "< $dbfile") || die "$dbfile: $!\n";
    while(<LEVELDB>) {
	chomp;
	%h = &convert2hash($_);
	if ($h{'flgsrc'} == FLAG_SRC_EXTRA) {
	    # Has priority otherwise it passes as 'original'
	    push(@e, $_);
	} elsif ($h{'flgsta'} == FLAG_STA_NOTAVAIL) {
	    push(@n, $_);
	} elsif ($h{'flgsta'} == FLAG_STA_UPGRADED) {
	    push(@u, $_);
	} elsif ($h{'flgsta'} == FLAG_STA_DOWNGRADED) {
	    push(@d, $_);
	}
    }
    close(LEVELDB);

    # For each category print a report (if not empty)
    &showReport($distro, 'n', \@n) if ($#n > -1 && $repNot);
    &showReport($distro, 'u', \@u) if ($#u > -1 && $repUpgrade);
    &showReport($distro, 'd', \@d) if ($#d > -1 && $repDowngrade);
    &showReport($distro, 'e', \@e) if ($#e > -1 && $repExtra);
    
    exit(0);
}

sub Statistics {
    my $dbfile = shift;
    my (%h, %groups, %installed, %sitting);
    
    open(LEVELDB, "< $dbfile") || die "$dbfile: $!\n";
    while(<LEVELDB>) {
	chomp;
	%h = &convert2hash($_);
	if ($h{'flgsta'} != FLAG_STA_NOTAVAIL) {
	    if (exists($groups{$h{'group'}})) {
	        $groups{$h{'group'}} += $h{'size'};
		$installed{$h{'group'}}++;
	    } else {
	        $groups{$h{'group'}} = $h{'size'};
		$installed{$h{'group'}} = 1;
	    }
	} else {
	    $sitting{$h{'group'}} = 1;
	}
    }
    close(LEVELDB);

    printf("%38s %9s %3s  %3s\n", "Group", "Size", "In", "Out");
    for (sort keys %groups) {
        printf("%38s %9s %3s  %3s\n", $_, $groups{$_},
	       $installed{$_}, $sitting{$_});
    }
    exit(0);
}

sub ReGroup {
    my $dbfile = shift;
    my $candidate = shift;
    my (%reference, %unsorted, %myref, %mycand, %st, $name);

    open(DBREFERENCE, "< $dbfile") || die "$dbfile: $!\n";
    $st{'refcnt'} = 0;
    $st{'unscnt'} = 0;
    $st{'matched'} = 0;
    # Read the reference db, this one has groups for every RPM
    &notify("Reading reference database (grouped)...");
    while (<DBREFERENCE>) {
        chomp;
	%myref = &convert2hash($_);
	$reference{$myref{'name'}} = $_;
	$st{'refcnt'}++;
    }
    close(DBREFERENCE);
    &notify("done\n");

    # Read the candidate db, this one is missing the groups
    &notify("Reading candidate database (ungrouped)...");
    open(DBCANDIDATE, "< $candidate") || die "$candidate: $!\n";
    while (<DBCANDIDATE>) {
        chomp;
	%mycand = &convert2hash($_);
	$name = $mycand{'name'};
	$unsorted{$name} = $_;
	$st{'unscnt'}++;
	if (exists($reference{$name})) {
	    %myref = &convert2hash($reference{$name});
	    $mycand{'group'} = $myref{'group'};
	    $unsorted{$name} = &convert2raw(\%mycand); 
	    $st{'matched'}++;
	}
    }
    close(DBCANDIDATE);
    &notify("done\n");

    &notify("Writing new database with fixed records...");
    open(DBCANDIDATE, "> $candidate.new") || die "$candidate.new: $!\n";
    for (sort keys %unsorted) {
        print DBCANDIDATE "$unsorted{$_}\n";
    }
    close(DBCANDIDATE);
    &notify("done\n");
    
    print "Regroup Results\n";
    print "\tTotal records on reference db: $st{'refcnt'}\n";
    print "\tTotal records on candidate db: $st{'unscnt'}\n";
    print "\tTotal fixed candidate records: $st{'matched'}\n";
    print "\tNew file saved in $candidate.new (please edit & store)\n";
}

sub Identify {
    my $interactive = shift;
    my $id;
    my $ecode = 3;	# Not a Red Hat system
    my $idfile= '/etc/mandrake-release';

    if (! -e $idfile) { 
        $idfile = '/etc/redhat-release';
	if (! -e $idfile) {
	    $idfile = '/etc/SuSE-release';
	    if (! -e $idfile) {
		print "unkown\n"; exit(3);
	    } else { $Cfg{'rpm-dist-dir'} = $Cfg{'suse-cd'}; }
	} else { $Cfg{'rpm-dist-dir'} = $Cfg{'redhat-cd'}; }
    } else { $Cfg{'rpm-dist-dir'} = $Cfg{'mandrake-cd'}; }

    if (!open(RELID, "< $idfile")) { 
        print "unknown\n"; exit(3); 
    }
    while (<RELID>) {
	chomp;
	# I'm told SuSe has /etc/SuSE-release
	# SuSE Linux 6.1 (i386)
	# VERSION = 6.1
	if (/Linux\s+Mandrake\s+release\s+([\d.]+)/i ||
	    /Mandrake\s+Linux\s+release\s+([\d.]+)/i) {
	    # Check Mandrake first because they also keep an
	    # /etc/redhat-release as a symbolic link to their
	    # /etc/mandrake-release.
	    my $major = $1;
	    $major =~ s/\.//g;
	    $id = "mandrake$major";
	    $ecode = 0;   # Found
	    last;
	}
	elsif (/Red\s+Hat\s+Linux\s+release\s+([\d.]+)/i) {
	    my $major = $1;
	    $major =~ s/\.//g;
	    $id = "redhat$major";
	    $ecode = 0;   # Found
	    last;
	}
	elsif (/SuSE\s+Linux\s+([\d.]+)/i) {
	    my $major = $1;
	    $major =~ s/\.//g;
	    $id = "suse$major";
	    $ecode = 0;   # Found
	    last;
	}
    }
    close(RELID);
    # This last bit allows one to define a different location for the
    # 'virgin' RPMs, could be the path on the CDROM or an NFS path
    # or wherever the 'virgin' distribution is found.
    if (defined($modCdPath)) { 
        $Cfg{'rpm-dist-dir'} = $modCdPath; 
    }
    if ($interactive == 1) {
	print "$id\n" if ($ecode == 0);
	exit($ecode);
    }
    return($ecode);
}

sub RegressionTest {
    my ($rtfile, $total_tests, $total_failed);
    # Other types of regression tests are added here, a
    # mnemonic is associated with a bare filename so,
    #      --rt vc  -> use versioncmp.rt
    # We search for the RT file first in ./misc/ and then in
    # the lib-dir configuration.
    if ($optRT eq 'vc') { $rtfile = 'versioncmp.rt'; }
    else {
        &notify("Unknown regression test $optRT\n");
	exit(10);
    }

    # If we are doing development let's use the one in the
    # current work area as opposed to the one that is installed.
    if (-f "misc/$rtfile") { $rtfile = "misc/$rtfile"; }
    elsif (-f "$Cfg{'lib-dir'}/$rtfile") {
        $rtfile = "$Cfg{'lib-dir'}/$rtfile";
    } else {
        print "Cannot find regression test file\n";
	exit(11);
    }

    my $engine = &$VersionComparePtr('ident','ident');
    print "Title: Version comparison engine $engine\n";

    # Perform the regression test
    $total_tests = $total_failed = 0;
    open(RTFILE, "< $rtfile") || die "$rtfile: $!\n";
    while (<RTFILE>) {
        chomp;
	print "Rule $'\n" if ($_ =~ m/^\s*#\s*%Rule/i);
	next if ($_ =~ m/^\s*#/);
	next if ($_ =~ m/^\s*$/);
	if ($optRT eq 'vc') {
	    # Test version compare algorithm
	    my (@data, $result, $rule);
	    @data = split(/\s+/, $_, 3);
	    $result = &$VersionComparePtr($data[0], $data[1], \$rule);
	    printf "\t%15s -> %15s %3s : %+1d R%s ", $data[0], $data[1],
	    				  	    $data[2], $result,
						    $rule;
	    $total_tests++;
	    if ($result == $data[2]) { print "OK\n"; }
	    else { $total_failed++; print "FAILED\n"; }
	}
    }
    close(RTFILE);
    my $per_ok = ($total_tests - $total_failed) / $total_tests * 100;
    $per_ok = int($per_ok * 100) / 100;
    print "Totals: $total_tests cases, $total_failed failed ($per_ok\%)\n";
    exit(0);
}

sub compareCache {
    my $reverse = shift;
    my $key = shift;
    my $rRes = shift;
    my $rC1 = shift;
    my $rC2 = shift;
    my $rC3 = shift;
    my ($ver1, $ver2, %d1, %d2);

    %d2 = &convert2hash($$rC2{$key});
    $ver2 = "$d2{'version'}-$d2{'release'}";
    if (!exists($$rC1{$key})) {
        if ($reverse) {
	    $$rRes{'discontinued'}++;
	    $ver1 = $ver2; $ver2 = 'none';
	} else {
	    $$rRes{'added'}++; # Something new (most of the cases)
	    $ver1 = 'none';
	}
	$$rC3{$key} = join('|', $key, $ver1, $ver2);
	delete $$rC2{$key};
    } else {
	%d1 = &convert2hash($$rC1{$key});
	$ver1 = "$d1{'version'}-$d1{'release'}";
	if ($ver1 ne $ver2) {
	    # Different version/release so indicate that
	    $$rRes{'mutations'}++;
	} else {
	    $$rRes{'unchanged'}++;
	}
	if ($reverse) {
	    my $tmp;
	    $tmp = $ver1;
	    $ver1 = $ver2;
	    $ver2 = $tmp;
	}
#	if ($ver1 ne $ver2) {
	    $$rC3{$key} = join('|', $key, $ver1, $ver2);
#	}
	delete $$rC1{$key};
	delete $$rC2{$key};
    }
}

sub CompareDistribution {
    my $dist1 = shift;
    my $dist2 = shift;
    my ($key, $ver1, $ver2, $comment, $rest, %dbdist1, %dbdist2);
    my (%db, %results, %rstat, %comments);
    
    format COMPARE_TOP =
		Distribution Comparison (Page @||||)
		                         $%
Showing Additions (@|||) Discontinued (@|||) Mutations (@|||) Unchanged (@|||)
                   $rstat{'a'}         $rstat{'r'}      $rstat{'m'}      $rstat{'s'}
Package name              @>>>>>>>>>>>>>  @>>>>>>>>>>>>  Comments
                           $dist1           $dist2
------------------------- -------------- -------------- ----------------------
.
    format COMPARE =
@<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>  @>>>>>>>>>>>>  @<<<<<<<<<<<<<<<<<<<<<<<
$key                       $ver1            $ver2           $comment
.

    $^L = "\n" . '~' x 70 . "\n";
    $~ = "COMPARE";
    $optCompare =~ tr/[a-z]/[A-Z]/;
    &dbLoad($dist1, \%dbdist1);
    &dbLoad($dist2, \%dbdist2);
    open(DBREFERENCE, "< ../databases/rpmnotes") || die "/var/local/rpmlevel/rpmnotes: $!\n";
    while (<DBREFERENCE>) {
        chomp;
	($key, $rest) = split(":",$_,2);
	$comments{$key} = $rest;
    }
    close(DBREFERENCE);
# Test print the comments
#    for $key ( keys %comments ) {
#      print "$key : $comments{$key} \n"; }
    $dist1 = substr($dist1, rindex($dist1, '/') + 1);
    $dist2 = substr($dist2, rindex($dist2, '/') + 1);
    $results{'unchanged'} = 0;
    $results{'added'} = 0;
    $results{'discontinued'} = 0;
    $results{'mutations'} = 0;
    $rstat{'a'} = (index($optCompare,'A') == -1 ? 'no' : 'yes');
    $rstat{'r'} = (index($optCompare,'R') == -1 ? 'no' : 'yes');
    $rstat{'m'} = (index($optCompare,'M') == -1 ? 'no' : 'yes');
    $rstat{'s'} = (index($optCompare,'S') == -1 ? 'no' : 'yes');
    # First run through the latest distro, presumably it has
    # more packages than the previous one :)
    for (keys %dbdist2) {   # Usually the newest has more stuff
	&compareCache(0, $_, \%results, \%dbdist1, \%dbdist2, \%db);
    }
    # Now do this in case the first is actually bigger
    for (keys %dbdist1) {
	&compareCache(1, $_, \%results, \%dbdist2, \%dbdist1, \%db);
    }
    # It's time to vomit!
    $= = 22;
    $= = $modLines if defined($modLines);
    for (sort keys %db) {
        # Only mutations are supposed to appear here
	($key, $ver1, $ver2) = split(/\|/, $db{$_});
        $comment = $comments{$key};
	if ((index($optCompare,'A') > -1 && $ver1 eq 'none') ||
	    (index($optCompare,'R') > -1 && $ver2 eq 'none') ||
	    ((index($optCompare,'M') > -1 && ($ver2 ne 'none' && $ver1 ne 'none')  && ($ver2 ne $ver1)) ||
	    (index($optCompare,'S') > -1 && $ver2 eq $ver1))
	   ) 
	    {
              if (index($optCompare,'S') > -1 && $ver2 eq $ver1) {
		$comment = "";
	    }
	    write();
	}
    }
    print "\nFrom $dist1 To $dist2" .
          "\n\tMutations: $results{'mutations'}" .
          "\n\tAdditions: $results{'added'}" .
          "\n\tRemovals : $results{'discontinued'}" .
	  "\n\tUnchanged: $results{'unchanged'}\n";
    exit(0);
}

# *****************************************************************
#               M   A   I   N
# *****************************************************************
#my $vc = &versionCompare($ARGV[0], $ARGV[1]);
#print "$ARGV[0] -> $ARGV[1] : $vc\n"; exit;
my $dbfile;
my $distro;
$cvsId   =~ m/Revision:\s+(\d+\.\d+\.*\d*\.*\d*)/;
$version = $1;
# For now let's have the possibility of multiple
# version compare algorithms. There is no sure way of doing
# it because nobody seems to respect standards and sadly
# same goes for enforcing it.
#$VersionComparePtr = \&versionCompare; # Used in 1.2-1
$VersionComparePtr = \&newVersionCompare; # Used in 1.3-1

&GetOptions('h|help'	=> \$optHelp,
	    'i|init'	=> \$optInit,
	    'r|report:s'=> \$optReport,
	    'sync'	=> \$optSync,
	    'identify'	=> \$optIdentify,
	    'stats'	=> \$optStats,
	    'compare=s'	=> \$optCompare,
	    'regroup=s'	=> \$optRegroup,
	    'rt=s'	=> \$optRT,	  # Regression test
	    'append'	=> \$modAppend,	  # Only with --init
	    'nosave'	=> \$modNoSave,	  # Only with --init or --sync
	    'lines=i'	=> \$modLines,	  # Only with --report --compare
	    'cdpath=s'	=> \$modCdPath,	  # Only with --init
	    'nosync'	=> \$modNoSync);  # Only with --init
&Help(0) if $optHelp;
&RegressionTest if defined($optRT);
if ($optInit || $optReport || $optSync || $optStats || $optRegroup) {
    &Help(1) if $#ARGV > 0;
    $dbfile = 'default';
    $dbfile = $ARGV[0] unless $#ARGV == -1;
    $distro = $dbfile;
    $dbfile = "$Cfg{'level-dir'}/$dbfile.db";
} elsif (defined($optCompare)) {
    &Help(1) if $#ARGV != 1;
    &CompareDistribution($ARGV[0], $ARGV[1]);
}
&Statistics($dbfile) if $optStats; 
&Identify(1) if $optIdentify;
&Init($dbfile) if $optInit;
&Status($dbfile, $distro, $optReport) if $optReport;
&Synchronize($dbfile) if $optSync;
&ReGroup($dbfile, $optRegroup) if $optRegroup;
&Help(2);
# *****************************************************************
#               H  I  S  T  O  R  Y
# *****************************************************************
# 08.nov.1999 DEGT Initial version (1.1)
# 15.nov.1999 DEGT Added --regroup
# 19.nov.1999 DEGT Added headings to Statistics
# 20.nov.1999 DEGT Theoretically speaking... Mandrake & SuSE
# 21.nov.1999 DEGT Show distribution file in the header
# 21.nov.1999 DEGT Added --nosave for --init and --sync, messages
# 21.nov.1999 DEGT Added --append for --init (SuSE)
# 21.nov.1999 DEGT Fixed sync problem, was losing previous upgrade tags
# 01.dec.1999 DEGT Added --compare
# 03.dec.1999 DEGT v1.2-1 Second Official Release
# xx.xxx.1999 AG   agonzalez@yahoo.com path for version compare
# 28.dec.1999 DEGT Built-in regression test (--rt vc)