#!/usr/bin/perl
#### START: scalar(localtime)

# below requires for original cpan-outdated
use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use File::Temp;
use File::Spec;
use Config;
use version;
use LWP::Simple ();
use IO::Zlib;
use CPAN::DistnameInfo;
use Module::CoreList ();
use Module::Metadata;
use constant WIN32 => $^O eq 'MSWin32';

# require this script only
use File::Find::Rule;
use AnyEvent;
use AnyEvent::Util;

our $VERSION = "0.06";

$| = 1;

my $mirror = 'http://www.cpan.org/';
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;
#### prepare filtering with module path: 'depth='.$depth
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;
#### prev_path: @found+0

#### mktemp
my $tmpfile = File::Temp->new( UNLINK => 1, SUFFIX => '.gz' );

#### fetch 02packages.details.txt
getstore( $index_url, $tmpfile->filename );
#### open gz and skip HEADER
my $fh = zopen($tmpfile) or die "cannot open $tmpfile";
## skip header part
while ( my $line = <$fh> ) {
    last if $line eq "\n";
}

# body part
my %seen;
my %dist_latest_version;

my %ch;
my $cv;

# AnyEvent::Util::fh_nonblocking($fh,1);

#### create channel
my %num = (
    gz => 30,
    scan => 10,
    info => 1,
    rep => 1,
);

for (keys %num) {
    $ch{$_} = [];
}
$cv=AE::cv;
my $cv_main=AE::cv;

#### spawn threads
for my $ref (
#       worker      name
    [ \&_parse_gz, 'gz' ],
    [ \&_scan_inc, 'scan' ],
    [ \&_get_info, 'info' ],
    [ \&_report,   'rep' ],
)
{
    my ( $sub, $name ) = @{$ref};
    my $num = $num{$name};
    ### spawn: $name => $num
    for my $x (1..$num) {
        $cv->begin;
         my $w;$w=AE::timer 0,0.0001, sub{
            ## enter: $name
            if ($sub->()) {
                undef $w;
                $cv->end;
            }
        };
    }
}

### schedule
$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 ' ';
## ***PKG: $pkg
    return if $version eq 'undef';

    # $Mail::SpamAssassin::Conf::VERSION is 'bogus'
    # https://rt.cpan.org/Public/Bug/Display.html?id=73465
    return unless $version =~ /[0-9]/;

    # if excluding core modules
    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: $pkg
    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;
### --------PATH: $path
        push @{$ch{info}}, [ $path, @$get ];
        return;
    }
    return;
## --NOTFOUND: $file
}

# ignore old distribution.
#   This is a heuristic approach. It is not a strict.
#   If you want a strict check, cpan-outdated looks 02packages.details.txt.gz twice.
#   It is too slow.
#
#   But, 02packages.details.txt.gz is sorted.
#   Submodules are listed after main module most of the time.
#   This strategy works well for now.
# ref https://github.com/tokuhirom/cpan-outdated/issues#issue/4

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 } ) {
        # $info->version < $latest
        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 ];
### ++: $pkg;
    }
    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;
}

# return true if $inst_version is less than $version
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;
}

# for broken packages.
sub permissive_filter {
    local $_ = $_[0];
    s/^[Vv](\d)/$1/;          # Bioinf V2.0
    s/^(\d+)_(\d+)$/$1.$2/;   # VMS-IndexedFile 0_02
    s/-[a-zA-Z]+$//;          # Math-Polygon-Tree 0.035-withoutworldwriteables
    s/([a-j])/ord($1)-ord('a')/gie;    # DBD-Solid 0.20a
    s/[_h-z-]/./gi;                    # makepp 1.50.2vs.070506
    s/\.{2,}/./g;
    $_;
}

# taken from cpanminus
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;
    }
}

__END__

=head1 NAME

cpan-outdated-coro - faster C<cpan-outdated>

=head1 SYNOPSIS

    # usage is the same:=)

    # print the list of distribution that contains outdated modules
    % cpan-outdated-coro

    # print the list of outdated modules in packages
    % cpan-outdated-coro -p

    # verbose
    % cpan-outdated-coro --verbose

    # alternate mirrors
    % cpan-outdated-coro --mirror file:///home/user/minicpan/

    # additional module path(same as cpanminus)
    % cpan-outdated-coro -l extlib/
    % cpan-outdated-coro -L extlib/

    # install with cpan
    % cpan-outdated-coro | xargs cpan -i

    # install with cpanm
    % cpan-outdated-coro    | cpanm
    % cpan-outdated-coro -p | cpanm

=head1 DESCRIPTION

( version 0.04 and later not use Coro, but never change the name of this distribution. )

This script works the same as C<cpan-outdated>(prints the list of outdated CPAN modules in your machine), but fast.

This script also can be integrated with L<cpanm> command.

=head1 USAGE

Using this script, only type with C<cpan-outdated-coro>
instead of C<cpan-outdated>.

Functions and options are completely the same as C<cpan-outdated>.
See C<cpan-outdated> for more details.

=head1 PERFORMANCE AND TRADE-OFF

This script is faster than C<cpan-outdated> 423%.

Use less memory - about 23%(39.01MB -> 30.06MB on MS-Win32.
C/W: 'cpan -O' uses 213MB)

trade-off:

=over 4

=item *
Use non-core modules - see C<DEPENDENCIES>.

=back

=head1 DEPENDENCIES

File::Find::Rule

AnyEvent

=head1 AUTHOR

KPEE

=head1 SPECIAL THANKS

Tokuhiro Matsuno(author of C<cpan-outdated>)

=head1 LICENSE

Copyright (C) 2014 KPEE

Original C<cpan-outdated> Copyright (C) 2009 Tokuhiro Matsuno.

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<App::cpanoutdated>

=cut

__END__
