# Copyright (C) 2001, 2002 Hewlett Packard Corporation
# Copyright (C) 2005 Jay Beale
# Licensed under the GNU General Public License

package Bastille::TestAPI;
use lib "/usr/lib";

require Bastille::API;
import Bastille::API;

use Exporter;
@ISA = qw ( Exporter );
@EXPORT = qw(  B_run_test B_is_service_off B_match_line B_return_matched_line
B_match_chunk
B_is_package_installed isProcessRunning B_is_executable B_is_suid B_is_sgid 
B_check_permissions
B_get_user_list B_get_group_list B_parse_fstab B_parse_mtab B_is_rpm_up_to_date );
use lib "/usr/lib","/usr/lib/perl5/site_perl/","/usr/lib/Bastille";

$SKIPQ=1;
$ASKQ=0;

###########################################################################
# define tests
###########################################################################
use Bastille::test_AccountSecurity;
use Bastille::test_Apache;
use Bastille::test_BootSecurity;
#use Bastille::test_ConfigureMiscPAM;
use Bastille::test_DNS;
use Bastille::test_DisableUserTools;
use Bastille::test_FTP;
use Bastille::test_FilePermissions;
#use Bastille::test_Firewall;
use Bastille::test_HP_UX;
use Bastille::test_Logging;
use Bastille::test_MiscellaneousDaemons;
#use Bastille::test_PSAD;
#use Bastille::test_PatchDownload;
#use Bastille::test_Patches;
use Bastille::test_Printing;
#use Bastille::test_RemoteAccess;
use Bastille::test_SecureInetd;
use Bastille::test_Sendmail;
#use test_TMPDIR;

use Bastille::IPFilter;
&Bastille::IPFilter::defineTests;

###########################################################################
# &B_run_test($$)
#
# Runs the specified test to determine whether or not the question should
# be answered.
# return values:
# 0:     system is insecure, ask the question
# 1:     system is secure, don't bother
# undef: test is not defined, so you have to ask the question anyway
###########################################################################
sub B_run_test ($$) {
  my $module = $_[0];
  my $key = $_[1];

  if (exists $GLOBAL_TEST{$module}{$key}) {
      my $testout = &{$GLOBAL_TEST{$module}{$key}};
      &B_log("DEBUG","\$GLOBAL_TEST{'$module'}{'$key'} returned $testout.\n");
      # &OutputValidator($module,$key,$testout);
      print AUDIT_LOG "Run_test_says: $module $key $testout\n";
      return $testout;
  } else {
    &B_log("DEBUG","\$GLOBAL_TEST{'$module'}{'$key'} is not defined, ask question.\n");
    return undef;
  }
}

###########################################################################
# &B_is_service_off($$)
#
# Runs the specified test to determine whether or not the question should
# be answered.
#
# return values:
# $ASKQ/0:     service is on 
# $SKIPQ/1:     service is off 
# undef: test is not defined
###########################################################################

sub B_is_service_off ($){
   my $service=$_[0];

   
   if(&GetDistro =~ "^HP-UX"){
     return &checkServiceOnHPUX($service);
   }
   elsif ( (&GetDistro =~ "^RH") || (&GetDistro =~ "^SE") ) {
     return &checkServiceOnLinux($service);
   }
   else {
     # not yet implemented for other distributions of Linux
     # when GLOBAL_SERVICE, GLOBAL_SERVTYPE and GLOBAL_PROCESS are filled 
     # in for Linux, then
     # at least inetd and inittab services should be similar to the above,
     # whereas chkconfig would be used on some Linux distros to determine
     # if non-inetd/inittab services are running at boot time.  Looking at
     # processes should be similar.
     return undef;
   }
}

