line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::HTTP::API::Meta::Method; |
2
|
|
|
|
|
|
|
BEGIN { |
3
|
1
|
|
|
1
|
|
25993
|
$Net::HTTP::API::Meta::Method::VERSION = '0.14'; |
4
|
|
|
|
|
|
|
} |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
# ABSTRACT: create api method |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
1471
|
use Moose; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
use Net::HTTP::API::Error; |
10
|
|
|
|
|
|
|
use Moose::Util::TypeConstraints; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
use MooseX::Types::Moose qw/Str Int ArrayRef/; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
extends 'Moose::Meta::Method'; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
subtype UriPath |
17
|
|
|
|
|
|
|
=> as 'Str' |
18
|
|
|
|
|
|
|
=> where { $_ =~ m!^/! } |
19
|
|
|
|
|
|
|
=> message {"path must start with /"}; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
enum Method => qw(HEAD GET POST PUT DELETE); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
has path => (is => 'ro', isa => 'UriPath', required => 1); |
24
|
|
|
|
|
|
|
has method => (is => 'ro', isa => 'Method', required => 1); |
25
|
|
|
|
|
|
|
has description => (is => 'ro', isa => 'Str', predicate => 'has_description'); |
26
|
|
|
|
|
|
|
has strict => (is => 'ro', isa => 'Bool', default => 1,); |
27
|
|
|
|
|
|
|
has authentication => ( |
28
|
|
|
|
|
|
|
is => 'ro', |
29
|
|
|
|
|
|
|
isa => 'Bool', |
30
|
|
|
|
|
|
|
predicate => 'has_authentication', |
31
|
|
|
|
|
|
|
default => 0 |
32
|
|
|
|
|
|
|
); |
33
|
|
|
|
|
|
|
has expected => ( |
34
|
|
|
|
|
|
|
traits => ['Array'], |
35
|
|
|
|
|
|
|
is => 'ro', |
36
|
|
|
|
|
|
|
isa => ArrayRef [Int], |
37
|
|
|
|
|
|
|
auto_deref => 1, |
38
|
|
|
|
|
|
|
required => 0, |
39
|
|
|
|
|
|
|
predicate => 'has_expected', |
40
|
|
|
|
|
|
|
handles => {find_expected_code => 'grep',}, |
41
|
|
|
|
|
|
|
); |
42
|
|
|
|
|
|
|
has params => ( |
43
|
|
|
|
|
|
|
traits => ['Array'], |
44
|
|
|
|
|
|
|
is => 'ro', |
45
|
|
|
|
|
|
|
isa => ArrayRef [Str], |
46
|
|
|
|
|
|
|
required => 0, |
47
|
|
|
|
|
|
|
default => sub { [] }, |
48
|
|
|
|
|
|
|
auto_deref => 1, |
49
|
|
|
|
|
|
|
handles => {find_request_parameter => 'first',} |
50
|
|
|
|
|
|
|
); |
51
|
|
|
|
|
|
|
has params_in_url => ( |
52
|
|
|
|
|
|
|
traits => ['Array'], |
53
|
|
|
|
|
|
|
is => 'ro', |
54
|
|
|
|
|
|
|
isa => ArrayRef [Str], |
55
|
|
|
|
|
|
|
required => 0, |
56
|
|
|
|
|
|
|
default => sub { [] }, |
57
|
|
|
|
|
|
|
auto_deref => 0, |
58
|
|
|
|
|
|
|
handles => {find_request_url_parameters => 'first'} |
59
|
|
|
|
|
|
|
); |
60
|
|
|
|
|
|
|
has required => ( |
61
|
|
|
|
|
|
|
traits => ['Array'], |
62
|
|
|
|
|
|
|
is => 'ro', |
63
|
|
|
|
|
|
|
isa => ArrayRef [Str], |
64
|
|
|
|
|
|
|
default => sub { [] }, |
65
|
|
|
|
|
|
|
auto_deref => 1, |
66
|
|
|
|
|
|
|
required => 0, |
67
|
|
|
|
|
|
|
); |
68
|
|
|
|
|
|
|
has documentation => ( |
69
|
|
|
|
|
|
|
is => 'ro', |
70
|
|
|
|
|
|
|
isa => 'Str', |
71
|
|
|
|
|
|
|
lazy => 1, |
72
|
|
|
|
|
|
|
default => sub { |
73
|
|
|
|
|
|
|
my $self = shift; |
74
|
|
|
|
|
|
|
my $doc; |
75
|
|
|
|
|
|
|
$doc .= "name: " . $self->name . "\n"; |
76
|
|
|
|
|
|
|
$doc .= "description: " . $self->description . "\n" |
77
|
|
|
|
|
|
|
if $self->has_description; |
78
|
|
|
|
|
|
|
$doc .= "method: " . $self->method . "\n"; |
79
|
|
|
|
|
|
|
$doc .= "path: " . $self->path . "\n"; |
80
|
|
|
|
|
|
|
$doc .= "arguments: " . join(', ', $self->params) . "\n" |
81
|
|
|
|
|
|
|
if $self->params; |
82
|
|
|
|
|
|
|
$doc .= "required: " . join(', ', $self->required) . "\n" |
83
|
|
|
|
|
|
|
if $self->required; |
84
|
|
|
|
|
|
|
$doc; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
before wrap => sub { |
89
|
|
|
|
|
|
|
my ($class, %args) = @_; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
if (!$args{params} && $args{required}) { |
92
|
|
|
|
|
|
|
die Net::HTTP::API::Error->new( |
93
|
|
|
|
|
|
|
reason => "You can't require a param that have not been declared"); |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
if ( $args{required} ) { |
97
|
|
|
|
|
|
|
foreach my $required ( @{ $args{required} } ) { |
98
|
|
|
|
|
|
|
die Net::HTTP::API::Error->new( reason => |
99
|
|
|
|
|
|
|
"$required is required but is not declared in params" ) |
100
|
|
|
|
|
|
|
if ( !grep { $_ eq $required } @{ $args{params} }, @{$args{params_in_url}} ); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
}; |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub wrap { |
106
|
|
|
|
|
|
|
my ($class, %args) = @_; |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
if (!defined $args{body}) { |
109
|
|
|
|
|
|
|
my $code = sub { |
110
|
|
|
|
|
|
|
my ($self, %method_args) = @_; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
my $method = $self->meta->find_net_api_method_by_name($args{name}); |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
$method->_validate_before_execute(\%method_args); |
115
|
|
|
|
|
|
|
my $path = $method->_build_path(\%method_args); |
116
|
|
|
|
|
|
|
my $local_url = $method->_build_uri($self, $path); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
my $result = $self->http_request( |
119
|
|
|
|
|
|
|
$method->method => $local_url, |
120
|
|
|
|
|
|
|
$method->params_in_url, \%method_args |
121
|
|
|
|
|
|
|
); |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
my $code = $result->code; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
if ($method->has_expected |
126
|
|
|
|
|
|
|
&& !$method->find_expected_code(sub {/$code/})) |
127
|
|
|
|
|
|
|
{ |
128
|
|
|
|
|
|
|
die Net::HTTP::API::Error->new( |
129
|
|
|
|
|
|
|
reason => "unexpected code", |
130
|
|
|
|
|
|
|
http_error => $result |
131
|
|
|
|
|
|
|
); |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
my $content = $self->get_content($result);; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
if ($result->is_success) { |
137
|
|
|
|
|
|
|
if (wantarray) { |
138
|
|
|
|
|
|
|
return ($content, $result); |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
else { |
141
|
|
|
|
|
|
|
return $content; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
die Net::HTTP::API::Error->new( |
146
|
|
|
|
|
|
|
http_error => $result, |
147
|
|
|
|
|
|
|
reason => $result->message, |
148
|
|
|
|
|
|
|
); |
149
|
|
|
|
|
|
|
}; |
150
|
|
|
|
|
|
|
$args{body} = $code; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
$class->SUPER::wrap(%args); |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub _validate_before_execute { |
157
|
|
|
|
|
|
|
my ($self, $args) = @_; |
158
|
|
|
|
|
|
|
for my $method (qw/_check_params_before_run _check_required_before_run/) { |
159
|
|
|
|
|
|
|
$self->$method($args); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
sub _check_params_before_run { |
164
|
|
|
|
|
|
|
my ($self, $args) = @_; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
return if !$self->strict; |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
# check if there is no undeclared param |
169
|
|
|
|
|
|
|
foreach my $arg (keys %$args) { |
170
|
|
|
|
|
|
|
if ( !$self->find_request_parameter(sub {/$arg/}) |
171
|
|
|
|
|
|
|
&& !$self->find_request_url_parameters(sub {/$arg/})) |
172
|
|
|
|
|
|
|
{ |
173
|
|
|
|
|
|
|
die Net::HTTP::API::Error->new( |
174
|
|
|
|
|
|
|
reason => "'$arg' is not declared as a param"); |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub _check_required_before_run { |
180
|
|
|
|
|
|
|
my ($self, $args) = @_; |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
# check if all our params declared as required are present |
183
|
|
|
|
|
|
|
foreach my $required ($self->required) { |
184
|
|
|
|
|
|
|
if (!grep { $required eq $_ } keys %$args) { |
185
|
|
|
|
|
|
|
die Net::HTTP::API::Error->new(reason => |
186
|
|
|
|
|
|
|
"'$required' is declared as required, but is not present"); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
sub _build_path { |
192
|
|
|
|
|
|
|
my ($self, $args) = @_; |
193
|
|
|
|
|
|
|
my $path = $self->path; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
my $max_iter = keys %$args; |
196
|
|
|
|
|
|
|
my $i = 0; |
197
|
|
|
|
|
|
|
while ($path =~ /(?:\$|:)(\w+)/g) { |
198
|
|
|
|
|
|
|
my $match = $1; |
199
|
|
|
|
|
|
|
$i++; |
200
|
|
|
|
|
|
|
if (my $value = delete $args->{$match}) { |
201
|
|
|
|
|
|
|
$path =~ s/(?:\$|:)$match/$value/; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
if ($max_iter > $i) { |
204
|
|
|
|
|
|
|
$path =~ s/\/(?:(\$|\:).*)?$//; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
$path =~ s/\/(?:(\$|\:).*)?$//; |
208
|
|
|
|
|
|
|
return $path; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub _build_uri { |
212
|
|
|
|
|
|
|
my ($method, $self, $path) = @_; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
my $local_url = $self->api_base_url->clone; |
215
|
|
|
|
|
|
|
my $path_url_base = $local_url->path; |
216
|
|
|
|
|
|
|
$path_url_base =~ s/\/$// if $path_url_base =~ m!/$!; |
217
|
|
|
|
|
|
|
$path_url_base .= $path; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
if ($self->api_format && $self->api_format_mode eq 'append') { |
220
|
|
|
|
|
|
|
my $format = $self->api_format; |
221
|
|
|
|
|
|
|
$path_url_base .= "." . $format; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
$local_url->path($path_url_base); |
225
|
|
|
|
|
|
|
return $local_url; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
1; |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
__END__ |
232
|
|
|
|
|
|
|
=pod |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=head1 NAME |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
Net::HTTP::API::Meta::Method - create api method |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=head1 VERSION |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
version 0.14 |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
=head1 SYNOPSIS |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=head1 DESCRIPTION |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
=head1 AUTHOR |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
franck cuny <franck@lumberjaph.net> |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
This software is copyright (c) 2010 by linkfluence. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
255
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=cut |
258
|
|
|
|
|
|
|
|