line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package WWW::PGXN; |
2
|
|
|
|
|
|
|
|
3
|
9
|
|
|
9
|
|
305887
|
use 5.010; |
|
9
|
|
|
|
|
35
|
|
|
9
|
|
|
|
|
379
|
|
4
|
9
|
|
|
9
|
|
53
|
use strict; |
|
9
|
|
|
|
|
65
|
|
|
9
|
|
|
|
|
552
|
|
5
|
9
|
|
|
9
|
|
6035
|
use WWW::PGXN::Distribution; |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
264
|
|
6
|
9
|
|
|
9
|
|
5898
|
use WWW::PGXN::Extension; |
|
9
|
|
|
|
|
23
|
|
|
9
|
|
|
|
|
293
|
|
7
|
9
|
|
|
9
|
|
5144
|
use WWW::PGXN::User; |
|
9
|
|
|
|
|
24
|
|
|
9
|
|
|
|
|
241
|
|
8
|
9
|
|
|
9
|
|
4908
|
use WWW::PGXN::Tag; |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
232
|
|
9
|
9
|
|
|
9
|
|
5203
|
use WWW::PGXN::Mirror; |
|
9
|
|
|
|
|
25
|
|
|
9
|
|
|
|
|
240
|
|
10
|
9
|
|
|
9
|
|
12444
|
use HTTP::Tiny; |
|
9
|
|
|
|
|
665843
|
|
|
9
|
|
|
|
|
430
|
|
11
|
9
|
|
|
9
|
|
9794
|
use URI::Template; |
|
9
|
|
|
|
|
172699
|
|
|
9
|
|
|
|
|
332
|
|
12
|
9
|
|
|
9
|
|
12142
|
use JSON (); |
|
9
|
|
|
|
|
200564
|
|
|
9
|
|
|
|
|
302
|
|
13
|
9
|
|
|
9
|
|
91
|
use Carp; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
10551
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $VERSION = v0.12.4; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub new { |
18
|
9
|
|
|
9
|
1
|
760
|
my($class, %params) = @_; |
19
|
9
|
|
|
|
|
31
|
my $self = bless {} => $class; |
20
|
9
|
|
|
|
|
2279
|
for my $key (qw(url proxy)) { |
21
|
18
|
100
|
|
|
|
1246
|
$self->$key($params{$key}) if exists $params{$key} |
22
|
|
|
|
|
|
|
} |
23
|
9
|
|
|
|
|
58
|
return $self; |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub get_distribution { |
27
|
15
|
|
|
15
|
1
|
718
|
my ($self, $dist, $version) = @_; |
28
|
15
|
100
|
100
|
|
|
161
|
my $data = $self->_fetch_json( |
|
|
100
|
|
|
|
|
|
29
|
|
|
|
|
|
|
(defined $version ? 'meta' : 'dist'), |
30
|
|
|
|
|
|
|
{ dist => lc $dist, version => lc($version || '') } |
31
|
|
|
|
|
|
|
) or return; |
32
|
14
|
|
|
|
|
176
|
WWW::PGXN::Distribution->new($self, $data); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub get_extension { |
36
|
2
|
|
|
2
|
1
|
537
|
my ($self, $ext) = @_; |
37
|
2
|
100
|
|
|
|
14
|
my $data = $self->_fetch_json(extension => { extension => lc $ext }) |
38
|
|
|
|
|
|
|
or return; |
39
|
1
|
|
|
|
|
18
|
WWW::PGXN::Extension->new($self, $data); |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub get_user { |
43
|
2
|
|
|
2
|
1
|
488
|
my ($self, $user) = @_; |
44
|
2
|
100
|
|
|
|
12
|
my $data = $self->_fetch_json(user => { user => lc $user }) or return; |
45
|
1
|
|
|
|
|
15
|
WWW::PGXN::User->new($data); |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub get_tag { |
49
|
2
|
|
|
2
|
1
|
501
|
my ($self, $tag) = @_; |
50
|
2
|
100
|
|
|
|
13
|
my $data = $self->_fetch_json(tag => { tag => lc $tag }) or return; |
51
|
1
|
|
|
|
|
17
|
WWW::PGXN::Tag->new($data); |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub get_stats { |
55
|
2
|
|
|
2
|
1
|
787
|
my ($self, $name) = @_; |
56
|
2
|
100
|
|
|
|
12
|
my $data = $self->_fetch_json(stats => { stats => lc $name }) or return; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub get_userlist { |
60
|
3
|
|
|
3
|
1
|
462
|
my ($self, $letter) = @_; |
61
|
3
|
100
|
|
|
|
10
|
return undef unless $self->_uri_templates->{userlist}; |
62
|
2
|
|
100
|
|
|
23
|
return $self->_fetch_json(userlist => { letter => lc $letter }) || []; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
my %valid_in = ( map { $_ => undef } qw(docs dists extensions users tags)); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
sub search { |
68
|
12
|
|
|
12
|
1
|
30439
|
my ($self, %params) = @_; |
69
|
12
|
|
|
|
|
32
|
my $url = $self->url; |
70
|
12
|
100
|
|
|
|
390
|
my $in = delete $params{in} |
71
|
|
|
|
|
|
|
or croak 'Missing required "in" parameter to search()'; |
72
|
|
|
|
|
|
|
|
73
|
5
|
|
|
|
|
103
|
croak qq{Invalid "in" parameter to search(); Must be one of:\n} |
74
|
11
|
100
|
|
|
|
45
|
. join("\n", map { "* $_" } sort keys %valid_in) |
75
|
|
|
|
|
|
|
unless exists $valid_in{$in}; |
76
|
|
|
|
|
|
|
|
77
|
10
|
100
|
|
|
|
38
|
if ($url->scheme eq 'file') { |
78
|
|
|
|
|
|
|
# Fetch it via PGXN::API::Searcher. |
79
|
5
|
|
66
|
|
|
163
|
my $searcher = $self->{_searcher} ||= PGXN::API::Searcher->new( |
80
|
|
|
|
|
|
|
File::Spec->catdir($url->path_segments) |
81
|
|
|
|
|
|
|
); |
82
|
5
|
|
|
|
|
85
|
return $searcher->search(in => $in, %params); |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
5
|
|
|
|
|
268
|
my $qurl = $self->_url_for(search => { in => $in }); |
86
|
15
|
|
|
|
|
65
|
$qurl->query_form({ |
87
|
5
|
|
|
|
|
1626
|
map { substr($_, 0, 1) => $params{$_} } keys %params |
88
|
|
|
|
|
|
|
}); |
89
|
5
|
50
|
|
|
|
826
|
my $res = $self->_fetch($qurl) or return; |
90
|
5
|
|
|
|
|
269
|
return JSON->new->utf8->decode($res->{content}); |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
sub mirrors { |
94
|
1
|
|
|
1
|
1
|
871
|
my $self = shift; |
95
|
1
|
|
33
|
|
|
2
|
return @{ $self->{mirrors} ||= do { |
|
1
|
|
|
|
|
9
|
|
96
|
1
|
|
|
|
|
4
|
my $mirrors = $self->_fetch_json('mirrors'); |
97
|
1
|
|
|
|
|
4
|
[ map { WWW::PGXN::Mirror->new($_) } @{ $mirrors } ]; |
|
2
|
|
|
|
|
13
|
|
|
1
|
|
|
|
|
41
|
|
98
|
|
|
|
|
|
|
} }; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub spec { |
102
|
3
|
|
|
3
|
1
|
483
|
my ($self, $format) = @_; |
103
|
3
|
|
100
|
|
|
12
|
$format ||= 'txt'; |
104
|
3
|
50
|
|
|
|
8
|
my $res = $self->_fetch( |
105
|
|
|
|
|
|
|
$self->_url_for('spec' => { format => $format }) |
106
|
|
|
|
|
|
|
) or return; |
107
|
3
|
|
|
|
|
14
|
utf8::decode $res->{content}; |
108
|
3
|
|
|
|
|
16
|
return $res->{content}; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub url { |
112
|
106
|
|
|
106
|
1
|
4314
|
my $self = shift; |
113
|
106
|
100
|
|
|
|
598
|
return $self->{url} unless @_; |
114
|
13
|
|
|
|
|
90
|
(my $url = shift) =~ s{/+$}{}g; |
115
|
13
|
|
|
|
|
123
|
$self->{url} = URI->new($url); |
116
|
13
|
100
|
|
|
|
38545
|
require PGXN::API::Searcher if $self->{url}->scheme eq 'file'; |
117
|
13
|
|
|
|
|
11154
|
delete $self->{_req}; |
118
|
13
|
|
|
|
|
38
|
delete $self->{_searcher}; |
119
|
13
|
|
|
|
|
131
|
$self->{url}; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub proxy { |
123
|
2
|
|
|
2
|
1
|
33
|
my $self = shift; |
124
|
2
|
50
|
|
|
|
19
|
return $self->{proxy} unless @_; |
125
|
0
|
|
|
|
|
0
|
$self->{proxy} = shift; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
BEGIN { |
129
|
9
|
|
|
9
|
|
29
|
for my $thing (qw(meta download source)) { |
130
|
9
|
|
|
9
|
|
64
|
no strict 'refs'; |
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
1647
|
|
131
|
27
|
|
|
|
|
128
|
*{"$thing\_url_for"} = sub { |
132
|
3
|
|
|
3
|
|
1733
|
$_[0]->_url_for( $thing => { dist => lc $_[1], version => lc $_[2] }); |
133
|
27
|
|
|
|
|
86
|
}; |
134
|
27
|
|
|
|
|
126
|
*{"$thing\_path_for"} = sub { |
135
|
3
|
|
|
3
|
|
15758
|
$_[0]->_path_for( $thing => { dist => lc $_[1], version => lc $_[2] }); |
136
|
27
|
|
|
|
|
81
|
}; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
9
|
|
|
|
|
23
|
for my $thing (qw(tag extension user)) { |
140
|
9
|
|
|
9
|
|
54
|
no strict 'refs'; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
957
|
|
141
|
27
|
|
|
|
|
131
|
*{"$thing\_url_for"} = sub { |
142
|
3
|
|
|
3
|
|
1644
|
$_[0]->_url_for( $thing => { $thing => lc $_[1] }); |
143
|
27
|
|
|
|
|
71
|
}; |
144
|
27
|
|
|
|
|
9385
|
*{"$thing\_path_for"} = sub { |
145
|
3
|
|
|
3
|
|
1263
|
$_[0]->_path_for( $thing => { $thing => lc $_[1] }); |
146
|
27
|
|
|
|
|
79
|
}; |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
sub html_doc_path_for { |
151
|
2
|
|
|
2
|
1
|
417
|
my ($self, $dist, $version, $path) = @_; |
152
|
2
|
|
|
|
|
16
|
$self->_path_for(htmldoc => { |
153
|
|
|
|
|
|
|
dist => lc $dist, |
154
|
|
|
|
|
|
|
version => lc $version, |
155
|
|
|
|
|
|
|
docpath => $path, |
156
|
|
|
|
|
|
|
}); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub html_doc_url_for { |
160
|
1
|
|
|
1
|
1
|
516
|
my $self = shift; |
161
|
1
|
|
|
|
|
4
|
return URI->new($self->url . $self->html_doc_path_for(@_)); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
sub _uri_templates { |
165
|
79
|
|
|
79
|
|
914
|
my $self = shift; |
166
|
79
|
|
100
|
|
|
744
|
return $self->{uri_templates} ||= { do { |
167
|
9
|
|
|
|
|
38
|
my $req = $self->_request; |
168
|
9
|
|
|
|
|
45
|
my $url = URI->new($self->url . '/index.json'); |
169
|
9
|
|
|
|
|
435
|
my $res = $req->get($url); |
170
|
9
|
100
|
|
|
|
48
|
croak "Request for $url failed: $res->{status}: $res->{reason}\n" |
171
|
|
|
|
|
|
|
unless $res->{success}; |
172
|
8
|
|
|
|
|
350
|
my $tmpl = JSON->new->utf8->decode($res->{content}); |
173
|
8
|
|
|
|
|
70
|
map { $_ => URI::Template->new($tmpl->{$_}) } keys %{ $tmpl }; |
|
96
|
|
|
|
|
8969
|
|
|
8
|
|
|
|
|
50
|
|
174
|
|
|
|
|
|
|
}}; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub _path_for { |
178
|
63
|
|
|
63
|
|
122
|
my ($self, $name, $vars) = @_; |
179
|
63
|
100
|
|
|
|
158
|
my $tmpl = $self->_uri_templates->{$name} |
180
|
|
|
|
|
|
|
or croak qq{No URI template named "$name"}; |
181
|
62
|
|
|
|
|
1551
|
return $tmpl->process($vars); |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
sub _url_for { |
185
|
54
|
|
|
54
|
|
17836
|
my $self = shift; |
186
|
54
|
|
|
|
|
172
|
return URI->new($self->url . $self->_path_for(@_)); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub _request { |
190
|
53
|
|
|
53
|
|
95
|
my $self = shift; |
191
|
53
|
100
|
66
|
|
|
318
|
$self->{_req} ||= $self->url =~ m{^file:} ? WWW::PGXN::FileReq->new : HTTP::Tiny->new( |
192
|
|
|
|
|
|
|
agent => __PACKAGE__ . '/' . __PACKAGE__->VERSION, |
193
|
|
|
|
|
|
|
proxy => $self->proxy, |
194
|
|
|
|
|
|
|
); |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub _fetch { |
198
|
42
|
|
|
42
|
|
9387
|
my ($self, $url) = @_; |
199
|
42
|
|
|
|
|
121
|
my $res = $self->_request->get($url); |
200
|
42
|
100
|
|
|
|
262
|
return $res if $res->{success}; |
201
|
6
|
50
|
|
|
|
107
|
return if $res->{status} == 404; |
202
|
0
|
|
|
|
|
0
|
croak "Request for $url failed: $res->{status}: $res->{reason}\n"; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
sub _fetch_json { |
206
|
32
|
|
|
32
|
|
58
|
my $self = shift; |
207
|
32
|
100
|
|
|
|
105
|
my $res = $self->_fetch($self->_url_for(@_)) or return; |
208
|
26
|
|
|
|
|
1159
|
return JSON->new->utf8->decode($res->{content}); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub _download_to { |
212
|
5
|
|
|
5
|
|
12
|
my ($self, $file) = (shift, shift); |
213
|
5
|
|
|
|
|
24
|
my $url = $self->_url_for(download => @_); |
214
|
5
|
|
|
|
|
3067
|
my $res = $self->_fetch($url); |
215
|
5
|
100
|
|
|
|
67
|
if (-e $file) { |
216
|
2
|
50
|
|
|
|
31
|
if (-d $file) { |
217
|
2
|
|
|
|
|
13
|
my @seg = $url->path_segments; |
218
|
2
|
|
|
|
|
179
|
$file = File::Spec->catfile($file, $seg[-1]); |
219
|
|
|
|
|
|
|
} else { |
220
|
0
|
|
|
|
|
0
|
croak "$file already exists"; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
5
|
50
|
|
|
|
34253
|
open my $fh, '>:raw', $file or die "Cannot open $file: $!\n"; |
225
|
5
|
|
|
|
|
53
|
print $fh $res->{content}; |
226
|
5
|
50
|
|
|
|
685
|
close $fh or die "Cannot close $file: $!\n"; |
227
|
5
|
|
|
|
|
113
|
return $file; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
package |
231
|
|
|
|
|
|
|
WWW::PGXN::FileReq; |
232
|
|
|
|
|
|
|
|
233
|
9
|
|
|
9
|
|
69
|
use strict; |
|
9
|
|
|
|
|
18
|
|
|
9
|
|
|
|
|
368
|
|
234
|
9
|
|
|
9
|
|
10371
|
use URI::file (); |
|
9
|
|
|
|
|
73847
|
|
|
9
|
|
|
|
|
243
|
|
235
|
9
|
|
|
9
|
|
116
|
use File::Spec (); |
|
9
|
|
|
|
|
20
|
|
|
9
|
|
|
|
|
148
|
|
236
|
9
|
|
|
9
|
|
54
|
use URI::Escape (); |
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
1660
|
|
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub new { |
239
|
10
|
|
|
10
|
|
239
|
bless {} => shift; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub get { |
243
|
53
|
|
|
53
|
|
188
|
my $self = shift; |
244
|
53
|
|
|
|
|
265
|
my $file = File::Spec->catfile(shift->path_segments); |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
return { |
247
|
53
|
100
|
|
|
|
5082
|
success => 0, |
248
|
|
|
|
|
|
|
status => 404, |
249
|
|
|
|
|
|
|
reason => 'not found', |
250
|
|
|
|
|
|
|
headers => {}, |
251
|
|
|
|
|
|
|
} unless -e $file; |
252
|
|
|
|
|
|
|
|
253
|
45
|
50
|
|
|
|
2360
|
open my $fh, '<:raw', $file or return { |
254
|
|
|
|
|
|
|
success => 0, |
255
|
|
|
|
|
|
|
status => 500, |
256
|
|
|
|
|
|
|
reason => $!, |
257
|
|
|
|
|
|
|
headers => {}, |
258
|
|
|
|
|
|
|
}; |
259
|
|
|
|
|
|
|
|
260
|
45
|
|
|
|
|
193
|
local $/; |
261
|
|
|
|
|
|
|
return { |
262
|
45
|
|
50
|
|
|
3221
|
success => 1, |
263
|
|
|
|
|
|
|
status => 200, |
264
|
|
|
|
|
|
|
reason => 'OK', |
265
|
|
|
|
|
|
|
content => <$fh> || undef, |
266
|
|
|
|
|
|
|
headers => {}, |
267
|
|
|
|
|
|
|
}; |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
1; |
271
|
|
|
|
|
|
|
__END__ |