###########################################################################
# &checkServiceOnHPUX($service);
#
# Checks if the given service is running on an HP/UX system.  This is
# called by B_is_Service_Off(), which is the function that Bastille
# modules should call.
#
# Return values:
# $ASKQ if the service is on
# $SKIPQ if the service is off
# undef if the state of the service cannot be determined
#
###########################################################################
sub checkServiceOnHPUX($) {
  my $service=$_[0];

  # get the list of parameters which could be used to initiate the service
  # (could be in /etc/rc.config.d, /etc/inetd.conf, or /etc/inittab, so we
  # check all of them)
  my @params= @{ &getGlobal('SERVICE',$service) };
  my $grep =&getGlobal('BIN', 'grep');
  my $inetd=&getGlobal('FILE', 'inetd.conf');
  my $inittab=&getGlobal('FILE', 'inittab');
  my $retVals;
     
  foreach my $param (@params) {
    &B_log("DEBUG","Checking to see if service $service is off.\n");
    # this line is HP-UX specific

    if (&getGlobal('SERVTYPE', $service) =~ /rc/) {
      my $ch_rc=&getGlobal('BIN', 'ch_rc');
      my $on=`$ch_rc -l -p $param`;

      $on =~ s/\s*\#.*$//; # remove end-of-line comments
      $on =~ s/^\s*\"(.+)\"\s*$/$1/; # remove surrounding double quotes
      $on =~ s/^\s*\'(.+)\'\s*$/$1/; # remove surrounding single quotes

      chomp $on;
      &B_log("DEBUG","ch_rc returned: $param=$on\n");

      if ($on =~ /^\d+$/ && $on != 0) {
        # service is not off
        ###########################   BREAK out, don't skip question
        return $ASKQ;
      }
      elsif($on =~ /^\s*$/) {
        # if the value returned is an empty string return 
        # an undef value.
        return undef;
      }
    } 
    else {
      # those files which rely on comments to determine what gets
      # turned on, such as inetd.conf and inittab
      my $inettabs=`$grep -e '^[[:space:]]*$param' $inetd $inittab`;
      if ($inettabs =~ /.+/) {  # . matches anything except newlines
        # service is not off
        &B_log("DEBUG","Checking inetd.conf and inittab; found $inettabs\n");
        ###########################   BREAK out, don't skip question
        return $ASKQ;
      }
    } 
  }

  # boot-time parameters are not set; check processes
  return &checkProcsForService($service);
}

###########################################################################
# &checkServiceOnLinux($service);
#
# Checks if the given service is running on a Linux system.  This is
# called by B_is_Service_Off(), which is the function that Bastille
# modules should call.
#
# Return values:
# $ASKQ if the service is on
# $SKIPQ if the service is off
# undef if the state of the service cannot be determined
#
###########################################################################
sub checkServiceOnLinux($) {
  my $service=$_[0];

  # get the list of parameters which could be used to initiate the service
  # (could be in /etc/rc.d/rc?.d, /etc/inetd.conf, or /etc/inittab, so we
  # check all of them)
  my @params = @{ &getGlobal('SERVICE', $service) };
  my $chkconfig = &getGlobal('BIN', 'chkconfig');
  my $grep = &getGlobal('BIN', 'grep');
  my $inittab = &getGlobal('FILE', 'inittab');
  my $serviceType = &getGlobal('SERVTYPE', $service);;

  # A kludge to get things running because &getGlobal('SERVICE' doesn't 
  # return the expected values.
  @params = ();
  push (@params, $service);

  foreach my $param (@params) {
    &B_log("DEBUG","Checking to see if service $service is off.\n");

    if ($serviceType =~ /rc/) {
      my $on = `$chkconfig --list $param 2>&1`;
      if ($on =~ /^$param:\s+unknown/) {
	  # This service isn't installed on the system
	  return $SKIPQ;
      }
      if ($on =~ /^error reading information on service $param: No such file or directory/) {
	  # This service isn't installed on the system
	  return $SKIPQ;
      }
      if ($on =~ /^error/) {
	  # This probably 
	  &B_log("DEBUG","chkconfig returned: $param=$on\n");
	  return undef;
      }
      $on =~ s/^$param\s+//;		# remove the service name and spaces
      $on =~ s/[0-6]:off\s*//g;		# remove any runlevel:off entries
      $on =~ s/:on\s*//g;		# remove the :on from the runlevels
      # what remains is a list of runlevels in which the service is on, 
      # or a null string if it is never turned on
      chomp $on;			# newline should be gone already (\s)
      &B_log("DEBUG","chkconfig returned: $param=$on\n");

      if ($on =~ /^\d+$/) {
        # service is not off
        ###########################   BREAK out, don't skip question
        return $ASKQ;
      }
  }
    elsif ($serviceType =~ /inet/) {
	my $on = `$chkconfig --list $param 2>&1`;
	if ($on =~ /^$param:\s+unknown/) {
	    # This service isn't installed on the system
	    return $SKIPQ;
	}
	if ($on =~ /^error reading information on service $param: No such file or directory/) {
	    # This service isn't installed on the system
	    return $SKIPQ;
	}
	if ($on =~ /^error/ ) {
	 # Something else is wrong?
	 # return undef
	 return undef;
     }
      if ($on =~ tr/\n// > 1) {
        $on =~ s/^xinetd.+\n//;
      }
      $on =~ s/^\s*$param:?\s+//;	# remove the service name and spaces
      chomp $on;			# newline should be gone already (\s)
      &B_log("DEBUG","chkconfig returned: $param=$on\n");

      if ($on =~ /^on$/) {
        # service is not off
        ###########################   BREAK out, don't skip question
        return $ASKQ;
      }
    }
    else {
      # perhaps the service is started by inittab
      my $inittabline = `$grep -E '^[^#].{0,3}:.*:.+:.*$param' $inittab`;
      if ($inittabline =~ /.+/) {  # . matches anything except newlines
        # service is not off
        &B_log("DEBUG","Checking inittab; found $inittabline\n");
        ###########################   BREAK out, don't skip question
        return $ASKQ;
      } 
    }
  }  # foreach my $param


  # boot-time parameters are not set; check processes
  return &checkProcsForService($service);
}

