The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package App::cpm::Resolver::02Packages;
use strict;
use warnings;
use App::cpm::version;
use Cwd ();
use File::Path ();
our $VERSION = '0.956';

{
    package
        App::cpm::Resolver::02Packages::Impl;
    use parent 'CPAN::Common::Index::Mirror';
    use Class::Tiny qw(path);
    use File::Spec;
    use File::Basename ();
    use File::Copy ();
    use HTTP::Tinyish;

    our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };

    sub BUILD {
        my $self = shift;
        if ($self->path =~ /\.gz$/ and !$HAS_IO_UNCOMPRESS_GUNZIP) {
            die "Can't load gz index file without IO::Uncompress::Gunzip";
        }
        return;
    }

    sub cached_package { shift->{cached_package} }

    sub refresh_index {
        my $self = shift;
        my $path = $self->path;
        my $dest = File::Spec->catfile($self->cache, File::Basename::basename($path));
        if ($path =~ m{^https?://}) {
            my $res = HTTP::Tinyish->new(agent => "App::cpm/$VERSION", verify_SSL => 1)->mirror($path => $dest);
            die "$res->{status} $res->{reason}, $path\n" unless $res->{success};
        } else {
            $path =~ s{^file://}{};
            die "$path: No such file.\n" unless -f $path;
            if (!-f $dest or (stat $dest)[9] < (stat $path)[9]) {
                File::Copy::copy($path, $dest) or die "Copy $path $dest: $!\n";
                my $mtime = (stat $path)[9];
                utime $mtime, $mtime, $dest;
            }
        }

        if ($dest =~ /\.gz$/) {
            ( my $uncompressed = File::Basename::basename($dest) ) =~ s/\.gz$//;
            $uncompressed = File::Spec->catfile( $self->cache, $uncompressed );
            if ( !-f $uncompressed or (stat $uncompressed)[9] < (stat $dest)[9] ) {
                no warnings 'once';
                IO::Uncompress::Gunzip::gunzip($dest, $uncompressed)
                    or die "Gunzip $dest: $IO::Uncompress::Gunzip::GunzipError";
            }
            $self->{cached_package} = $uncompressed;
        } else {
            $self->{cached_package} = $dest;
        }
    }
}

sub new {
    my ($class, %option) = @_;
    my $cache_base = $option{cache} or die "cache option is required\n";
    my $mirror = $option{mirror} or die "mirror option is required\n";
    $mirror =~ s{/*$}{/};

    my ($path, $cache);
    if ($option{path}) {
        $path = $option{path};
    } else {
        $path = "${mirror}modules/02packages.details.txt.gz";
        $cache = $class->cache_for($mirror, $cache_base);
    }

    my $impl = App::cpm::Resolver::02Packages::Impl->new(
        path => $path, $cache ? (cache => $cache) : (),
    );
    $impl->refresh_index; # refresh_index first
    bless { mirror => $mirror, impl => $impl }, $class;
}

sub cache_for {
    my ($class, $mirror, $cache) = @_;
    if ($mirror !~ m{^https?://}) {
        $mirror =~ s{^file://}{};
        $mirror = Cwd::abs_path($mirror);
        $mirror =~ s{^/}{};
    }
    $mirror =~ s{/$}{};
    $mirror =~ s/[^\w\.\-]+/%/g;
    my $dir = "$cache/$mirror";
    File::Path::mkpath([ $dir ], 0, 0777);
    return $dir;
}

sub cached_package { shift->{impl}->cached_package }

sub resolve {
    my ($self, $job) = @_;
    my $result = $self->{impl}->search_packages({package => $job->{package}});
    if (!$result) {
        return { error => "not found, @{[$self->cached_package]}" };
    }

    if (my $version_range = $job->{version_range}) {
        my $version = $result->{version};
        if (!App::cpm::version->parse($version)->satisfy($version_range)) {
            return { error => "found version $version, but it does not satisfy $version_range, @{[$self->cached_package]}" };
        }
    }
    my $distfile = $result->{uri};
    $distfile =~ s{^cpan:///distfile/}{};
    $distfile =~ m{^((.).)};
    $distfile = "$2/$1/$distfile";
    return +{
        source => "cpan", # XXX
        distfile => $distfile,
        uri => "$self->{mirror}authors/id/$distfile",
        version => $result->{version} || 0,
        package => $result->{package},
    };
}

1;