#!/usr/bin/perl
our $VERSION = "0.06";
$| = 1;
my $quote = WIN32 ? q/"/ : q/'/;
my $local_lib;
my $self_contained = 0;
Getopt::Long::Configure("bundling");
Getopt::Long::GetOptions(
'h|help' => \my $help,
'verbose' => \my $verbose,
'm|mirror=s' => \$mirror,
'p|print-package' => \my $print_package,
'I=s' => sub { die "this option was deprecated" },
'l|local-lib=s' => \$local_lib,
'L|local-lib-contained=s' =>
sub { $local_lib = $_[1]; $self_contained = 1; },
'compare-changes' => sub {
die "--compare-changes option was deprecated.\n"
. "You can use 'cpan-listchanges `cpan-outdated -p`' instead.\n"
. "cpanm cpan-listchanges # install from CPAN\n";
},
'exclude-core' => \my $exclude_core,
)
or pod2usage();
pod2usage() if $help;
$mirror =~ s:/$::;
my $index_url = "${mirror}/modules/02packages.details.txt.gz";
my $core_modules = $Module::CoreList::version{$]};
my @libpath = make_inc( $local_lib, $self_contained );
my %prev_path;
my $depth = 2;
my @found;
my $rule = File::Find::Rule->new;
$rule = $rule->new->relative->maxdepth($depth)->or(
$rule->new->directory->or(
$rule->new->name('auto')->prune, $rule->new->name(qr/^(?:\.|\w+)$/),
$rule->new->prune
),
$rule->new->name('*.pm')
);
for my $p (@libpath) {
push @found, map lc(), $rule->in($p);
}
@prev_path{@found} = (1) x @found;
my $tmpfile = File::Temp->new( UNLINK => 1, SUFFIX => '.gz' );
getstore( $index_url, $tmpfile->filename );
my $fh = zopen($tmpfile) or die "cannot open $tmpfile";
while ( my $line = <$fh> ) {
last if $line eq "\n";
}
my %seen;
my %dist_latest_version;
my %ch;
my $cv;
my %num = (
gz => 30,
scan => 10,
info => 1,
rep => 1,
);
for (keys %num) {
$ch{$_} = [];
}
$cv=AE::cv;
my $cv_main=AE::cv;
for my $ref (
[ \&_parse_gz, 'gz' ],
[ \&_scan_inc, 'scan' ],
[ \&_get_info, 'info' ],
[ \&_report, 'rep' ],
)
{
my ( $sub, $name ) = @{$ref};
my $num = $num{$name};
for my $x (1..$num) {
$cv->begin;
my $w;$w=AE::timer 0,0.0001, sub{
if ($sub->()) {
undef $w;
$cv->end;
}
};
}
}
$cv_main->recv;
close $fh;
exit;
sub _parse_gz {
local $_=<$fh>;
unless (defined $_) {
push @{$ch{scan}}, undef;
return 1;
}
chomp;
my ( $pkg, $version, $dist ) = split ' ';
return if $version eq 'undef';
return unless $version =~ /[0-9]/;
return
if $exclude_core && exists $core_modules->{$pkg};
return
if $dist =~ m{/perl-[0-9._]+\.tar\.(gz|bz2)$};
my @a = split '::', $pkg . '.pm', $depth + 1;
pop @a if @a > $depth;
return unless $prev_path{ lc( join( '/', @a ) ) };
push @{$ch{scan}}, [ $pkg, $version, $dist, ];
return;
}
sub _scan_inc {
return unless @{$ch{scan}}+0;
my $get = shift @{$ch{scan}};
unless (defined $get) {
push @{$ch{info}}, undef;
return 1;
}
( my $file = @$get[0] ) =~ s[::][/]g;
$file .= '.pm';
for my $dir (@libpath) {
my $path = join '/', $dir, $file;
next unless -f $path;
push @{$ch{info}}, [ $path, @$get ];
return;
}
return;
}
sub _get_info {
return unless @{$ch{info}}+0;
my $get = shift @{$ch{info}};
unless (defined $get) {
push @{$ch{rep}}, undef;
return 1;
}
my ( $path, $pkg, $version, $dist ) = @{$get};
my $info = CPAN::DistnameInfo->new($dist);
if ( my $latest = $dist_latest_version{ $info->dist } ) {
if ( compare_version( $info->version, $latest ) ) {
return;
}
}
$dist_latest_version{ $info->dist } = $info->version;
my $meta = do {
local $SIG{__WARN__} = sub { };
Module::Metadata->new_from_file($path);
};
my $inst_version = $meta->version($pkg);
return unless defined $inst_version;
if ( compare_version( $inst_version, $version ) ) {
return if $seen{$dist}++;
push @{$ch{rep}}, [ $pkg, $inst_version, $version, $dist ];
}
return;
}
sub _report {
if(@{$ch{rep}}) {
my $get = shift @{$ch{rep}};
unless (defined $get) {
$cv_main->send;
return 1;
}
my ( $pkg, $inst_version, $version, $dist ) = @{$get};
if ($verbose) {
printf "%-30s %-7s %-7s %s\n", $pkg, $inst_version, $version,
$dist;
}
elsif ($print_package) {
print "$pkg\n";
}
else {
print "$dist\n";
}
}
return;
}
sub compare_version {
my ( $inst_version, $version ) = @_;
return 0 if $inst_version eq $version;
my $inst_version_obj = eval { version->new($inst_version) }
|| version->new( permissive_filter($inst_version) );
my $version_obj = eval { version->new($version) }
|| version->new( permissive_filter($version) );
return $inst_version_obj < $version_obj ? 1 : 0;
}
sub permissive_filter {
local $_ = $_[0];
s/^[Vv](\d)/$1/;
s/^(\d+)_(\d+)$/$1.$2/;
s/-[a-zA-Z]+$//;
s/([a-j])/ord($1)-ord('a')/gie;
s/[_h-z-]/./gi;
s/\.{2,}/./g;
$_;
}
sub which {
my ($name) = @_;
my $exe_ext = $Config{_exe};
foreach my $dir ( File::Spec->path ) {
my $fullpath = File::Spec->catfile( $dir, $name );
if ( -x $fullpath || -x ( $fullpath .= $exe_ext ) ) {
if ( $fullpath =~ /\s/ && $fullpath !~ /^$quote/ ) {
$fullpath = "$quote$fullpath$quote";
}
return $fullpath;
}
}
return;
}
sub getstore {
my ( $url, $fname ) = @_;
my $ua = LWP::UserAgent->new( parse_head => 0, );
$ua->env_proxy();
my $request = HTTP::Request->new( GET => $url );
my $response = $ua->request( $request, $fname );
if ( my $died = $response->header('X-Died') ) {
die "Cannot getstore $url to $fname: $died";
}
elsif ( $response->code == 200 ) {
return 1;
}
else {
die "Cannot getstore $url to $fname: " . $response->status_line;
}
}
sub zopen {
IO::Zlib->new( $_[0], "rb" );
}
sub make_inc {
my ( $base, $self_contained ) = @_;
if ($base) {
require local::lib;
my @modified_inc = (
local::lib->install_base_perl_path($base),
local::lib->install_base_arch_path($base),
);
if ($self_contained) {
push @modified_inc, @Config{qw(privlibexp archlibexp)};
}
else {
push @modified_inc, @INC;
}
return @modified_inc;
}
else {
return @INC;
}
}