###########################################################################
# &checkProcsForService($service);
#
# Checks if the given service is running by analyzing the process table.
# This is a helper function to checkServiceOnLinux and checkServiceOnHP
#
# Return values:
# $SKIPQ if the service is off
# undef if the state of the service cannot be determined
#
###########################################################################
sub checkProcsForService ($) {
  my $service=$_[0];
  my @psnames=@{ &getGlobal('PROCESS',$service)};

  my @processes;
  # inetd services don't have a separate process
  foreach my $psname (@psnames) {
    my @procList = &isProcessRunning($psname);
    if(@procList >= 0){
      splice @processes,$#processes+1,0,@procList;
    }
  }

  if($#processes >= 0){  # . matches anything except newlines
    &B_log("DEBUG","The following processes were still running even though " .
           "the corresponding service appears to be turned off.  Bastille " .
           "question and action will be skipped.\n\n" .
           "@processes\n\n");
    # processes were still running, service is not off, but we don't know how
    # to configure it so we skip the question
    return $SKIPQ; 
  } else {
    &B_log("DEBUG","$service is off.  Found no processes running on the system.");
    # no processes, so service is off
    return $SKIPQ; 
  }
  # Can't determine the state of the service by looking at the processes,
  # so return undef.
  return undef;
}


###########################################################################
# &B_match_line($file,$pattern);
#
# This subroutine will return a 1 if the pattern specified can be matched
# against the file specified.  It will return a 0 otherwise.
#
# return values:
# 0:     pattern not in file or the file is not readable
# 1:     pattern is in file
###########################################################################
sub B_match_line($$) {
    # file to be checked and pattern to check for.
    my ($file,$pattern) = @_;
    # if the file is readable then
    if(-r $file) {
	# if the file can be opened then
	if(open FILE,"<$file") {
	    # look at each line in the file
	    while (my $line = <FILE>) {
		# if a line matches the pattern provided then
		if($line =~ $pattern) {
		    # return the pattern was found
		    return 1;
		}
	    }
	}
	# if the file cann't be opened then
	else {
	    # send a note to that affect to the errorlog
	    &B_log("ERROR","Unable to open file for read.\n$file\n$!\n");
	}
    }
    # the provided pattern was not matched against a line in the file
    return 0;
}

###########################################################################
# &B_return_matched_line($file,$pattern);
#
# This subroutine returns lines in a file matching a given regular 
# expression, when called in the default list mode.  When called in scalar
# mode, it will return the number of lines that matched the given pattern.
#
###########################################################################
sub B_return_matched_line($$)
{
    my ($filename,$pattern) = @_;
    my @lines = ();

    open(READFILE, $filename);
    while (<READFILE>) {
	chomp;
	next unless /$pattern/;
	push(@lines, $_);
    }
    if (wantarray)
    {
	return @lines;
    }
    else
    {
	return scalar (@lines);
    }
}

