File Coverage

blib/lib/MetaCPAN/Client.pm

Criterion	Covered	Total	%
statement	189	246	76.8
branch	31	58	53.4
condition	20	38	52.6
subroutine	44	51	86.2
pod	20	20	100.0
total	304	413	73.6

use strict;
use warnings;
package MetaCPAN::Client;
# ABSTRACT: A comprehensive, DWIM-featured client to the MetaCPAN API
$MetaCPAN::Client::VERSION = '2.040000';
use Moo;
use Carp;
use JSON::MaybeXS qw< JSON >;
use Ref::Util qw< is_arrayref is_hashref is_ref >;
use URI::Escape qw< uri_escape_utf8 >;

use MetaCPAN::Client::Request;
use MetaCPAN::Client::Author;
use MetaCPAN::Client::Distribution;
use MetaCPAN::Client::DownloadURL;
use MetaCPAN::Client::Module;
use MetaCPAN::Client::File;
use MetaCPAN::Client::Favorite;
use MetaCPAN::Client::Pod;
use MetaCPAN::Client::Rating;
use MetaCPAN::Client::Release;
use MetaCPAN::Client::Mirror;
use MetaCPAN::Client::Package;
use MetaCPAN::Client::Permission;
use MetaCPAN::Client::ResultSet;
use MetaCPAN::Client::Cover;
use MetaCPAN::Client::CVE;

has request => (
    is      => 'ro',
    handles => [qw],
);

my @supported_searches = qw<
    author distribution favorite module rating release mirror file permission package cover cve
>;

sub BUILDARGS {
    my ( $class, %args ) = @_;

    $args{'request'} ||= MetaCPAN::Client::Request->new(
        ( ua     => $args{ua}     )x!! $args{ua},
        ( ua_args => $args{ua_args} )x!! $args{ua_args},
        ( domain => $args{domain} )x!! $args{domain},
        ( debug  => $args{debug}  )x!! $args{debug},
    );

    return \%args;
}

sub author {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'author', $arg, $params );
}

sub module {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'module', $arg, $params );
}

sub distribution {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'distribution', $arg, $params );
}

sub file {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'file', $arg, $params );
}

sub package {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'package', $arg, $params );
}

sub permission {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'permission', $arg, $params );
}

sub cover {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'cover', $arg, $params );
}

sub cve {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'cve', $arg, $params );
}

sub pod {
    my $self   = shift;
    my $name   = shift;
    my $params = shift || {};

    return MetaCPAN::Client::Pod->new({
        request => $self->request,
        name    => $name,
        %$params
    });
}

sub favorite {
    my $self   = shift;
    my $args   = shift;
    my $params = shift;

    is_hashref($args)
        or croak 'favorite takes a hash ref as parameter';

    return $self->_search( 'favorite', $args, $params );
}

sub rating {
    my $self   = shift;
    my $args   = shift;
    my $params = shift;

    is_hashref($args)
        or croak 'rating takes a hash ref as parameter';

    return _empty_result_set('rating');
}

sub release {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'release', $arg, $params );
}

sub mirror {
    my $self   = shift;
    my $arg    = shift;
    my $params = shift;

    return $self->_get_or_search( 'mirror', $arg, $params );
}

sub reverse_dependencies {
    my $self = shift;
    my $dist = shift;

    $dist =~ s/::/-/g;

    return $self->_reverse_deps($dist);
}

*rev_deps = *reverse_dependencies;

sub recent {
    my $self = shift;
    my $size = shift || 100;

    $size eq 'today'
        and return $self->_recent(
            size   => 1000,
            query => {
                bool => {
                    filter => _filter_today()
                }
            }
        );

    $size =~ /^[0-9]+$/
        and return $self->_recent( size => $size );

    croak "recent: invalid size value";
}

sub all {
    my $self   = shift;
    my $type   = shift;
    my $params = shift;

    # This endpoint used to support only pluralized types (mostly) and convert
    # to singular types before redispatching.  Now it accepts both plural and
    # unplural forms directly and relies on the underlying methods it
    # dispatches to to check types (using the global supported types array).
    $type =~ s/s$//;

    $params and !is_hashref($params)
        and croak "all: params must be a hashref";

    if ( $params->{fields} and !is_arrayref($params->{fields}) ) {
        $params->{fields} = [ split /,/ => $params->{fields} ];
    }

    return $self->$type( { __MATCH_ALL__ => 1 }, $params );
}

sub download_url {
    my $self             = shift;
    my $module           = shift;
    my $version_or_range = shift;
    my $dev              = shift;

    my $uri = $module;
    my @extra;
    if ( defined $version_or_range ) {

        my @valid_ranges =  qw{ == != <= >= < > ! };
        my $is_using_range;
        foreach my $range ( @valid_ranges ) {
            if ( index( $version_or_range, $range ) >= 0 ) {
                $is_using_range = 1;
                last;
            }
        }
        # by default use the '==' operator when no range set
        $version_or_range = '==' . $version_or_range unless $is_using_range;

        # version=>0.21,<0.27,!=0.26&dev=1
        push @extra, 'version=' .uri_escape_utf8($version_or_range);
    }
    if ( defined $dev ) {
        push @extra, 'dev=' . uri_escape_utf8($dev);
    }

    $uri .= '?'.join('&', @extra) if scalar @extra;

    return $self->_get( 'download_url', $uri );
}

