#!/usr/bin/perl

use strict;
use warnings;

use CPAN;
use File::Basename;

my $prog = fileparse($0);

sub usage() {
    print <<"HELP";
$prog helps you to maintain CPAN modules.

-c      This is a cron job.  Output '$prog: ' at the start of each line so
        $prog | grep -P '^$prog: ' will send mail only when updated modules are
        available.

-d      Print raw, unfiltered module data for debugging.

-i      Output just install commands for updated modules.

-x mod  Exclude modules that you don't want to update for administrative reasons

-X dst  Exclude distributions that you don't want to update for administrative reasons

-v      Verbose output: List each module that needs updating, not just distributions.

Exclusions will match versions:
  -X perl       Will not report perl updates (any version)
  -X perl-5.12  Will not report perl 5.12 (or 5.12.3)
and module names:
  -x ModPerl::MethodLookup

Administrative reasons might be an incompatibility with your software, or perhaps
a dependency on a package not yet available for your platform.
HELP
    exit 1;
}

my( $d_cmd, $i_cmd, $c_cmd, $v_cmd, %x, %X );

$c_cmd = '';
while( $ARGV[0] && $ARGV[0] =~ m/^-/ ) {
  my $s = shift @ARGV;

  if( $s eq '-c' ) {
      $c_cmd = "$prog: ";
      next;
  }
  if( $s eq '-d' ) {
      $d_cmd = 1;
      next;
  }
  if( $s eq '-i' ) {
      $i_cmd = 1;
      next;
  }
  if( $s eq '-v' ) {
      $v_cmd = 1;
      next;
  }

  if( $s =~ /^-(h|\?)/ ) {
      usage();
      exit;
  }

  my $a = shift @ARGV if( $ARGV[0] !~ m/^-/ );
  if( $s =~ /^-x$/i ) {
      die "argument required for $s\n" unless( $a );

      my( $m, $v );
      if( $a =~ /(.*?)-(\d+\.\d+(?:\.\d+)*)$/ ) {
        ($m, $v) = ($1, ($2 || ''));
      } else {
        $m = $a;
        $v = '*';
      }
      if( $s eq '-x' ) {
        $x{$m} = $v;
      } else {
        $X{$m} = $v;
      }
      next;
  }

  die "$prog: Unknown switch \"$s\", try -h\n";
}

# Redirect stdout so we can filter idle chatter - especially
# for cron jobs and e-mail.

open my $oldout, ">&STDOUT"     or die "Can't dup STDOUT: $!\n";
my $out = '';
close STDOUT;
open STDOUT, ">", \$out or die "Can't redirect STDOUT\n";

my %dists;
for my $mod  (CPAN::Shell->expand("Module","/./")) {
    next unless $mod->inst_file;
    next if $mod->uptodate;
    printf "CPAN-update: Module %s version %s installed; version %s is available.\n",
            $mod->id, $mod->inst_version, $mod->cpan_version if( $d_cmd );

    if( (my $xv = $x{$mod->id}) ) {
      next if( $xv eq '*' || $mod->cpan_version =~ /^$xv/ );
    }

    my $dist = CPAN::Shell->expand(
                                    "Module", $mod->id
                                  )->distribution();
    my $distribution = $dist->base_id();
    my( $m, $v );
    if( $distribution =~ /(.*?)-(\d+\.\d+(?:\.\d+)*)$/ ) {
      ($m, $v) = ($1, ($2 || ''));
    } else {
      $m = $distribution;
      $v = '*';
    }
    if( (my $xv = $X{$m}) ) {
      next if( $xv eq '*' || $v =~ /^$xv/ );
    }
    unless( $dists{$distribution} ) {
        $dists{$distribution} = { count => 0,
                                  name => $dist->pretty_id,
                                  modlist => {},
        };
    }
    $dists{$distribution}{count}++;
    $dists{$distribution}{modlist}{$mod->id}{inst} = $mod->inst_version;
    $dists{$distribution}{modlist}{$mod->id}{new} = $mod->cpan_version;
}
for my $d (sort keys %dists) {
    my( $m, $v );
    if( $d =~ /(.*?)-(\d+\.\d+(?:\.\d+)*)$/ ) {
        ($m, $v) = ($1, " to version " . ($2 || '?'));
    } else {
        $m = $d;
        $v = '';
    }

    if( $i_cmd ) {
        printf "%sinstall %s\n", $c_cmd, $dists{$d}{name};
        next;
    }
    my $c = $dists{$d}{count};
    printf "%s%s should be updated%s for %d module%s\n", $c_cmd, $m, $v, $c, ($c == 1? '' : 's');
    if( $v_cmd ) {
        for my $m (sort keys %{$dists{$d}{modlist}}) {
            printf "%s    %s: installed version %s, new version %s\n", $c_cmd, $m,
                             $dists{$d}{modlist}{$m}{inst},
                             $dists{$d}{modlist}{$m}{new};
        }
    }
}

close STDOUT;
open STDOUT, ">&", $oldout or die "Can't re-redirect STDOUT:$!\n";
close $oldout;

# Strip idle chatter (conveniently, ANSI highlighting marks most of the offensive lines)

print map { ( m!^\033|(?:\s*ftp://.*/CPAN/(?:modules|authors)/)!? '' : "$_\n" ) } split( "\n", $out );