###########################################################################
# &B_match_chunk($file,$pattern);
#
# This subroutine will return a 1 if the pattern specified can be matched
# against the file specified on a line-agnostic form.  This allows for 
# patterns which by necessity must match against a multi-line pattern.
# This is the natural analogue to B_replace_chunk, which was created to
# provide multi-line capability not provided by B_replace_line.
#
# return values:
# 0:     pattern not in file or the file is not readable
# 1:     pattern is in file
###########################################################################

sub B_match_chunk($$) {

    my ($file,$pattern) = @_;
    my @lines;
    my $big_long_line;
    my $retval=1;

    open CHUNK_FILE,$file;

    # Read all lines into one scalar.
    @lines = <CHUNK_FILE>;
    close CHUNK_FILE;

    foreach my $line ( @lines ) {
        $big_long_line .= $line;
    }

    # Substitution routines get weird unless last line is terminated with \n
    chomp $big_long_line;
    $big_long_line .= "\n";

    # Exit if we don't find a match
    unless ($big_long_line =~ $pattern) {
        $retval = 0;
    }

    return $retval;
}


###########################################################################
# &B_is_package_installed($package);
#
# This function checks for the existence of the package named.
#
# TODO: Allow $package to be an expression.
# TODO: Allow optional $version, $release, $epoch arguments so we can
#       make sure that the given package is at least as recent as some
#       given version number.
#
# scalar return values:
# 0:    $package is not installed
# 1:    $package is installed
###########################################################################

sub B_is_package_installed($) {

    my $package = $_[0];

    # This routine not yet implemented on HP-UX.
    my $distro = &GetDistro;
    if ($distro =~ /^HP-UX/) {
	return 0;
    }
    # This routine only works on RPM-based distros: Red Hat, Fedora, Mandrake and SuSE
    elsif ( ($distro !~ /^RH/) and ($distro !~ /^MN/) and($distro !~ /^SE/) ) {
	return 0;
    }
    # Run an rpm command -- librpm is extremely messy, dynamic and not
    # so much a perl thing.  It's actually barely a C/C++ thing...

    if (open RPM,"rpm -q $package") {
	# We should get only one line back, but let's parse a few
	# just in case.

	my @lines = <RPM>;
	close RPM;

	#
        # This is what we're trying to parse:
	#
	#
	# $ rpm -q jay
	# package jay is not installed
	# $ rpm -q bash
	# bash-2.05b-305.1
	#

	foreach $line (@lines) {
	    if ($line =~ /^package\s$package\sis\snot\sinstalled/) {
		return 0;
	    }
	    elsif ($line =~ /^$package\-/) {
		return 1;
	    }
	}

	# If we've read every line without finding one of these, then
	# our parsing is broken
	&B_log("ERROR","B_is_package_installed was unable to find a definitive RPM present or not present line.\n");
	return 0;

    }
    else {
	&B_log("ERROR","B_is_package_installed was unable to run the RPM command,\n");
	return 0;
    }

}

###########################################################################
# &B_check_permissions($$)
#
# Checks if the given file has the given permissions or stronger, where we
# define stronger as "less accessible."  The file argument must be fully 
# qualified, i.e. contain the absolute path.
#
# return values:
# 1: file has the given permissions or better
# 0:  file does not have the given permsssions
# undef: file permissions cannot be determined
###########################################################################

sub B_check_permissions ($$){
  my ($fileName, $reqdPerms) = @_;
  my $filePerms;			# actual permissions


  if (-e $fileName) {
    if (stat($fileName)) {
      $filePerms = (stat($fileName))[2] & 07777;
    }
    else {
      &B_log ("ERROR", "Can't stat $fileName.\n");
      return undef;
    }
  }
  else {
    # If the file does not exist, permissions are as good as they can get.
    return 1;
  }

  #
  # We can check whether the $filePerms are as strong by
  # bitwise ANDing them with $reqdPerms and checking if the
  # result is still equal to $filePerms.  If it is, the 
  # $filePerms are strong enough.
  #
  if ( ($filePerms & $reqdPerms) == $filePerms ) {
      return 1;
  }
  else {
      return 0;
  }

}

