#! /usr/bin/perl -w
use strict;

# RPMFu - Compare locally installed RPMs against those available
# from one or more ftp sites.  Download newer versions.
# http://www.highprogrammer.com/alan/perl/#rpmfu
#
# Copyright 2001 Alan De Smet
#
# 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.
#
# The GNU General Public License can be found at
# http://www.gnu.org/copyleft/gpl.html

# 0.1 - 20010127 - Initial release
# 0.2 - 20010211 - Fixed parsing of versions in filenames. (Apparently
#    it never worked, which is creepy, since it _did_ work.)
#

my($RPM) = '/bin/rpm';
my($NCFTPLS) = '/usr/bin/ncftpls -F';
my($WGET) = '/usr/bin/wget';
my(@SRCS) = (
    'ftp://mirror.cs.wisc.edu/pub/mirrors/linux/redhat/updates/6.2/en/os/i686/',
    'ftp://mirror.cs.wisc.edu/pub/mirrors/linux/redhat/updates/6.2/en/os/i586/',
    'ftp://mirror.cs.wisc.edu/pub/mirrors/linux/redhat/updates/6.2/en/os/i386/',
    'ftp://mirror.cs.wisc.edu/pub/mirrors/linux/redhat/updates/6.2/en/os/noarch/',
);


main();
exit;

package RPMVersion;
use Carp;

sub new {
    my $receiver = shift;
    my $class = (ref $receiver or $receiver);
    my $self = setup(@_);
    bless $self, $class;
    return $self;
}

sub break_up_version {
    my($src) = @_;
    carp "break up what?" if not defined $src;
    my(@v);
    while(length $src) {
        if($src =~ /^\./) {
            $src =~ s/^\.//;
            next;
        }
        if($src =~ /^\d/) {
            my($chunk) = ($src =~ /^(\d+)/);
            push @v, $chunk;
            $src =~ s/^(\d+)//;
            next;
        }
        if($src =~ /^\D/) {
            my($chunk) = ($src =~ /^(\D+)/);
            push @v, $chunk;
            $src =~ s/^(\D+)//;
            next;
        }
        # Odd, I don't know how to handle this.  Throw away first letter.
        $src = substr $src, 1;
    }
    return @v;
}

sub setup {
    my($src) = @_;
	my(@chunks) = split(/-/, $src);
	my $release = pop @chunks;
	my $version = pop @chunks;
	if(not defined $version or not defined $release) {
		print STDERR "Warning: Unable to parse $src\n";
	}
    my(@version) = break_up_version($version);
    my(@release) = break_up_version($release);
    my($self) = {
        'version' => \@version,
        'release' => \@release,
    };
    return $self;
}

sub list_diff_test {
    my($reflhs, $refrhs) = @_;
    my @lhs = @{ $reflhs };
    my @rhs = @{ $refrhs };


    while(scalar @lhs or scalar @rhs) {
        my($lhs) = shift @lhs || 0;
        my($rhs) = shift @rhs || 0;
        if($lhs =~ /^\d/ and $rhs =~ /^\d/) {
            return -1 if $lhs > $rhs;
            return  1 if $lhs < $rhs;
        } else {
            return -1 if $lhs gt $rhs;
            return  1 if $lhs lt $rhs;
        }
    }
    return 0;
}

sub release {
    my($self) = @_;
    carp "release is read only" if scalar @_ != 1;
    return @{ $self->{'release'} };
}

sub version {
    my($self) = @_;
    carp "version is read only" if scalar @_ != 1;
    return @{ $self->{'version'} };
}

sub diff_test {
    my($lhs, $rhs) = @_;
    my($ret, @lhs, @rhs);
    @lhs = $lhs->version();
    @rhs = $rhs->version();
    $ret = list_diff_test( \@lhs, \@rhs );
    return $ret if $ret != 0;
    @lhs = $lhs->release();
    @rhs = $rhs->release();
    $ret = list_diff_test( \@lhs, \@rhs );
    return $ret;
}