sub autocomplete {
    my $self = shift;
    my $q    = shift;

    my $res;

    eval {
        $res = $self->fetch( '/search/autocomplete?q=' . uri_escape_utf8($q) );
        1;

    } or do {
        warn $@;
        return [];
    };

    return [
        map { $_->{fields} } @{ $res->{hits}{hits} }
    ];
}

sub autocomplete_suggest {
    my $self = shift;
    my $q    = shift;

    my $res;

    eval {
        $res = $self->fetch( '/search/autocomplete/suggest?q=' . uri_escape_utf8($q) );
        1;

    } or do {
        warn $@;
        return [];
    };

    return $res->{suggestions};
}

###

sub _get {
    my $self = shift;

    ( scalar(@_) == 2
      or ( scalar(@_) == 3 and ( !defined $_[2] or is_hashref($_[2]) ) ) )
        or croak '_get takes type and search string as parameters (and an optional params hash)';

    my $type   = shift;
    my $arg    = shift;
    my $params = shift;

    my $fields_filter = $self->_read_fields( $params );

    my $response = $self->fetch(
        sprintf("%s/%s%s", $type ,$arg, $fields_filter||'')
    );
    is_hashref($response)
        or croak sprintf( 'Failed to fetch %s (%s)', ucfirst($type), $arg );

    $type = 'DownloadURL' if $type eq 'download_url';
    my $class = 'MetaCPAN::Client::' . ucfirst($type);

    if ( $type eq 'cve' and is_hashref($response) and is_arrayref($response->{cve} ) ) {
        $class =~ s/Cve/CVE/;
        $response = $response->{cve}[0];
    }

    return $class->new_from_request($response, $self);
}

sub _read_fields {
    my $self   = shift;
    my $params = shift;
    $params or return;

    my $fields = delete $params->{fields};
    $fields or return;

    if ( is_arrayref($fields) ) {
        grep { ref $_ } @$fields
            and croak "fields array should not contain any refs.";

        return sprintf( "?fields=%s", join q{,} => @$fields );

    } elsif ( !ref $fields ) {

        return "?fields=$fields";
    }

    croak "invalid param: fields";
}

sub _search {
    my $self   = shift;
    my $type   = shift;
    my $args   = shift;
    my $params = shift;

    is_hashref($args)
        or croak '_search takes a hash ref as query';

    ! defined $params or is_hashref($params)
        or croak '_search takes a hash ref as query parameters';

    $params ||= {};

    grep { $_ eq $type } @supported_searches
        or croak 'search type is not supported';

    my $scroller = $self->ssearch($type, $args, $params);

    return MetaCPAN::Client::ResultSet->new(
        scroller => $scroller,
        type     => $type,
    );
}

sub _get_or_search {
    my $self   = shift;
    my $type   = shift;
    my $arg    = shift;
    my $params = shift;

    is_hashref($arg) and
        return $self->_search( $type, $arg, $params );

    defined $arg and !is_ref($arg)
        and return $self->_get($type, $arg, $params);

    croak "$type: invalid args (takes scalar value or search parameters hashref)";
}

sub _reverse_deps {
    my $self = shift;
    my $dist = shift;

    my $res;

    eval {
        $res = $self->fetch(
            "/reverse_dependencies/dist/$dist",
            {
                size   => 5000,
                query  => {
                    bool => {
                        must => [
                            { term => { 'status'     => 'latest' } },
                            { term => { 'authorized' => JSON->true } },
                        ]
                    }
                },
            }
        );
        1;

    } or do {
        warn $@;
        return _empty_result_set('release'),
    };

    return MetaCPAN::Client::ResultSet->new(
        items => $res->{'data'},
        type  => 'release',
    );
}

sub _recent {
    my $self = shift;
    my @args = @_;

    my $res;

    eval {
        $res = $self->fetch(
            '/release/_search',
            {
                from   => 0,
                query  => { match_all => {} },
                @args,
                sort   => [ { 'date' => { order => "desc" } } ],
            }
        );
        1;

    } or do {
        warn $@;
        return _empty_result_set('release');
    };

    return MetaCPAN::Client::ResultSet->new(
        items => $res->{'hits'}{'hits'},
        type  => 'release',
    );
}

sub _filter_today {
    return { range => { date => { from => "now/1d+0h" } } };
}

sub _empty_result_set {
    my $type = shift;

    return MetaCPAN::Client::ResultSet->new(
        items => [],
        type  => $type,
    );
}

1;

__END__