###########################################################################
# &isProcessRunning($procPattern);
#
# If called in scalar context this subroutine will return a 1 if the
# pattern specified can be matched against the process table.  It will
# return a 0 otherwise.
# If called in the list context this subroutine will return the list
# of processes which matched the pattern supplied
#
# scalar return values:
# 0:     pattern not in process table
# 1:     pattern is in process table
#
# list return values:
# proc lines from the process table if they are found
###########################################################################
sub isProcessRunning($) {

    my $procPattern= $_[0];
    my $ps = &getGlobal('BIN',"ps");

    my $isRunning=0;
    # process table.
    my @psTable = `$ps -elf`;
    # list of processes that match the $procPattern
    my @procList;
    foreach my $process (@psTable) {
	if($process =~ $procPattern) {
	    $isRunning = 1;
	    push @procList, $process . "\n";
	} 
    }
    &B_log("DEBUG","$procPattern search yielded $isRunning\n\n");
    # if this subroutine was called in scalar context
    if( ! wantarray ) {
	return $isRunning; 
    }

    return @procList;
}


###########################################################################
# B_is_executable($)
#
# This routine reports on whether a file is executable by the current 
# process' effective UID. 
#
# scalar return values:
# 0:     file is not executable
# 1:     file is executable
#
###########################################################################

sub B_is_executable($)
{
    my $name = shift;
    my $executable = 0;

    if (-x $name) {
	$executable = 1;
    }
    return $executable;
}

###########################################################################
# B_is_suid($)
#
# This routine reports on whether a file is Set-UID and owned by root.
#
# scalar return values:
# 0:     file is not SUID root
# 1:     file is SUID root
#
###########################################################################

sub B_is_suid($)
{
    my $name = shift;

    my @FileStatus = stat($name);
    my $IsSuid = 0;

    if (-u $name)
    {
        if($FileStatus[4] == 0) {
            $IsSuid = 1;
        }
    }

    return $IsSuid;
}

###########################################################################
# B_is_sgid($)
#
# This routine reports on whether a file is SGID and group owned by 
# group root (gid 0).
#
# scalar return values:
# 0:     file is not SGID root
# 1:     file is SGID root
#
###########################################################################

sub B_is_sgid($)
{
    my $name = shift;

    my @FileStatus = stat($name);
    my $IsSgid = 0;

    if (-g $name)
    {
        if($FileStatus[5] == 0) {
            $IsSgid = 1;
        }
    }

    return $IsSgid;
}

###########################################################################
# B_get_user_list()
#
# This routine outputs a list of users on the system.
#
###########################################################################

sub B_get_user_list()
{
    my @users;
    open(PASSWD,&getGlobal('FILE','passwd'));
    while(<PASSWD>) {
        #Get the users
        if (/^([^:]+):/)
        {
            push (@users,$1);
        }
    }
     return @users;
}

###########################################################################
# B_get_group_list()
#
# This routine outputs a list of groups on the system.
#
###########################################################################

sub B_get_group_list()
{
    my @groups;
    open(GROUP,&getGlobal('FILE','group'));
    while(my $group_line = <GROUP>) {
        #Get the groups
        if ($group_line =~ /^([^:]+):/)
        {
	    push (@groups,$1);
        }
    }
     return @groups;
}


###########################################################################
# B_parse_fstab()
#
# Search the filesystem table for a specific mount point.
#
# scalar return value:
# The line form the table that matched the mount point, or the null string 
# if no match was found.
#
# list return value:
# A list of parsed values from the line of the table that matched, with 
# element [3] containing a reference to a hash of the mount options.  The 
# keys are: acl, dev, exec, rw, suid, sync, or user.  The value of each key 
# can be either 0 or 1.  To access the hash, use code similar to this:
# %HashResult = %{(&B_parse_fstab($MountPoint))[3]};
#
###########################################################################

