#!/usr/bin/perl -w
#
# I use up2date, and have it not delete the binaries. This accumulates
# cruft over time, and up2date doesn't have the "delete older
# binaries" option that I'd like it to have. So, this script attempts
# to clean up the specified (default current) directory in that
# manner.
#
# CAUTION: Deletes files. YHBW.
#
# September 2002:
#  Use RPM::Header to examine and compare versions
#  Use Getopts::Long to get options
# 08/06/2003 RPM::Header is no longer viable. curses!
# 15/02/2004 Added back in a hand-rolled vercmp
# 22/02/2004 Swapped meaning of debug & verbose flags (sanity)

# Try and find a viable RPM package
my $RPMAPI = "RPM::Header";
eval {
    require RPM::Header;
};
if ( $@) {
    eval {
        require RPM2;
        $RPMAPI = "RPM2";
    };
}
if ( $@ ) {
    $RPMAPI = "rpm";
}

# hush about warnings, thanks
sub goober {
    $RPM::err;
}

use Getopt::Long;

my $verbose = 0;
my $dryrun = 0;
my $debug = 0;

GetOptions( "verbose!" => \$verbose,
            "debug!" => \$debug,
            "dry-run!" => \$dryrun ) or
  print STDERR "usage: $0 [--verbose] [--dryrun] [rpmdirs]\n" and
  exit 1;

# if no directory is specified, clean the current directory
if (!@ARGV) {
	push @ARGV, ".";
}

while ( @ARGV ) {
    my %packages;

    $dir = shift;
    $dir =~ s|(.+)/$|$1|;
    print STDERR "Cleaning $dir\n" if $debug;

    if ( ! -d $dir ) {
        print STDERR "$dir: no such directory, skipping\n";
        next;
    }

    # Get a list of ".rpm" files in the directory. Note that gnorpm
    # currently downloads files as .rpm.tmp and doesn't rename them, so
    # we'll pick them up too. And .hdr files are from up2date; we just
    # want to remove unattached ones of those.
    opendir( DIR, "$dir" ) or die "$dir:$!\n";
    @files = grep /\.rpm$|\.rpm.tmp$|\.hdr$/, readdir( DIR );
    closedir( DIR );

    # Loop over the set of files we've collected
    for my $file ( sort @files ) {
        next if $file =~ /\.hdr$/;
        my $deleteme = "";
        my @bits;
        $file = "$dir/$file";
        print STDERR "Checking $file..." if $debug;

        # Use RPM to parse out the version, rather than the mish-mash of
        # regexps I'd otherwise need.
        my ( $package, $version, $release, $hdr ) =
          get_NVR( $file );

        # Maybe it's busted.
        if ( !defined( $package ) || !defined( $version ) ||
             !defined( $release )) {
            print STDERR "Failed to get version info on $file\n";
            next;
        }

        # Rename the GnoRPM files
        if ( $file =~ s/\.tmp$// ) {
            rename( "${file}.tmp", $file );
        }

        # treat source files separately
        if ( $file =~ /src\.rpm$/ ) {
            $package = "$package src";
        }

        print " Package $package $version $release: " if $debug;

        # Compare it against what we've already got.
        if ( defined( $packages{$package} )) {
            my ( $p, $v, $r, $f, $h )  = @{$packages{$package}};

            # Outright version difference
            my $vdiff = cmpver( $hdr, $h, $v, $r );

            if ( $vdiff < 0 ) {
                @bits = ( $p, $v, $r, $f, $h );
                $deleteme = $file;
                print "older than $v $r, " if $debug;
            } elsif ( $vdiff == 0 ) {
                @bits = ( $package, $version, $release, $file, $hdr );
                $deleteme = "";
                print "identical to $v $r, skipping.\n" if $debug;
            } else {
                @bits = ( $package, $version, $release, $file, $hdr );
                $deleteme = $f;
                print "supercedes $v $r, " if $debug;
            }
        } else {
            # Don't know about this package yet
            print "noted.\n" if $debug;
            @bits = ( $package, $version, $release, $file, $hdr );
        }

        # Nuke if necessary
        if ( $deleteme ) {
            print "deleting $deleteme.\n" if ( $verbose or $debug);
            unlink( $deleteme ) unless $dryrun;
            $deleteme =~ s/\.rpm/\.hdr/;
            unlink( $deleteme ) unless $dryrun;
        }

        # Make a note
        $packages{$package} = \@bits;
    }

    # Clean up unclaimed hdr files
    #  for my $file ( @files ) {
    #	next unless $file =~ /\.hdr$/;
    #	next unless defined $hdr{$hdr};
    #   unlink( $file );
    #  }
}

sub get_NVR {
    my $file = shift;
    my ( $package, $version, $release, $hdr );
    if ( $RPMAPI eq "RPM::Header" ) {
        $hdr = new RPM::Header $file;
        if ( !defined( $hdr )) {
            print STDERR "Can't access header of $file: $RPM::err\n";
            return;
        }
        ( $package, $version, $release ) =
          ( $hdr->{'NAME'}, $hdr->{'VERSION'}, $hdr->{'RELEASE'} );
    } else {
        ( $package, $version, $release ) =
          split( /\s/, `rpm -qp --queryformat "%{NAME} %{VERSION} %{RELEASE}" $file` );
        $hdr = [ $package, $version, $release ];
    }

    # Return the results
    return ( $package, $version, $release, $hdr );
}

sub cmpver {
    my ( $hdr, $h, $v2, $r2 ) = @_;

    if ( $RPMAPI eq "RPM::Header" ) {
        return $hdr->cmpver( $h )
    } else {
        my ( $v1, $r1 ) = ( $hdr->[1], $hdr->[2] );

        # this is actually pretty damned awkward, due to the wide variety
        # of crap that can appear in a version string. Also, we should be
        # checking the epoch if it's present, but screw that for a game of
        # soldiers.
        if ( $v1 eq $v2 ) {
            return $r1 <=> $r2 if $r1 =~ /^\d+(\.\d+)?$/ and $r2 =~ /^\d+(\.\d+)?$/;
            return myvercmp( $r1, $r2 );
        } else {
            # simple case: numeric compare
            return $v1 <=> $v2 if $v1 =~ /^\d+(\.\d+)?$/ and $v2 =~ /^\d+(\.\d+)?$/;
            return myvercmp( $v1, $v2 );
        }
    }
}

sub myvercmp {
    my $v1 = shift;
    my $v2 = shift;

    my @parts1 = split( /\./, $v1 );
    my @parts2 = split( /\./, $v2 );

    my $parts = scalar( @parts1 );
    if ( scalar( @parts2 ) > $parts ) {
        $parts = scalar( @parts2 );
    }

    for my $i ( 0 .. $parts - 1 ) {
        my $p1 = $parts1[$i] || 0;
        my $p2 = $parts2[$i] || 0;
        next if $p1 eq $p2;

        if ( $p1 =~ /^\d+$/ and $p2 =~ /^\d+$/ ) {
            return $p1 <=> $p2;
        } else {
            # here be dragons. due to collating order issues, this may
            # actually screw up and I should do more work on it as
            # soon as I can be bothered.
            return $p1 cmp $p2;
        }
    }
}