#!/usr/bin/perl
# SYNTAX
# update_mods [-s <section>] [-h] tarball_dir
#
# DESCRIPTION:
# Downloads and udpates the modules in the tarball_dir according to
# the install_order file
# -h
#      Produces help output and exits
# -s <section>
#      work only on the specified section in the install_order file
#      Defaults to updating everything
#
# This is very inefficient because all version of a module are downloaded
# and extracted, and then all the oldest versions are removed and the extracted
# latest version is removed leaving only the tarball.  However, it does work...

use strict;
use warnings;
use Getopt::Std;
use CPAN;
use File::Copy;
use Cwd 'abs_path', 'getcwd';
use version;    # for version comparisons
use Data::Dump;

#use lib "/usr/local/nagios/perl/lib";
#use Data::Dump qw /dump/;

package main;

my $opts = {};
getopts( 's:hx', $opts ) || die "Invalid options";

my @errors;
my @not_found;

if ( $opts->{h} ) { usage(); }
my $moddir = shift @ARGV
    or die "Must specify a directory where tarballs should exist\n";
$moddir = abs_path($moddir);

my %ignores = ();
chdir $moddir or die "Cannot change to $moddir";
my @files = map { s/-\d+.*\.tar.gz//; $_ } <*.gz>;

print Data::Dump::dump(@files);

if ( $opts->{x} ) {
    exit clear_out();
}

CPAN::Shell::setup_output;
CPAN::Index->force_reload;

print "Downloading:\n";

my $tag = $opts->{s} || "all";

for my $f (@files) {
    next
        if ( !$f || $f =~ m/^\s+$/ || $f =~ m/^\s*#/ )
        ;    # ignore all blank lines
    $f =~ s/\s+//;       # remove all whitespaces from line
    $f =~ s/\s+#.*//;    # remove all comments from the line

    print "- $f\n";

    # search for what to download
    my $object;

    {

        # Assume (probably bad idea) distribution is "<name>-<numeric vers>"
        my $search = "/\/${f}";
        $search .= "-v?\\d" if ( $f !~ /\.tar\.gz$/ );
        $search .= "/";
        warn("dist search=$search");
        $object = object_search( $f, "Distribution", $search );
    }

    if ( !$object ) {

        # look for exact module name matches only
        warn("mod search");
        $object = object_search( $f, "Module", "/^$f\$/" );
    }

    if ( !$object ) {

        # clear out CPAN cache
        new CPAN::CacheMgr;

        push( @not_found,
            "Unable to find a match for $f in CPAN as module or distribution"
        );
    }
}

# clear out CPAN cache
new CPAN::CacheMgr;

print('Download finished',$/,$/);

clear_out();

print 'Tidying up finished',$/;

if (@not_found) {
    warn( join( $/, @not_found ) );
}
if (@errors) {
    warn( "Please correct \n", @errors, "in the install_order file\n" );
}

exit 255 if ( @not_found || @errors );

sub usage {
    print <<"!EOF!";
Usage: 
  $0 -h 
  $0 [-t <tag>] <perlmod dir>

Where:
  -h               - This help output
	-s  <section>    - Section within the install_order file to work on
  <perlmod dir>    - Directory to download modules to

Requires:
  <perlmod dir>/install_order
                   - list of files to download

NOTE: unless -t provided, will update all modules
!EOF!
    exit 0;
}

sub object_search {
    my ( $lookfor, $type, $search ) = @_;
    my $found = 0;
    for my $mod ( CPAN::Shell->expand( $type, $search ) ) {
        my $error;
        $found = 1;
        eval { $mod->get };
        if ($@) {
            return 0;
        }
        my ( $source, $dest );

        #dump($mod);

        if ( $mod->isa("CPAN::Module") ) {
            ( $dest = $mod->cpan_file ) =~ s!.*/!!;
            $source = $CPAN::Config->{'keep_source_where'}
                . "/authors/id/"
                . $mod->cpan_file;
            ( my $name = $dest ) =~ s/-\d.*//;
            if ( $name !~ /\.pm$/ && $name ne $lookfor ) {

                # clear out CPAN cache
                new CPAN::CacheMgr;
                push( @errors, "  $lookfor => $name\n" );
            }
        }
        elsif ( $mod->isa("CPAN::Distribution") ) {
            ( $dest = $mod->{localfile} ) =~ s!.*/!!;
            $source = $mod->{localfile};
        }
        else {
            warn( "UNKNOWN OBJECT TYPE: ", $mod->isa );
        }
        copy( $source, "$moddir/$dest" ) || die("Copy failed: $!");
    }
    return $found;
}

sub clear_out {

    # now remove older versions where duplicates have been fetched
    opendir( MODS, $moddir ) || die("Cannot read $moddir: $!");
    my @tarfiles;
    foreach my $tarfile ( sort( readdir(MODS) ) ) {
        next if ( $tarfile =~ m/^\./ );

        #	warn("Checking tarfile $tarfile");
        push( @tarfiles, $tarfile ) if ( -f "$moddir/$tarfile" );
    }
    close(MODS);

    die( "Didn't read $moddir (", getcwd(), ";$moddir\n" ) if ( !@tarfiles );

    my $prev;
    foreach my $file (sort @tarfiles) {
        ( my $match = $file ) =~ s/-v?\d+\.\d+\.(?:\d+\.)?tar\.gz//;

        #	warn("match=$match prev=$prev file=$file");

        if ( $prev && $prev =~ m/^$match-v?\d+/ ) {
            $prev =~ m/.*-v?(\d+\.\d+(?:\.\d+)?)\.t/;
            my $prev_ver = version->new($1);
            $file =~ m/.*-v?(\d+\.\d+(?:\.\d+)?)\.t/;
            my $cur_ver = version->new($1);

            warn("match=$match prev=$prev file=$file");
            warn(
                "prev_ver=", $prev_ver->numify,
                " cur_ver=", $cur_ver->numify
            );

            #warn("Match with $file and $prev");
            if ( $cur_ver > $prev_ver ) {
                warn("Removing $prev in preference to $file\n");
                unlink("$moddir/$prev");
            }
            elsif ( $cur_ver < $prev_ver ) {
                warn("Removing $file in preference to $prev\n");
                unlink("$moddir/$file");
            }
        }
        $prev = $file;
    }
}