sub B_parse_fstab($)
{
    my $name = shift;
    my $file = &getGlobal('FILE','fstab');
    my ($enable, $disable, $infile);
    my @lineopt;
    my $retline = "";
    my @retlist = ();

    unless (open FH, $file) {
	&B_log('ERROR',"B_parse_fstab couldn't open fstab file at path $file.\n");
	return 0;
    }
    while (<FH>) {
        s/\#.*//;
        next unless /\S/;
        @retlist = split;
        next unless $retlist[1] eq $name;
        $retline  .= $_;
        if (wantarray) {
            my $option = {		# initialize to defaults
            acl    =>  0,		# for ext2, etx3, reiserfs
            dev    =>  1,
            exec   =>  1,
            rw     =>  1,
            suid   =>  1,
            sync   =>  0,
            user   =>  0,
            };

            my @lineopt = split(',',$retlist[3]);
            foreach my $entry (@lineopt) {
                if ($entry eq 'acl') {
                    $option->{'acl'} = 1;
                }
                elsif ($entry eq 'nodev') {
                    $option->{'dev'} = 0;
                }
                elsif ($entry eq 'noexec') {
                    $option->{'exec'} = 0;
                }
                elsif ($entry eq 'ro') {
                    $option->{'rw'} = 0;
                }
                elsif ($entry eq 'nosuid') {
                    $option->{'suid'} = 0;
                }
                elsif ($entry eq 'sync') {
                    $option->{'sync'} = 1;
                }
                elsif ($entry eq 'user') {
                    $option->{'user'} = 1;
                }
            }
            $retlist[3]= $option;
        }
        last;
    }

    if (wantarray)
    {
        return @retlist;
    }
    else
    {
        return $retline;
    }

}


###########################################################################
# B_parse_mtab()
#
# This routine returns a hash of devices and their mount points from mtab,
# simply so you can get a list of mounted filesystems.
#
###########################################################################

