The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use 5.012;
use warnings;

use CPANPLUS::Backend;
use Storable              qw(nstore);
use Data::Dumper          qw(Dumper);
use Getopt::Long          qw(GetOptions);

warn ">> started '$0'\n";

# parse commandline options
my @spec = (
    'url=s',
    'out_dumper=s',
    'out_nstore=s',
);
GetOptions(\my %a, @spec) or die ">> invalid option(s)";

# set defaults
$a{url}        //= 'http://cpan.strawberryperl.com';
$a{out_dumper} //= 'upgrade-list.dumper.txt';
$a{out_nstore} //= 'upgrade-list.nstore.txt';

### SUBROUTINES

sub get_cpanplus_backend {
  my %args = @_;
  
  warn ">> creating CPANPLUS::Backend\n";
  my $cb = CPANPLUS::Backend->new;
  my $conf = $cb->configure_object;

  if ($args{url}) {
    my $url = $args{url};
    $url = "$url/" unless $url =~ m|/$|;
    warn ">> using cpan mirror '$url'\n";
    my ($scheme, $host, $path) = $url =~ m|(.*?)://(.*?)(/.*)|;
    $conf->set_conf('hosts', [ {scheme=>$scheme, path=>$path, host=>$host} ]);
  }

  return $cb;
}

sub save_output {
  my ($data, $out_nstore, $out_dumper) = @_;

  if ($out_nstore) {
    warn ">> storing results via Storable to '$out_nstore'\n";
    nstore($data, $out_nstore) or die ">> store failed";;
  }

  if ($out_dumper) {
    warn ">> storing results via Data::Dumper to '$out_nstore'\n";
    open my $fh, ">", $out_dumper or die ">> open: $!";
    print $fh Dumper($data) or die ">> print: $!";
    close $fh or die ">> close: $!";
  }
}

sub modinfo2hash {
  my $mod = shift;
  return unless $mod && ref $mod eq 'CPANPLUS::Module';
  return {
    local_version => $mod->installed_version,
    cpan_version  => $mod->version,
    module        => $mod->module,
    distribution  => $mod->package_name,
    cpan_file     => $mod->author->cpanid . '/' . $mod->package,
    core_module   => $mod->module_is_supplied_with_perl_core ? 1 : 0,
  };
}

sub get_upgrade_list {
  my $cb = shift;
  die ">> no cpanplus backend" unless $cb;
  
  # get info about all installed modules
  warn ">> loading info about installed modules\n";
  my @all = $cb->installed;
  die ">> FATAL: cannot list installed modules via CPANPLUS\n" unless scalar(@all) > 0;

  # select modules that need upgrade
  my @to_upgrade = ();
  my @trouble_makers = ();

  my %seen;
  for my $mod (@all) {
    next if $mod->is_uptodate;           # skip this mod if it's up to date
    next if $mod->package_is_perl_core;  # skip this mod if it's core
    next if $seen{$mod->package}++;
    if ($mod->installed_version && $mod->version) {
      push @to_upgrade, $mod;
    }
    else {
      # undefined or '0' version
      push @trouble_makers, $mod;
    }
  }
  @to_upgrade = sort { $a->module cmp $b->module } @to_upgrade;
  @trouble_makers = sort { $a->module cmp $b->module } @trouble_makers;

  my $rv = { to_upgrade=>[], trouble_makers=>[], method=>'CPANPLUS', timestamp=>time };
  push @{$rv->{to_upgrade}}, modinfo2hash($_) for (@to_upgrade);
  push @{$rv->{trouble_makers}}, modinfo2hash($_) for (@trouble_makers);

  warn ">> count of all            = ", scalar(@all), "\n";
  warn ">> count of trouble_makers = ", scalar(@trouble_makers), "\n";
  warn ">> * $_->{cpan_file}\n" for (@{$rv->{trouble_makers}});
  warn ">> count of to_upgrade     = ", scalar(@to_upgrade), "\n";
  warn ">> * $_->{cpan_file}\n" for (@{$rv->{to_upgrade}});
  warn ">> get_upgrade_list finished\n";

  return $rv;
}

### MAIN

my $cb = get_cpanplus_backend(url=>$a{url});
my $data = get_upgrade_list($cb);
save_output($data, $a{out_nstore}, $a{out_dumper});

warn ">> done!\n";
exit 0;