File Coverage

blib/lib/CPAN/Perl/Releases/MetaCPAN.pm
Criterion Covered Total %
statement 15 77 19.4
branch 0 22 0.0
condition 0 5 0.0
subroutine 5 11 45.4
pod 0 5 0.0
total 20 120 16.6


line stmt bran cond sub pod time code
1             package CPAN::Perl::Releases::MetaCPAN;
2 1     1   104348 use strict;
  1         3  
  1         29  
3 1     1   5 use warnings;
  1         2  
  1         38  
4              
5             our $VERSION = '0.007';
6 1     1   901 use JSON::PP ();
  1         19314  
  1         29  
7 1     1   494 use HTTP::Tinyish;
  1         1083  
  1         31  
8              
9 1     1   7 use Exporter 'import';
  1         2  
  1         1161  
10             our @EXPORT_OK = qw(perl_tarballs perl_versions perl_pumpkins);
11              
12             sub new {
13 0     0 0   my ($class, %option) = @_;
14 0   0       my $uri = $option{uri} || "https://fastapi.metacpan.org/v1/release";
15 0           $uri =~ s{/$}{};
16 0 0         my $cache = exists $option{cache} ? $option{cache} : 1;
17 0           my $http = HTTP::Tinyish->new(verify_SSL => 1, agent => __PACKAGE__ . "/$VERSION");
18 0           my $json = JSON::PP->new->canonical(1);
19 0           bless { uri => $uri, http => $http, cache => $cache, json => $json }, $class;
20             }
21              
22             sub get {
23 0     0 0   my $self = shift;
24 0 0 0       return $self->{_releases} if $self->{cache} and $self->{_releases};
25              
26 0           my @release;
27 0           my $from = 0;
28 0           my $total;
29 0           my $uri = "$self->{uri}/_search";
30 0           for (1..5) {
31             # https://github.com/metacpan/metacpan-web/blob/master/lib/MetaCPAN/Web/Model/API/Release.pm
32             # https://github.com/metacpan/metacpan-api/blob/master/lib/MetaCPAN/Document/Release/Set.pm
33 0           my $query = {
34             query => {
35             bool => {
36             must => [
37             { term => { distribution => "perl" } },
38             { term => { authorized => JSON::PP::true } },
39             ],
40             },
41             },
42             size => 1000,
43             from => $from,
44             sort => [ { date => 'desc' } ],
45             fields => [qw( name date author version status maturity download_url )],
46             };
47             my $res = $self->{http}->post($uri, {
48 0           content => $self->{json}->encode($query),
49             headers => { 'content-type' => 'application/json' },
50             });
51 0 0         if (!$res->{success}) {
52 0 0         my $message = $res->{status} == 599 ? ", $res->{content}" : "";
53 0           chomp $message;
54 0           $message =~ s/\n/ /g;
55 0           die "$res->{status} $res->{reason}, $uri$message\n";
56             }
57 0           my $hash = $self->{json}->decode($res->{content});
58 0 0         $total = $hash->{hits}{total} unless defined $total;
59 0           push @release, map { $_->{fields} } @{$hash->{hits}{hits}};
  0            
  0            
60 0 0         last if $total <= @release;
61 0           $from = @release;
62             }
63 0 0         if ($total != @release) {
64 0           die sprintf "metacpan returns %d perl releases, but expected %d\n",
65             (scalar @release), $total;
66             }
67 0 0         $self->{_releases} = \@release if $self->{cache};
68 0           \@release;
69             }
70              
71             sub _self {
72 0 0   0     my $self = eval { $_[0]->isa(__PACKAGE__) } ? shift : __PACKAGE__->new;
  0            
73 0 0         wantarray ? ($self, @_) : $self;
74             }
75              
76             sub perl_tarballs {
77 0     0 0   my ($self, $arg) = _self @_;
78 0           my $releases = $self->get;
79             my %tarballs =
80             map {
81 0           my $url = $_->{download_url};
82 0           $url =~ s{.*authors/id/}{};
83 0 0         if ($url =~ /\.(tar\.\S+)$/) {
84 0           ($1, $url);
85             } else {
86 0           ();
87             }
88             }
89 0           grep { my $name = $_->{name}; $name =~ s/^perl-?//; $name eq $arg }
  0            
  0            
90 0           grep { $_->{status} =~ /^(?:cpan|latest)$/ }
  0            
91             @$releases;
92 0           \%tarballs;
93             }
94              
95             sub perl_versions {
96 0     0 0   my $self = _self @_;
97 0           my $releases = $self->get;
98             my @versions =
99 0           map { my $name = $_->{name}; $name =~ s/^perl-?//; $name }
  0            
  0            
100 0           grep { $_->{status} =~ /^(?:cpan|latest)$/ }
  0            
101             @$releases;
102 0           @versions;
103             }
104              
105             sub perl_pumpkins {
106 0     0 0   my $self = _self @_;
107 0           my $releases = $self->get;
108             my %author =
109 0           map { $_->{author} => 1 }
110 0           grep { $_->{status} =~ /^(?:cpan|latest)$/ }
  0            
111             @$releases;
112 0           sort keys %author;
113             }
114              
115             1;
116             __END__