#!C:\strawberry\perl\bin\perl.exe
### 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 Coro;
use Coro::Channel;
use Coro::Handle;

our $VERSION = "0.0.1";

$| = 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')
);
push @found, $rule->in($_) for @libpath;
@prev_path{@found} = (1) x @found;
### prev_path: @found+0

undef $rule;
undef @found;

### 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";
}

$fh = unblock $fh;    # async_fh

# body part
my %seen;
my %dist_latest_version;

my $main = Coro::current;

my %num_of_channel = ( scan => 5, info => 2, rep => 5 );
my %ch;

### open channel
$ch{$_} = Coro::Channel->new( $num_of_channel{$_} ) for keys %num_of_channel;

### spawn threads
for my $ref (
#       worker      num_of_workers
    [ \&_parse_gz, 10 ],
    [ \&_scan_inc, 2 ],
    [ \&_get_info, 1 ],
    [ \&_report,   1 ]
    )
{
    my ( $sub, $num ) = @{$ref};
    async_pool { $sub->() } for 1 .. $num;
}

### schedule
schedule;

exit;

sub _parse_gz {
    while (<$fh>) {
        chomp;
        my ( $pkg, $version, $dist ) = split ' ';
        cede;
## ***PKG: $pkg
        next if $version eq 'undef';

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

        # if excluding core modules
        next
            if $exclude_core && exists $core_modules->{$pkg};

        next
            if $dist =~ m{/perl-[0-9._]+\.tar\.(gz|bz2)$};
        my @a = split '::', $pkg . '.pm', $depth + 1;
        pop @a if @a > $depth;
        next unless $prev_path{ join( '/', @a ) };
        $ch{scan}->put( [ $pkg, $version, $dist ] );
    }
    $ch{scan}->shutdown;
    close $fh;
}

sub _scan_inc {
    while ( my $info = $ch{scan}->get ) {
        ( my $file = @$info[0] ) =~ s[::][/]g;
        $file .= '.pm';
        for my $dir (@libpath) {
            my $path = join '/', $dir, $file;
            next unless -f $path;
## --------PATH: $path
            $ch{info}->put( [ $path, @$info ] );
            last;
        }
        cede;
## --NOTFOUND: $file
    }
    $ch{info}->shutdown;
}

# 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 {
    while ( my $get = $ch{info}->get() ) {
        my ( $path, $pkg, $version, $dist ) = @{$get};
        my $info = CPAN::DistnameInfo->new($dist);
        cede;
        if ( my $latest = $dist_latest_version{ $info->dist } ) {
            # $info->version < $latest
            if ( compare_version( $info->version, $latest ) ) {
                next;
            }
        }
        $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);
        next unless defined $inst_version;
        if ( compare_version( $inst_version, $version ) ) {
            next if $seen{$dist}++;
            $ch{rep}->put( [ $pkg, $inst_version, $version, $dist ] );
#### ++: $pkg;
        }
    }
    $ch{rep}->shutdown;
}

sub _report {
    while ( my $get = $ch{rep}->get() ) {
        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";
        }
        cede;
    }
    $main->ready;
}

# 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> using a little more resources

=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

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> 240%.

trade-off:

=over 4

=item *
Use more memory - about 1%(42.6MB -> 43.2MB on MS-Win32.
C/W: 'cpan -O' uses 213MB)

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

=back

=head1 DEPENDENCIES

File::Find::Rule

Coro

Coro::Channel

Coro::Handle

=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