sub test_aide {
    my($lhs, $rhs, $want) = @_;
    my($ret) = diff_test( RPMVersion->new($lhs),RPMVersion->new($rhs) );
    if($ret != $want) {
        die "$lhs <=> $rhs == $ret != $want";
    }
    if($want != 0) {
        my($want) = -$want;
        my($ret) = diff_test( RPMVersion->new($rhs),RPMVersion->new($lhs) );
        if($ret != $want) {
            die "$rhs <=> $lhs == $ret != $want (R)";
        }
    }
}
sub test {
    test_aide("2.2.3-24x", "1.2.3-23x", -1);
    test_aide("1.2.3-23x", "1.2.3-24",   1);
    test_aide("1.2.3-23x", "1.2.3-23x",  0);
    test_aide("1.2.3-24x", "1.2.3-23x", -1);
    test_aide("1.3.3-24x", "1.2.3-23x", -1);
    test_aide("1.2.4-24x", "1.2.3-23x", -1);
    test_aide("1.2.3-24x", "1.2.4-23x",  1);
    test_aide("1.2.3-24x", "1.2.4-23y",  1);
    test_aide("1000-2", "2000-1", 1);
}

package main;


sub debug_print
{
    print STDERR @_;
}


sub main {
    #RPMVersion::test();
    #sanity_check_names();

    debug_print "Getting available rpms...";
    my(%avail) = get_available_rpms();
    debug_print "done\n";
    debug_print "Getting local rpms...";
    my(@rpms) = get_all_rpms();
    debug_print "done\n";

    foreach my $rpm (@rpms) {
        my($name) = get_canonical_name($rpm);
        next if not defined $avail{$name};

        my $remote = $avail{$name};
        my $version_local = RPMVersion->new($rpm);
        my $name_remote = get_available_name_only($remote);
        my $version_remote = RPMVersion->new($name_remote);
        my $diff = RPMVersion::diff_test($version_local, $version_remote);

        if( $diff > 0 ) {
            print "$name, have $rpm, getting $name_remote\n";
            system("$WGET $remote");
        }
    }
}

sub get_all_rpms {
    my(@list) = `$RPM --query --all`;
    chomp @list;
    return @list;
}

sub get_canonical_name {
    my($name) = @_;
    my($first_line) = `$RPM --query -i $name`;
    my($canonical_name) = ($first_line =~ /^Name\s*:\s*(\S+)/);
    return $canonical_name;
}

# I rely on the names of the files matching a certain pattern.  Check it.
sub sanity_check_names {
    my(@rpms) = get_all_rpms();

    foreach my $long_name (@rpms) {
        my $short_name = get_canonical_name($long_name);
        if($long_name !~ /^\Q$short_name\E-\d[.\w]*-\d[.\w]*/) {
            print STDERR "Unhappy! $long_name $short_name\n";
        }
    }
}

sub get_available_rpms
{
    my(%rpms);
    foreach my $src (@SRCS) {
        $src .= "/" if $src !~ /\/$/;
        my(@files) = `$NCFTPLS -1 $src`;
        chomp @files;
        if(scalar @files == 0) {
            print STDERR "$src has no files?\n";
        }
        foreach my $file (@files) {
            next if $file !~ /\.rpm$/;
            my($core_name) = ($file =~ /^(.+)-\d[^-]*-\d/);
            die "$src - $file" if not defined $core_name;
            if(not exists $rpms{$core_name}) {
                $rpms{$core_name} = $src.$file;
            }
        }
    }
    return %rpms;
}

sub get_available_name_only {
    my($s) = @_;
    my($file_only) = ($s =~ /\/([^\/]+)$/);
    my($name_only) = ($file_only =~ /^(.+)\.[^.]+\.rpm$/);
    die if not defined $name_only;
    return $name_only;
}