view release on metacpan or  search on metacpan

lib/Dist/Surveyor/Inquiry.pm  view on Meta::CPAN

# but need to make it large enough for worst case distros (eg eBay-API).
# TODO: switching to the ElasticSearch module, with cursor support, will
# probably avoid the need for this. Else we could dynamically adjust.
our $metacpan_size = 2500;
our $metacpan_calls = 0;

our ($DEBUG, $VERBOSE);
*DEBUG = \$::DEBUG;
*VERBOSE = \$::VERBOSE;

require Exporter;
our @ISA = qw{Exporter};
our @EXPORT = qw{
    get_candidate_cpan_dist_releases
    get_candidate_cpan_dist_releases_fallback
    get_module_versions_in_release
    get_release_info
};

my $agent_string = "dist_surveyor/$VERSION";

my ($ua, $wget, $curl);
if (HTTP::Tiny->can_ssl) {
    $ua = HTTP::Tiny->new(
        agent => $agent_string,
        timeout => 10,
        keep_alive => 1, 
    );
} else { # for fatpacking support
    require File::Which;
    require IPC::System::Simple;
    $wget = File::Which::which('wget');
    $curl = File::Which::which('curl');
}

sub _https_request {
    my ($method, $url, $headers, $content) = @_;
    $headers ||= {};
    $method = uc($method || 'GET');
    if (defined $ua) {
        my %options;
        $options{headers} = $headers if %$headers;
        $options{content} = $content if defined $content;
        my $response = $ua->request($method, $url, \%options);
        unless ($response->{success}) {
            die "Transport error: $response->{content}\n" if $response->{status} == 599;
            die "HTTP error: $response->{status} $response->{reason}\n";
        }
        return $response->{content};
    } elsif (defined $wget) {
        my @args = ('-q', '-O', '-', '-U', $agent_string, '-T', 10, '--method', $method);
        push @args, '--header', "$_: $headers->{$_}" for keys %$headers;
        push @args, '--body-data', $content if defined $content;
        return IPC::System::Simple::capturex($wget, @args, $url);
    } elsif (defined $curl) {
        my @args = ('-s', '-S', '-L', '-A', $agent_string, '--connect-timeout', 10, '-X', $method);
        push @args, '-H', "$_: $headers->{$_}" for keys %$headers;
        push @args, '--data-raw', $content if defined $content;
        return IPC::System::Simple::capturex($curl, @args, $url);
    } else {
        die "None of IO::Socket::SSL, wget, or curl are available; cannot make HTTPS requests.";
    }
}

# caching via persistent memoize

my %memoize_cache;
my $locking_file;

=head1 CLASS METHODS

=head2 Dist::Surveyor::Inquiry->perma_cache()

Enable caching to disk of all the MetaCPAN API requests.
This cache can grew to be quite big - 40MB is one case, but it worth it,
as if you will need to run this program again, it will run much faster.

=cut

sub perma_cache {
    my $class = shift;
    my $db_generation = 3; # XXX increment on incompatible change
    my $pname = $FindBin::Script;
    $pname =~ s/\..*$//;
    my $memoize_file = "$pname-$db_generation.db";
    open $locking_file, ">", "$memoize_file.lock" 
        or die "Unable to open lock file: $!";
    flock ($locking_file, LOCK_EX) || die "flock: $!";
    tie %memoize_cache => 'Dist::Surveyor::DB_File', $memoize_file, O_CREAT|O_RDWR, 0640
        or die "Unable to use persistent cache: $!";
}

my @memoize_subs = qw(
    get_candidate_cpan_dist_releases
    get_candidate_cpan_dist_releases_fallback
    get_module_versions_in_release
    get_release_info
);
for my $subname (@memoize_subs) {
    my %memoize_args = (
        SCALAR_CACHE => [ HASH => \%memoize_cache ],
        LIST_CACHE   => 'FAULT',
        NORMALIZER   => sub { return join("\034", $subname, @_) }
    );
    memoize($subname, %memoize_args);
}

=head1 FUNCTIONS

=head2 get_release_info($author, $release)

Receive release info, such as:

    get_release_info('SEMUELF', 'Dist-Surveyor-0.009')

Returns a hashref containing all that release meta information, returned by
C<https://fastapi.metacpan.org/v1/release/$author/$release>
(but not information on the files inside the module)

Dies on HTTP error, and warns on empty response.