line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::GitHub::V3::Query; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
our $VERSION = '1.03'; |
4
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:FAYLAND'; |
5
|
|
|
|
|
|
|
|
6
|
1
|
|
|
1
|
|
8597
|
use URI; |
|
1
|
|
|
|
|
2371
|
|
|
1
|
|
|
|
|
26
|
|
7
|
1
|
|
|
1
|
|
377
|
use JSON::MaybeXS; |
|
1
|
|
|
|
|
4875
|
|
|
1
|
|
|
|
|
56
|
|
8
|
1
|
|
|
1
|
|
444
|
use MIME::Base64; |
|
1
|
|
|
|
|
500
|
|
|
1
|
|
|
|
|
48
|
|
9
|
1
|
|
|
1
|
|
570
|
use LWP::UserAgent; |
|
1
|
|
|
|
|
33966
|
|
|
1
|
|
|
|
|
36
|
|
10
|
1
|
|
|
1
|
|
7
|
use HTTP::Request; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
23
|
|
11
|
1
|
|
|
1
|
|
4
|
use Carp qw/croak/; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
40
|
|
12
|
1
|
|
|
1
|
|
5
|
use URI::Escape; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
47
|
|
13
|
1
|
|
|
1
|
|
5
|
use Types::Standard qw(Int Str Bool InstanceOf Object HashRef); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
9
|
|
14
|
1
|
|
|
1
|
|
1731
|
use Cache::LRU; |
|
1
|
|
|
|
|
567
|
|
|
1
|
|
|
|
|
29
|
|
15
|
|
|
|
|
|
|
|
16
|
1
|
|
|
1
|
|
6
|
use Scalar::Util qw(looks_like_number); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
41
|
|
17
|
|
|
|
|
|
|
|
18
|
1
|
|
|
1
|
|
423
|
use Net::GitHub::V3::ResultSet; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
26
|
|
19
|
|
|
|
|
|
|
|
20
|
1
|
|
|
1
|
|
9
|
use Moo::Role; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
5
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
# configurable args |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# Authentication |
25
|
|
|
|
|
|
|
has 'login' => ( is => 'rw', isa => Str, predicate => 'has_login' ); |
26
|
|
|
|
|
|
|
has 'pass' => ( is => 'rw', isa => Str, predicate => 'has_pass' ); |
27
|
|
|
|
|
|
|
has 'otp' => ( is => 'rw', isa => Str, predicate => 'has_otp' ); |
28
|
|
|
|
|
|
|
has 'access_token' => ( is => 'rw', isa => Str, predicate => 'has_access_token' ); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
# return raw unparsed JSON |
31
|
|
|
|
|
|
|
has 'raw_string' => (is => 'rw', isa => Bool, default => 0); |
32
|
|
|
|
|
|
|
has 'raw_response' => (is => 'rw', isa => Bool, default => 0); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
has 'api_url' => (is => 'ro', default => 'https://api.github.com'); |
35
|
|
|
|
|
|
|
has 'api_throttle' => ( is => 'rw', isa => Bool, default => 1 ); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
has 'upload_url' => (is => 'ro', default => 'https://uploads.github.com'); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# pagination |
40
|
|
|
|
|
|
|
has 'next_url' => ( is => 'rw', isa => Str, predicate => 'has_next_page', clearer => 'clear_next_url' ); |
41
|
|
|
|
|
|
|
has 'last_url' => ( is => 'rw', isa => Str, predicate => 'has_last_page', clearer => 'clear_last_url' ); |
42
|
|
|
|
|
|
|
has 'first_url' => ( is => 'rw', isa => Str, predicate => 'has_first_page', clearer => 'clear_first_url' ); |
43
|
|
|
|
|
|
|
has 'prev_url' => ( is => 'rw', isa => Str, predicate => 'has_prev_page', clearer => 'clear_prev_url' ); |
44
|
|
|
|
|
|
|
has 'per_page' => ( is => 'rw', isa => Str, default => 100 ); |
45
|
|
|
|
|
|
|
has 'total_pages' => ( is => 'rw', isa => Str, default => 0 ); |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# deprecation |
48
|
|
|
|
|
|
|
has 'deprecation_url' => ( is => 'rw', isa => Str ); |
49
|
|
|
|
|
|
|
has 'alternate_url' => ( is => 'rw', isa => Str ); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# Error handle |
52
|
|
|
|
|
|
|
has 'RaiseError' => ( is => 'rw', isa => Bool, default => 1 ); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# Rate limits |
55
|
|
|
|
|
|
|
# has 'rate_limit' => ( is => 'rw', isa => Int, default => sub { shift->update_rate_limit('rate_limit') } ); |
56
|
|
|
|
|
|
|
# has 'rate_limit_remaining' => ( is => 'rw', isa => Int, default => sub { shift->update_rate_limit('rate_limit_remaining') } ); |
57
|
|
|
|
|
|
|
# has 'rate_limit_reset' => ( is => 'rw', isa => Str, default => sub { shift->update_rate_limit('rate_limit_reset') } ); |
58
|
|
|
|
|
|
|
has 'rate_limit' => ( is => 'rw', isa => Int, default => sub { 0 } ); |
59
|
|
|
|
|
|
|
has 'rate_limit_remaining' => ( is => 'rw', isa => Int, default => sub { 0 } ); |
60
|
|
|
|
|
|
|
has 'rate_limit_reset' => ( is => 'rw', isa => Str, default => sub { 0 } ); |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# optional |
63
|
|
|
|
|
|
|
has 'u' => (is => 'rw', isa => Str); |
64
|
|
|
|
|
|
|
has 'repo' => (is => 'rw', isa => Str); |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# accept version |
67
|
|
|
|
|
|
|
has 'accept_version' => (is => 'rw', isa => Str, default => ''); |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
has 'is_main_module' => (is => 'ro', isa => Bool, default => 0); |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub update_rate_limit { |
72
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $what ) = @_; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# If someone calls rate_limit before an API query happens, force these fields to update before giving back a response. |
75
|
|
|
|
|
|
|
# Per github: Accessing this endpoint does not count against your REST API rate limit. |
76
|
|
|
|
|
|
|
# https://developer.github.com/v3/rate_limit/ |
77
|
0
|
|
|
|
|
0
|
my $content = $self->query('/rate_limit'); |
78
|
|
|
|
|
|
|
|
79
|
0
|
|
|
|
|
0
|
return $self->{$what}; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub set_default_user_repo { |
83
|
0
|
|
|
0
|
0
|
0
|
my ($self, $user, $repo) = @_; |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
|
|
|
0
|
$self->u($user); |
86
|
0
|
|
|
|
|
0
|
$self->repo($repo); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# need apply to all sub modules |
89
|
0
|
0
|
|
|
|
0
|
if ($self->is_main_module) { |
90
|
0
|
0
|
|
|
|
0
|
if ($self->is_repos_init) { |
91
|
0
|
|
|
|
|
0
|
$self->repos->u($user); $self->repos->repo($repo); |
|
0
|
|
|
|
|
0
|
|
92
|
|
|
|
|
|
|
} |
93
|
0
|
0
|
|
|
|
0
|
if ($self->is_issue_init) { |
94
|
0
|
|
|
|
|
0
|
$self->issue->u($user); $self->issue->repo($repo); |
|
0
|
|
|
|
|
0
|
|
95
|
|
|
|
|
|
|
} |
96
|
0
|
0
|
|
|
|
0
|
if ($self->is_pull_request_init) { |
97
|
0
|
|
|
|
|
0
|
$self->pull_request->u($user); $self->pull_request->repo($repo); |
|
0
|
|
|
|
|
0
|
|
98
|
|
|
|
|
|
|
} |
99
|
0
|
0
|
|
|
|
0
|
if ($self->is_git_data_init) { |
100
|
0
|
|
|
|
|
0
|
$self->git_data->u($user); $self->git_data->repo($repo); |
|
0
|
|
|
|
|
0
|
|
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
0
|
|
|
|
|
0
|
return $self; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub args_to_pass { |
108
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
109
|
0
|
|
|
|
|
0
|
my $ret; |
110
|
0
|
|
|
|
|
0
|
foreach my $col ('login', 'pass', 'otp', 'access_token', 'raw_string', 'raw_response', 'api_url', 'api_throttle', 'u', 'repo', 'next_url', 'last_url', 'first_url', 'prev_url', 'per_page', 'ua') { |
111
|
0
|
|
|
|
|
0
|
my $v = $self->$col; |
112
|
0
|
0
|
|
|
|
0
|
$ret->{$col} = $v if defined $v; |
113
|
|
|
|
|
|
|
} |
114
|
0
|
|
|
|
|
0
|
return $ret; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
has 'ua' => ( |
118
|
|
|
|
|
|
|
isa => InstanceOf['LWP::UserAgent'], |
119
|
|
|
|
|
|
|
is => 'ro', |
120
|
|
|
|
|
|
|
lazy => 1, |
121
|
|
|
|
|
|
|
default => sub { |
122
|
|
|
|
|
|
|
LWP::UserAgent->new( |
123
|
|
|
|
|
|
|
agent => "perl-net-github/$VERSION", |
124
|
|
|
|
|
|
|
cookie_jar => {}, |
125
|
|
|
|
|
|
|
keep_alive => 4, |
126
|
|
|
|
|
|
|
timeout => 60, |
127
|
|
|
|
|
|
|
); |
128
|
|
|
|
|
|
|
}, |
129
|
|
|
|
|
|
|
); |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
has 'json' => ( |
132
|
|
|
|
|
|
|
is => 'ro', |
133
|
|
|
|
|
|
|
isa => Object, # InstanceOf['JSON::MaybeXS'], |
134
|
|
|
|
|
|
|
lazy => 1, |
135
|
|
|
|
|
|
|
default => sub { |
136
|
|
|
|
|
|
|
return JSON::MaybeXS->new( utf8 => 1 ); |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
); |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
has 'cache' => ( |
141
|
|
|
|
|
|
|
isa => InstanceOf['Cache::LRU'], |
142
|
|
|
|
|
|
|
is => 'rw', |
143
|
|
|
|
|
|
|
lazy => 1, |
144
|
|
|
|
|
|
|
default => sub { |
145
|
|
|
|
|
|
|
Cache::LRU->new( |
146
|
|
|
|
|
|
|
size => 200 |
147
|
|
|
|
|
|
|
); |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
); |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# per-page pagination |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
has 'result_sets' => ( |
154
|
|
|
|
|
|
|
isa => HashRef, |
155
|
|
|
|
|
|
|
is => 'ro', |
156
|
|
|
|
|
|
|
default => sub { {} }, |
157
|
|
|
|
|
|
|
); |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub next { |
160
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
161
|
0
|
|
|
|
|
0
|
my ($url) = @_; |
162
|
0
|
|
|
|
|
0
|
my $result_set; |
163
|
0
|
0
|
|
|
|
0
|
$result_set = $self->result_sets->{$url} or do { |
164
|
0
|
|
|
|
|
0
|
$result_set = Net::GitHub::V3::ResultSet->new( url => $url ); |
165
|
0
|
|
|
|
|
0
|
$self->result_sets->{$url} = $result_set; |
166
|
|
|
|
|
|
|
}; |
167
|
0
|
|
|
|
|
0
|
my $results = $result_set->results; |
168
|
0
|
|
|
|
|
0
|
my $cursor = $result_set->cursor; |
169
|
0
|
0
|
|
|
|
0
|
if ( $cursor > $#$results ) { |
170
|
0
|
0
|
|
|
|
0
|
return if $result_set->done; |
171
|
0
|
|
0
|
|
|
0
|
my $next_url = $result_set->next_url || $result_set->url; |
172
|
0
|
|
|
|
|
0
|
my $new_result = $self->query($next_url); |
173
|
0
|
0
|
|
|
|
0
|
$result_set->results(ref $new_result eq 'ARRAY' ? |
174
|
|
|
|
|
|
|
$new_result : |
175
|
|
|
|
|
|
|
[$new_result] |
176
|
|
|
|
|
|
|
); |
177
|
0
|
|
|
|
|
0
|
$result_set->cursor(0); |
178
|
0
|
0
|
|
|
|
0
|
if ($self->has_next_page) { |
179
|
0
|
|
|
|
|
0
|
$result_set->next_url($self->next_url); |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
else { |
182
|
0
|
|
|
|
|
0
|
$result_set->done(1); |
183
|
|
|
|
|
|
|
} |
184
|
|
|
|
|
|
|
} |
185
|
0
|
|
|
|
|
0
|
my $result = $result_set->results->[$result_set->cursor]; |
186
|
0
|
|
|
|
|
0
|
$result_set->cursor($result_set->cursor + 1); |
187
|
0
|
|
|
|
|
0
|
return $result; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
sub close { |
192
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
193
|
0
|
|
|
|
|
0
|
my ($url) = @_; |
194
|
0
|
|
|
|
|
0
|
delete $self->result_sets->{$url}; |
195
|
0
|
|
|
|
|
0
|
return; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
sub query { |
200
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# fix ARGV, not sure if it's the good idea |
203
|
0
|
|
|
|
|
0
|
my @args = @_; |
204
|
0
|
0
|
0
|
|
|
0
|
if (@args == 1) { |
|
|
0
|
|
|
|
|
|
205
|
0
|
|
|
|
|
0
|
unshift @args, 'GET'; # method by default |
206
|
0
|
|
|
|
|
0
|
} elsif (@args > 1 and not (grep { $args[0] eq $_ } ('GET', 'POST', 'PUT', 'PATCH', 'HEAD', 'DELETE')) ) { |
207
|
0
|
|
|
|
|
0
|
unshift @args, 'POST'; # if POST content |
208
|
|
|
|
|
|
|
} |
209
|
0
|
|
|
|
|
0
|
my $request_method = shift @args; |
210
|
0
|
|
|
|
|
0
|
my $url = shift @args; |
211
|
0
|
|
|
|
|
0
|
my $data = shift @args; |
212
|
|
|
|
|
|
|
|
213
|
0
|
|
|
|
|
0
|
my $ua = $self->ua; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
## always go with login:pass or access_token (for private repos) |
216
|
0
|
0
|
0
|
|
|
0
|
if ($self->has_access_token) { |
|
|
0
|
|
|
|
|
|
217
|
0
|
|
|
|
|
0
|
$ua->default_header('Authorization', "token " . $self->access_token); |
218
|
|
|
|
|
|
|
} elsif ($self->has_login and $self->has_pass) { |
219
|
0
|
|
|
|
|
0
|
my $auth_basic = $self->login . ':' . $self->pass; |
220
|
0
|
|
|
|
|
0
|
$ua->default_header('Authorization', 'Basic ' . encode_base64($auth_basic)); |
221
|
0
|
0
|
|
|
|
0
|
if ($self->has_otp) { |
222
|
0
|
|
|
|
|
0
|
$ua->default_header('X-GitHub-OTP', $self->otp); |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
0
|
0
|
|
|
|
0
|
$url = $self->api_url . $url unless $url =~ /^https\:/; |
227
|
0
|
0
|
|
|
|
0
|
if ($request_method eq 'GET') { |
228
|
0
|
0
|
|
|
|
0
|
if ($url !~ /per_page=\d/) { |
229
|
|
|
|
|
|
|
## auto add per_page in url for GET no matter it supports or not |
230
|
0
|
|
|
|
|
0
|
my $uri = URI->new($url); |
231
|
0
|
|
|
|
|
0
|
my %query_form = $uri->query_form; |
232
|
0
|
|
0
|
|
|
0
|
$query_form{per_page} ||= $self->per_page; |
233
|
0
|
|
|
|
|
0
|
$uri->query_form(%query_form); |
234
|
0
|
|
|
|
|
0
|
$url = $uri->as_string; |
235
|
|
|
|
|
|
|
} |
236
|
0
|
0
|
0
|
|
|
0
|
if ($data and ref $data eq 'HASH') { |
237
|
0
|
|
|
|
|
0
|
my $uri = URI->new($url); |
238
|
0
|
|
|
|
|
0
|
my %query_form = $uri->query_form; |
239
|
0
|
|
|
|
|
0
|
$uri->query_form(%$data); |
240
|
0
|
|
|
|
|
0
|
$url = $uri->as_string; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
|
|
244
|
0
|
0
|
|
|
|
0
|
print STDERR ">>> $request_method $url\n" if $ENV{NG_DEBUG}; |
245
|
0
|
|
|
|
|
0
|
my $req = HTTP::Request->new( $request_method, $url ); |
246
|
0
|
|
|
|
|
0
|
$req->accept_decodable; |
247
|
0
|
0
|
0
|
|
|
0
|
if ($request_method ne 'GET' and $data) { |
248
|
0
|
|
|
|
|
0
|
my $json = $self->json->encode($data); |
249
|
0
|
0
|
0
|
|
|
0
|
print STDERR ">>> $json\n" if $ENV{NG_DEBUG} and $ENV{NG_DEBUG} > 1; |
250
|
0
|
|
|
|
|
0
|
$req->content($json); |
251
|
|
|
|
|
|
|
} |
252
|
0
|
|
|
|
|
0
|
$req->header( 'Content-Length' => length $req->content ); |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# if preview API, specify a custom media type to Accept header |
255
|
|
|
|
|
|
|
# https://developer.github.com/v3/media/ |
256
|
0
|
0
|
|
|
|
0
|
$req->header( 'Accept' => sprintf("application/vnd.github.%s.param+json", $self->accept_version) ) |
257
|
|
|
|
|
|
|
if $self->accept_version; |
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
|
|
0
|
my $res = $self->_make_request($req); |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
# get the rate limit information from the http response headers |
262
|
0
|
|
|
|
|
0
|
$self->rate_limit( $res->header('x-ratelimit-limit') ); |
263
|
0
|
|
|
|
|
0
|
$self->rate_limit_remaining( $res->header('x-ratelimit-remaining') ); |
264
|
0
|
|
|
|
|
0
|
$self->rate_limit_reset( $res->header('x-ratelimit-reset') ); |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
# Slow down if we're approaching the rate limit |
267
|
|
|
|
|
|
|
# By the way GitHub mistakes days for minutes in their documentation -- |
268
|
|
|
|
|
|
|
# the rate limit is per minute, not per day. |
269
|
0
|
0
|
|
|
|
0
|
if ( $self->api_throttle ) { |
270
|
0
|
0
|
0
|
|
|
0
|
sleep 2 if (($self->rate_limit_remaining || 0) |
|
|
|
0
|
|
|
|
|
271
|
|
|
|
|
|
|
< ($self->rate_limit || 60) / 2); |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
0
|
0
|
0
|
|
|
0
|
print STDERR "<<< " . $res->decoded_content . "\n" if $ENV{NG_DEBUG} and $ENV{NG_DEBUG} > 1; |
275
|
0
|
0
|
|
|
|
0
|
return $res if $self->raw_response; |
276
|
0
|
0
|
|
|
|
0
|
return $res->decoded_content if $self->raw_string; |
277
|
|
|
|
|
|
|
|
278
|
0
|
0
|
0
|
|
|
0
|
if ($res->header('Content-Type') and $res->header('Content-Type') =~ 'application/json') { |
279
|
0
|
|
|
|
|
0
|
my $json = $res->decoded_content; |
280
|
0
|
|
|
|
|
0
|
$data = eval { $self->json->decode($json) }; |
|
0
|
|
|
|
|
0
|
|
281
|
0
|
0
|
|
|
|
0
|
unless ($data) { |
282
|
|
|
|
|
|
|
# We tolerate bad JSON for errors, |
283
|
|
|
|
|
|
|
# otherwise we just rethrow the JSON parsing problem. |
284
|
0
|
0
|
|
|
|
0
|
die unless $res->is_error; |
285
|
0
|
|
|
|
|
0
|
$data = { message => $res->message }; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
} else { |
288
|
0
|
|
|
|
|
0
|
$data = { message => $res->message }; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
0
|
0
|
|
|
|
0
|
if ( $self->RaiseError ) { |
292
|
|
|
|
|
|
|
# check for 'Client Errors' |
293
|
0
|
0
|
0
|
|
|
0
|
if (not $res->is_success and ref $data eq 'HASH' and exists $data->{message}) { |
|
|
|
0
|
|
|
|
|
294
|
0
|
|
|
|
|
0
|
my $message = $data->{message}; |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
# Include any additional error information that was returned by the API |
297
|
0
|
0
|
|
|
|
0
|
if (exists $data->{errors}) { |
298
|
|
|
|
|
|
|
$message .= ': '.join(' - ', |
299
|
0
|
|
|
|
|
0
|
map { $_->{message} } |
300
|
0
|
|
|
|
|
0
|
grep { exists $_->{message} } |
301
|
0
|
|
|
|
|
0
|
@{ $data->{errors} }); |
|
0
|
|
|
|
|
0
|
|
302
|
|
|
|
|
|
|
} |
303
|
0
|
|
|
|
|
0
|
croak $message; |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
|
307
|
0
|
|
|
|
|
0
|
$self->_clear_pagination; |
308
|
0
|
0
|
|
|
|
0
|
if ($res->header('link')) { |
309
|
0
|
|
|
|
|
0
|
my @rel_strs = split ',', $res->header('link'); |
310
|
0
|
|
|
|
|
0
|
$self->_extract_link_url(\@rel_strs); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
## be smarter |
314
|
0
|
0
|
|
|
|
0
|
if (wantarray) { |
315
|
0
|
0
|
|
|
|
0
|
return @$data if ref $data eq 'ARRAY'; |
316
|
0
|
0
|
|
|
|
0
|
return %$data if ref $data eq 'HASH'; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
0
|
|
|
|
|
0
|
return $data; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
sub set_next_page { |
323
|
0
|
|
|
0
|
1
|
0
|
my ($self, $page) = @_; |
324
|
|
|
|
|
|
|
|
325
|
0
|
0
|
|
|
|
0
|
if( ! looks_like_number($page) ){ |
326
|
0
|
|
|
|
|
0
|
croak "Trying to set_next_page to $page, and not a number\n"; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
0
|
0
|
0
|
|
|
0
|
if( $page > $self->total_page && $page > 0 ){ |
330
|
0
|
|
|
|
|
0
|
return 0; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
0
|
|
|
|
|
0
|
my $temp_url = $self->next_url; |
334
|
0
|
|
|
|
|
0
|
$temp_url =~ s/([&?])page=[0-9]+([&?]*)/$1page=$page$2/; |
335
|
|
|
|
|
|
|
|
336
|
0
|
|
|
|
|
0
|
$self->next_url( $temp_url ); |
337
|
|
|
|
|
|
|
|
338
|
0
|
|
|
|
|
0
|
return 1; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub next_page { |
342
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
343
|
0
|
|
|
|
|
0
|
return $self->query($self->next_url); |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
sub prev_page { |
347
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
348
|
0
|
|
|
|
|
0
|
return $self->query($self->prev_url); |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
sub first_page { |
352
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
353
|
0
|
|
|
|
|
0
|
return $self->query($self->first_url); |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
sub last_page { |
357
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
358
|
0
|
|
|
|
|
0
|
return $self->query($self->last_url); |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub _clear_pagination { |
362
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
363
|
0
|
|
|
|
|
0
|
foreach my $page (qw/first last prev next/) { |
364
|
0
|
|
|
|
|
0
|
my $clearer = 'clear_' . $page . '_url'; |
365
|
0
|
|
|
|
|
0
|
$self->$clearer; |
366
|
|
|
|
|
|
|
} |
367
|
0
|
|
|
|
|
0
|
return 1; |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
sub iterate { |
371
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $method, $args, $callback ) = @_; |
372
|
|
|
|
|
|
|
|
373
|
0
|
0
|
|
|
|
0
|
die "This is a method class" unless ref $self; |
374
|
0
|
0
|
0
|
|
|
0
|
die "Need a method name as second argument" unless defined $method && $self->can($method); |
375
|
|
|
|
|
|
|
|
376
|
0
|
0
|
|
|
|
0
|
die "Missing a callback function as third argument" unless ref $callback eq 'CODE'; |
377
|
|
|
|
|
|
|
|
378
|
0
|
|
|
|
|
0
|
my @list_args; # 3rd argument |
379
|
0
|
0
|
|
|
|
0
|
if ( ref $args eq 'ARRAY' ) { |
|
|
0
|
|
|
|
|
|
380
|
0
|
|
|
|
|
0
|
@list_args = @$args; |
381
|
|
|
|
|
|
|
} elsif ( ref $args eq 'HASH' ) { |
382
|
|
|
|
|
|
|
# used for v2 api which are passing a hash of named parameters instead of a list |
383
|
0
|
|
|
|
|
0
|
@list_args = $args; |
384
|
|
|
|
|
|
|
} else { |
385
|
0
|
|
|
|
|
0
|
@list_args = $args; # can be undefined [need to preserve it instead of an empty list] |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
0
|
|
|
|
|
0
|
my $chunk = $self->can($method)->( $self, $args ); |
389
|
|
|
|
|
|
|
|
390
|
0
|
|
|
|
|
0
|
my $continue = 1; |
391
|
0
|
|
0
|
|
|
0
|
while ( ref $chunk eq 'ARRAY' && scalar @$chunk ) { |
392
|
|
|
|
|
|
|
# process a chunk |
393
|
0
|
|
|
|
|
0
|
foreach my $item ( @$chunk ) { |
394
|
0
|
|
|
|
|
0
|
$continue = $callback->( $item ); |
395
|
0
|
0
|
|
|
|
0
|
last unless $continue; # user has requested to stop iterating |
396
|
|
|
|
|
|
|
} |
397
|
0
|
0
|
|
|
|
0
|
last unless $continue; # user has requested to stop iterating |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# get the next chunk |
400
|
0
|
0
|
|
|
|
0
|
last unless $self->has_next_page; |
401
|
0
|
|
|
|
|
0
|
$chunk = $self->next_page; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
0
|
|
|
|
|
0
|
$self->_clear_pagination; |
405
|
|
|
|
|
|
|
|
406
|
0
|
|
|
|
|
0
|
return; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
sub _extract_link_url { |
410
|
0
|
|
|
0
|
|
0
|
my ($self, $raw_strs) = @_; |
411
|
0
|
|
|
|
|
0
|
foreach my $str (@$raw_strs) { |
412
|
0
|
|
|
|
|
0
|
my ($link_url, $rel) = split ';', $str; |
413
|
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
0
|
$link_url =~ s/^\s*//; |
415
|
0
|
|
|
|
|
0
|
$link_url =~ s/^/; |
416
|
0
|
|
|
|
|
0
|
$link_url =~ s/>$//; |
417
|
|
|
|
|
|
|
|
418
|
0
|
0
|
|
|
|
0
|
if( $rel =~ m/rel="(next|last|first|prev|deprecation|alternate)"/ ){ |
|
|
0
|
|
|
|
|
|
419
|
0
|
|
|
|
|
0
|
$rel = $1; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
elsif( $rel=~ m/rel="(.*?)"/ ){ |
422
|
0
|
|
|
|
|
0
|
warn "Unexpected link rel='$1' in '$str'"; |
423
|
0
|
|
|
|
|
0
|
next; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
else { |
426
|
0
|
|
|
|
|
0
|
warn "Unable to process link rel in '$str'"; |
427
|
0
|
|
|
|
|
0
|
next; |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
0
|
0
|
|
|
|
0
|
if( $rel eq 'deprecation' ){ |
431
|
0
|
|
|
|
|
0
|
warn "Deprecation warning: $link_url\n"; |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
|
434
|
0
|
|
|
|
|
0
|
my $url_attr = $rel . "_url"; |
435
|
0
|
|
|
|
|
0
|
$self->$url_attr($link_url); |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
# Grab, and expose, some additional header information |
438
|
0
|
0
|
|
|
|
0
|
if( $rel eq "last" ){ |
439
|
0
|
|
|
|
|
0
|
$link_url =~ /[\&?]page=([0-9]*)[\&?]*/; |
440
|
0
|
|
|
|
|
0
|
$self->total_pages( $1 ); |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
|
|
444
|
0
|
|
|
|
|
0
|
return 1; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub _make_request { |
448
|
0
|
|
|
0
|
|
0
|
my($self, $req) = @_; |
449
|
|
|
|
|
|
|
|
450
|
0
|
|
|
|
|
0
|
my $cached_res = $self->_get_shared_cache($req->uri); |
451
|
|
|
|
|
|
|
|
452
|
0
|
0
|
|
|
|
0
|
if ($cached_res) { |
453
|
0
|
|
|
|
|
0
|
$req->header("If-None-Match" => $cached_res->header("ETag")); |
454
|
0
|
|
|
|
|
0
|
my $res = $self->ua->request($req); |
455
|
|
|
|
|
|
|
|
456
|
0
|
0
|
|
|
|
0
|
if ($res->code == 304) { |
457
|
0
|
|
|
|
|
0
|
return $cached_res; |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
0
|
|
|
|
|
0
|
$self->_set_shared_cache($req->uri, $res); |
461
|
|
|
|
|
|
|
|
462
|
0
|
|
|
|
|
0
|
return $res; |
463
|
|
|
|
|
|
|
} else { |
464
|
0
|
|
|
|
|
0
|
my $res = $self->ua->request($req); |
465
|
0
|
|
|
|
|
0
|
$self->_set_shared_cache( $req->uri, $res); |
466
|
0
|
|
|
|
|
0
|
return $res; |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
sub _get_shared_cache { |
471
|
0
|
|
|
0
|
|
0
|
my ($self, $uri) = @_; |
472
|
0
|
|
|
|
|
0
|
return $self->cache->get($uri); |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
sub _set_shared_cache { |
476
|
0
|
|
|
0
|
|
0
|
my($self, $uri, $response) = @_; |
477
|
0
|
|
|
|
|
0
|
$self->cache->set($uri, $response); |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
## build methods on fly |
481
|
|
|
|
|
|
|
sub __build_methods { |
482
|
10
|
|
|
10
|
|
18
|
my $package = shift; |
483
|
10
|
|
|
|
|
43
|
my %methods = @_; |
484
|
|
|
|
|
|
|
|
485
|
10
|
|
|
|
|
49
|
foreach my $m (keys %methods) { |
486
|
205
|
|
|
|
|
280
|
my $v = $methods{$m}; |
487
|
205
|
|
|
|
|
260
|
my $url = $v->{url}; |
488
|
205
|
|
100
|
|
|
382
|
my $method = $v->{method} || 'GET'; |
489
|
205
|
|
100
|
|
|
388
|
my $args = $v->{args} || 0; # args for ->query |
490
|
205
|
|
|
|
|
225
|
my $check_status = $v->{check_status}; |
491
|
205
|
|
|
|
|
220
|
my $is_u_repo = $v->{is_u_repo}; # need auto shift u/repo |
492
|
205
|
|
|
|
|
224
|
my $preview_version = $v->{preview}; |
493
|
205
|
|
|
|
|
207
|
my $paginate = $v->{paginate}; |
494
|
205
|
|
50
|
|
|
546
|
my $version = $v->{v} || $v->{version} || 1; # version for the accessor |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# count how much %s inside u |
497
|
205
|
|
|
|
|
209
|
my $n = 0; while ($url =~ /\%s/g) { $n++ } |
|
205
|
|
|
|
|
522
|
|
|
414
|
|
|
|
|
607
|
|
498
|
|
|
|
|
|
|
|
499
|
1
|
|
|
1
|
|
3052
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
41
|
|
500
|
1
|
|
|
1
|
|
5
|
no warnings 'once'; |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
235
|
|
501
|
205
|
|
|
|
|
890
|
*{"${package}::${m}"} = sub { |
502
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
503
|
|
|
|
|
|
|
|
504
|
0
|
|
|
|
|
0
|
my ( $u, @qargs ); |
505
|
|
|
|
|
|
|
|
506
|
0
|
0
|
|
|
|
0
|
if ( $version == 2 ) { |
507
|
0
|
|
|
|
|
0
|
my $opts = {}; |
508
|
0
|
0
|
|
|
|
0
|
if ( ref $_[0] ) { |
509
|
0
|
|
|
|
|
0
|
my ( $_opts, $_qargs ) = @_; |
510
|
|
|
|
|
|
|
|
511
|
0
|
|
|
|
|
0
|
$opts = $_opts; |
512
|
0
|
0
|
|
|
|
0
|
if ( my $ref = ref $_qargs ) { |
513
|
0
|
0
|
|
|
|
0
|
@qargs = @$_qargs if $ref eq 'ARRAY'; |
514
|
0
|
0
|
|
|
|
0
|
@qargs = $_qargs if $ref eq 'HASH'; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
} else { # backward compatibility |
517
|
0
|
|
|
|
|
0
|
my $u = $url; |
518
|
0
|
|
|
|
|
0
|
while ( $u =~ s{:([a-z_]+)}{} ) { |
519
|
0
|
|
|
|
|
0
|
my $k = $1; |
520
|
|
|
|
|
|
|
#next if defined $opts->{$k}; |
521
|
0
|
|
|
|
|
0
|
$opts->{$k} = shift; |
522
|
0
|
0
|
|
|
|
0
|
die "$k value is not a scalar value $opts->{$k}" if ref $opts->{$k}; |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
0
|
0
|
|
|
|
0
|
@qargs = $args ? splice(@_, 0, $args) : (); |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
# we can now use named :parameter in the url itself |
528
|
0
|
|
|
|
|
0
|
$u = "$url"; |
529
|
|
|
|
|
|
|
{ |
530
|
1
|
|
|
1
|
|
16
|
no warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
602
|
|
|
0
|
|
|
|
|
0
|
|
531
|
0
|
|
|
|
|
0
|
$u =~ s{:([a-z_]+)}{$opts->{$1}}g; |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
} else { |
534
|
|
|
|
|
|
|
## if is_u_repo, both ($user, $repo, @args) or (@args) should be supported |
535
|
0
|
0
|
0
|
|
|
0
|
if ( ($is_u_repo or index($url, '/repos/%s/%s') > -1) and @_ < $n + $args) { |
|
|
|
0
|
|
|
|
|
536
|
0
|
|
|
|
|
0
|
unshift @_, ($self->u, $self->repo); |
537
|
|
|
|
|
|
|
} |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
# make url, replace %s with real args |
540
|
0
|
|
|
|
|
0
|
my @uargs = splice(@_, 0, $n); |
541
|
0
|
|
|
|
|
0
|
$u = sprintf($url, @uargs); |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
# args for json data POST |
544
|
0
|
0
|
|
|
|
0
|
@qargs = $args ? splice(@_, 0, $args) : (); |
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# if preview API, set preview version |
548
|
0
|
0
|
|
|
|
0
|
$self->accept_version($preview_version) if $preview_version; |
549
|
|
|
|
|
|
|
|
550
|
0
|
0
|
|
|
|
0
|
if ($check_status) { # need check Response Status |
551
|
0
|
|
|
|
|
0
|
my $old_raw_response = $self->raw_response; |
552
|
0
|
|
|
|
|
0
|
$self->raw_response(1); # need check header |
553
|
0
|
|
|
|
|
0
|
my $res = $self->query($method, $u, @qargs); |
554
|
0
|
|
|
|
|
0
|
$self->raw_response($old_raw_response); |
555
|
0
|
0
|
|
|
|
0
|
return index($res->header('Status'), $check_status) > -1 ? 1 : 0; |
556
|
|
|
|
|
|
|
} else { |
557
|
0
|
|
|
|
|
0
|
return $self->query($method, $u, @qargs); |
558
|
|
|
|
|
|
|
} |
559
|
205
|
|
|
|
|
1372
|
}; |
560
|
205
|
100
|
|
|
|
520
|
if ($paginate) { |
561
|
|
|
|
|
|
|
# Add methods next... and close... |
562
|
|
|
|
|
|
|
# Make method names singular (next_comments to next_comment) |
563
|
58
|
|
|
|
|
178
|
$m =~ s/s$//; |
564
|
58
|
100
|
|
|
|
120
|
my $m_name = ref $paginate ? $paginate->{name} : $m; |
565
|
58
|
|
|
|
|
271
|
*{"${package}::next_${m_name}"} = sub { |
566
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
# count how much %s inside u |
569
|
0
|
|
|
|
|
0
|
my $n = 0; while ($url =~ /\%s/g) { $n++ } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
## if is_u_repo, both ($user, $repo, @args) or (@args) should be supported |
572
|
0
|
0
|
0
|
|
|
0
|
if ( ($is_u_repo or index($url, '/repos/%s/%s') > -1) and @_ < $n + $args) { |
|
|
|
0
|
|
|
|
|
573
|
0
|
|
|
|
|
0
|
unshift @_, ($self->u, $self->repo); |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
# make url, replace %s with real args |
577
|
0
|
0
|
|
|
|
0
|
my @uargs = map { defined $_ ? $_ : '' } splice(@_, 0, $n); |
|
0
|
|
|
|
|
0
|
|
578
|
0
|
|
|
|
|
0
|
my $u = sprintf($url, @uargs); |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
# if preview API, set preview version |
581
|
0
|
0
|
|
|
|
0
|
$self->accept_version($preview_version) if $preview_version; |
582
|
|
|
|
|
|
|
|
583
|
0
|
|
|
|
|
0
|
return $self->next($u); |
584
|
58
|
|
|
|
|
260
|
}; |
585
|
58
|
|
|
|
|
273
|
*{"${package}::close_${m_name}"} = sub { |
586
|
0
|
|
|
0
|
|
|
my $self = shift; |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
# count how much %s inside u |
589
|
0
|
|
|
|
|
|
my $n = 0; while ($url =~ /\%s/g) { $n++ } |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
## if is_u_repo, both ($user, $repo, @args) or (@args) should be supported |
592
|
0
|
0
|
0
|
|
|
|
if ( ($is_u_repo or index($url, '/repos/%s/%s') > -1) and @_ < $n + $args) { |
|
|
|
0
|
|
|
|
|
593
|
0
|
|
|
|
|
|
unshift @_, ($self->u, $self->repo); |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
# make url, replace %s with real args |
597
|
0
|
|
|
|
|
|
my @uargs = splice(@_, 0, $n); |
598
|
0
|
|
|
|
|
|
my $u = sprintf($url, @uargs); |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
# if preview API, set preview version |
601
|
0
|
0
|
|
|
|
|
$self->accept_version($preview_version) if $preview_version; |
602
|
|
|
|
|
|
|
|
603
|
0
|
|
|
|
|
|
$self->close($u); |
604
|
58
|
|
|
|
|
267
|
}; |
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
|
|
609
|
1
|
|
|
1
|
|
8
|
no Moo::Role; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
24
|
|
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
1; |
612
|
|
|
|
|
|
|
__END__ |