#!/bin/env perl -w
#
# $Id: cpan_check 1091 2007-03-07 07:00:12Z comand $
#
# Copyright 2006 Cory Omand <comand@blastwave.org>
# All rights reserved.  Use is subject to license terms.
#
# Redistribution and/or use, with or without modification, is
# permitted.  This software is without warranty of any kind.  The
# author(s) shall not be liable in the event that use of the
# software causes damage.
#
# cpan_check - Check CPAN for module updates.
#

use strict;
use Data::Dumper;
use File::Basename;
use Time::Local qw/timelocal/;
use vars qw/$HAS_LWP $MODULE_EXT/;

# Check for LWP support
$HAS_LWP = 0;
eval {
    require LWP::UserAgent;
    import LWP::UserAgent;
    $HAS_LWP = 1;
};

# Standard module extension
$MODULE_EXT = qr/\.(tar\.(gz|bz2)|tgz)/;

# Month lookup table
my @MONTHS = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
my %MONTHS;
for (my $i = 0; $i < @MONTHS; $i++) { $MONTHS{$MONTHS[$i]} = $i }

# Parse a module filename to get version information
sub fileinfo {
    my $file = shift;
    return unless $file;

    $file = basename $file;

    my ($mname, $mvers) = $file =~ /^(.+?)[-\.\_](\d.*?)$MODULE_EXT$/;
    return unless $mvers;
    return ($mname, $mvers);
}

# Get a directory listing
sub get_listing {
    my $dir = shift;

    my @listing;
    if ($HAS_LWP) {
        my $ua = LWP::UserAgent->new(env_proxy => 1);
        my $rsp = $ua->get($dir);
        die "failed to list $dir: [" . $rsp->code . "] " . $rsp->message
            unless $rsp->is_success;

        @listing = split(/\n/, $rsp->content);
    }
    else {
        @listing = `curl -s $dir`;
    }

    return @listing;
}

# Parse a HTML directory listing
sub parse_listing {
    my $line = shift;
    my ($file, $d, $m, $y, $H, $M);

    ($file, $d, $m, $y, $H, $M) = $line =~
      /<a\s+href="([^"]+)">.+<\/a>.+?  # file
       (\d{2})-(\w{3})-(\d{4})\s+    # date (DD-MMM-YYYY)
       (\d{2}):(\d{2})               # time (HH:MM)
      /ix;

    unless ($file and $d and $m and $y) {
        ($file, $y, $m, $d, $H, $M) = $line =~
          /<a\s+href=\"([^\"]+)\">.+<\/a>.+?  # file
          (\d{4})-(\w{3})-(\d{2})\s+        # date (YYYY-MMM-DD)
          (\d{2}):(\d{2})                   # time (HH:MM)
          /ix;
    }

    return ($file, $d, $m, $y, $H, $M);
}

# Get module information
sub get_modinfo {
    my $moddir  = shift;
    my $modname = shift;
    return unless $moddir and $modname;

    my @listing = get_listing($moddir);

    # Parse the listing...
    my $vinfo;
    foreach my $line (@listing) {
        my ($file, $d, $m, $y, $H, $M) = parse_listing($line);

        next unless $file && $file =~ /$MODULE_EXT$/;
        my ($mname, $mver) = fileinfo($file);
        next unless $mver and $mname;
        next if $mname ne $modname;

        $vinfo->{$mver} = timelocal(0, $M, $H, $d, $MONTHS{$m}, $y - 1900);
    }

    return $vinfo;
}

#
# MAIN EXECUTION
#

my $distfile = shift @ARGV;
die "Usage: $0 module_file" unless $distfile;

my $outfh;
my $outfile = shift @ARGV;
if ($outfile) {
    open $outfh, ">>$outfile"
        or die "Failed to open update file '$outfile': $!\n";
} else {
    $outfh = \*STDERR;
}

my ($modname, $modvers) = fileinfo($distfile);
die "Unable to parse module file name: $distfile"
    unless $modname && defined $modvers;

# Get the distribution directory
my $distdir = dirname($distfile) . "/";

# Get a list of modules...
my $info = get_modinfo($distdir, $modname)
    or die "Unable to retrieve module information for $modname!\n";

# Remove the current version.  If the module has been pulled
# from CPAN, assume no current release (update to latest).
my $currel = delete $info->{$modvers} || 0;

# Find the versions which are newer than that one
my @uprev;
foreach my $ver (sort { $info->{$a} <=> $info->{$b} } keys %$info) {
    push @uprev, $ver if $info->{$ver} >= $currel;
}

# Print version info
if (@uprev) {
    my @ndev = grep(!/_/, @uprev);
    my @dev  = grep( /_/, @uprev);

    if (@ndev) {
        print "$modname $modvers:\n";

        my $rec = pop @ndev;
        print "    Recommended: ", $rec, "\n";
        print "          Older: ", join(", ", @ndev), "\n" if @ndev;
        print "    Development: ", join(", ", @dev), "\n" if @dev;

        # Output info to automate udpates
        print $outfh "$modname|$rec", "\n";
    }
}

exit 0;