sub B_parse_mtab
{
    my $mountpoints;
    open(MTAB,&getGlobal('FILE','mtab'));
    while(my $mtab_line = <MTAB>) {
        #test if it's a device
        if ($mtab_line =~ /^\//)
        {
           #parse out device and mount point
           $mtab_line =~ /^(\S+)\s+(\S+)/;
           $mountpoints->{$1} = $2;
        }
     }
     return $mountpoints;
}


###########################################################################
# B_is_rpm_up_to_date()
#
#
###########################################################################

sub B_is_rpm_up_to_date(@)
{
    my($nameB,$verB,$relB,$epochB) = @_;
    my $installedpkg = $nameB;
    
    if ($epochB =~ /(none)/) {
	$epochB = 0;
    } 
    
    my $rpmA   = `rpm -q --qf '%{VERSION}-%{RELEASE}-%{EPOCH}\n' $installedpkg`;
    my $nameA  = $nameB;
    my ($verA,$relA,$epochA);
    
    my $retval;
    
    # First, if the RPM isn't installed, let's handle that.
    if ($rpmA =~ /is not installed/) {
	$retval = -1;
	return $retval;
    }
    else {
	# Next, let's try to parse the EVR information without as few
	# calls as possible to rpm.
	if ($rpmA =~ /([^-]+)-([^-]+)-([^-]+)$/) {
	    $verA = $1;
	    $relA = $2;
	    $epochA = $3;
	}
	else {
	    $nameA  = `rpm -q --qf '%{NAME}' $installedpkg`;
	    $verA  = `rpm -q --qf '%{VERSION}' $installedpkg`;
	    $relA  = `rpm -q --qf '%{RELEASE}' $installedpkg`;
	    $epochA  = `rpm -q --qf '%{EPOCH}' $installedpkg`;
	}
    }
    
    # Parse "none" as 0.
    if ($epochA =~ /(none)/) {
	$epochA = 0;
    }
    
    # Handle the case where only one of them is zero.
    if ($epochA == 0 xor $epochB == 0)
    {
	if ($epochA != 0)
	{
	    $retval = 1;
	}
	else
	{
	    $retval = 0;
	}
    }
    else
    {
	# ...otherwise they are either both 0 or both non-zero and
	# so the situation isn't trivial.

	# Check epoch first - highest epoch wins.
	my $rpmcmp = &cmp_vers_part($epochA, $epochB);
	#print "epoch rpmcmp is $rpmcmp\n";
	if ($rpmcmp > 0)
	{
	    $retval = 1;
	}
	elsif ($rpmcmp < 0)
	{
	    $retval = 0;
	}
	else
	{
	    # Epochs were the same.  Check Version now.
	    $rpmcmp = &cmp_vers_part($verA, $verB);
	    #print "epoch rpmcmp is $rpmcmp\n";
	    if ($rpmcmp > 0)
	    {
		$retval = 1;
	    }
	    elsif ($rpmcmp < 0)
	    {
		$retval = 0;
	    }
	    else
	    {
		# Versions were the same.  Check Release now.
		my $rpmcmp = &cmp_vers_part($relA, $relB);
		#print "epoch rpmcmp is $rpmcmp\n";
		if ($rpmcmp >= 0)
		{
		    $retval = 1;
		}
		elsif ($rpmcmp < 0)
		{
		    $retval = 0;
		}
	    }
	}
    }
    return $retval;
}

#################################################
#  Helper function for B_is_rpm_up_to_date()
#################################################

#This cmp_vers_part function taken from Kirk Bauer's Autorpm. 
# This version comparison code was sent in by Robert Mitchell and, although
# not yet perfect, is better than the original one I had. He took the code
# from freshrpms and did some mods to it. Further mods by Simon Liddington
# <sjl96v@ecs.soton.ac.uk>.
#
# Splits string into minors on . and change from numeric to non-numeric
# characters. Minors are compared from the beginning of the string. If the
# minors are both numeric then they are numerically compared. If both minors
# are non-numeric and a single character they are alphabetically compared, if
# they are not a single character they are checked to be the same if the are not
# the result is unknown (currently we say the first is newer so that we have
# a choice to upgrade). If one minor is numeric and one non-numeric then the
# numeric one is newer as it has a longer version string.
# We also assume that (for example) .15 is equivalent to 0.15

sub cmp_vers_part($$) {
   my($va, $vb) = @_;
   my(@va_dots, @vb_dots);
   my($a, $b);
   my($i);

   if ($vb !~ /^pre/ and $va =~ s/^pre(\d+.*)$/$1/) {
      if ($va eq $vb) { return -1; }
   } elsif ($va !~ /^pre/ and $vb =~ s/^pre(\d+.*)$/$1/) {
      if ($va eq $vb) { return 1; }
   }

   @va_dots = split(/\./, $va);
   @vb_dots = split(/\./, $vb);

   $a = shift(@va_dots);
   $b = shift(@vb_dots);
   # We also assume that (for example) .15 is equivalent to 0.15
   if ($a eq '' && $va ne '') { $a = "0"; }
   if ($b eq '' && $vb ne '') { $b = "0"; }
   while ((defined($a) && $a ne '') || (defined($b) && $b ne '')) {
      # compare each minor from left to right
      if ((not defined($a)) || ($a eq '')) { return -1; } # the longer version is newer
      if ((not defined($b)) || ($b eq '')) { return  1; }
      if ($a =~ /^\d+$/ && $b =~ /^\d+$/) {
         # I have changed this so that when the two strings are numeric, but one or both
         # of them start with a 0, then do a string compare - Kirk Bauer - 5/28/99
         if ($a =~ /^0/ or $b =~ /^0/) {
            # We better string-compare so that netscape-4.6 is newer than netscape-4.08
            if ($a ne $b) {return ($a cmp $b);}
         }
         # numeric compare
         if ($a != $b) { return $a <=> $b; }
      } elsif ($a =~ /^\D+$/ && $b =~ /^\D+$/) {
         # string compare
         if (length($a) == 1 && length($b) == 1) {
            # only minors with one letter seem to be useful for versioning
            if ($a ne $b) { return $a cmp $b; }
         } elsif (($a cmp $b) != 0) {
            # otherwise we should at least check they are the same and if not say unknown
            # say newer for now so at least we get choice whether to upgrade or not
            return -1;
         }
      } elsif ( ($a =~ /^\D+$/ && $b =~ /^\d+$/) || ($a =~ /^\d+$/ && $b =~ /^\D+$/) ) {
         # if we get a number in one and a word in another the one with a number
         # has a longer version string
         if ($a =~ /^\d+$/) { return 1; }
         if ($b =~ /^\d+$/) { return -1; }
      } else {
         # minor needs splitting
         $a =~ /\d+/ || $a =~ /\D+/;
         # split the $a minor into numbers and non-numbers
         my @va_bits = ($`, $&, $');
         $b =~ /\d+/ || $b =~ /\D+/;
         # split the $b minor into numbers and non-numbers
         my @vb_bits = ($`, $&, $');
         for ( my $j=2; $j >= 0; $j--) {
            if ($va_bits[$j] ne '') { unshift(@va_dots,$va_bits[$j]); }
            if ($vb_bits[$j] ne '') { unshift(@vb_dots,$vb_bits[$j]); }
         }
      }
      $a = shift(@va_dots);
      $b = shift(@vb_dots);
   }
   return 0;
}

   
1;
