File Coverage

blib/lib/JSON/API.pm
Criterion Covered Total %
statement 112 113 99.1
branch 35 40 87.5
condition 11 13 84.6
subroutine 21 21 100.0
pod 8 8 100.0
total 187 195 95.9


line stmt bran cond sub pod time code
1             package JSON::API;
2 4     4   154879 use strict;
  4         6  
  4         140  
3 4     4   2414 use LWP::UserAgent;
  4         134188  
  4         126  
4 4     4   2395 use JSON;
  4         31793  
  4         22  
5 4     4   3085 use Data::Dumper;
  4         23356  
  4         296  
6 4     4   1936 use URI::Encode qw/uri_encode/;
  4         40241  
  4         264  
7              
8             BEGIN {
9 4     4   27 use Exporter ();
  4         6  
  4         77  
10 4     4   17 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  4         6  
  4         384  
11 4     4   9 $VERSION = '1.0.9';
12 4         31 @ISA = qw(Exporter);
13             #Give a hoot don't pollute, do not export more than needed by default
14 4         8 @EXPORT = qw();
15 4         5 @EXPORT_OK = qw();
16 4         4564 %EXPORT_TAGS = ();
17             }
18              
19             sub _debug
20             {
21 154     154   7290 my ($self, @lines) = @_;
22 154         373 my $output = join('\n', @lines);
23 154 100       542 print STDERR $output . "\n" if ($self->{debug});
24             }
25              
26             sub _server
27             {
28 39     39   49 my ($self, $input) = @_;
29 39         153 $input =~ s|^(https?://)?||;
30 39         156 $input =~ m|^([^\s:/]+)(:\d+)?.*|;
31 39   100     199 $input = $1 . ($2 || '');
32 39         69 return $input;
33             }
34              
35             sub _http_req
36             {
37 22     22   111 my ($self, $method, $path, $data) = @_;
38 22         113 $self->_debug('_http_req called with the following:',Dumper($method,$path,$data));
39              
40 22         178 my $url = $self->url($path);
41 22         71 $self->_debug("URL calculated to be: $url");
42              
43 22         138 my $headers = HTTP::Headers->new(
44             'Accept' => 'application/json',
45             'Content-Type' => 'application/json',
46             );
47              
48 22         1870 my $json;
49 22 100       65 if (defined $data) {
50 6         21 $json = $self->_encode($data);
51 6 100       30 return (wantarray ? (500, {}) : {}) unless defined $json;
    100          
52             }
53              
54 20         164 my $req = HTTP::Request->new($method, $url, $headers, $json);
55 20         3978 $self->_debug("Requesting: ",Dumper($req));
56 20         216 my $res = $self->{user_agent}->request($req);
57              
58 20         177567 $self->_debug("Response: ",Dumper($res));
59 20 100       353 if ($res->is_success) {
60 14         194 $self->{has_error} = 0;
61 14         45 $self->{error_string} = '';
62 14         35 $self->_debug("Successful request detected");
63             } else {
64 6         78 $self->{has_error} = 1;
65 6         24 $self->{error_string} = $res->content;
66 6         87 $self->_debug("Error detected: ".$self->{error_string});
67             # If internal warning, return before decoding, as it will fail + overwrite the error_string
68 6 50       20 if ($res->header('client-warning') =~ m/internal response/i) {
69 0 0       0 return wantarray ? ($res->code, {}) : {};
70             }
71             }
72 20 100 100     370 my $decoded = $res->content ? ($self->_decode($res->content) || {}) : {};
73              
74             #FIXME: should we auto-populate an error key in the {} if error detected but no content?
75             return wantarray ?
76 20 100       229 ($res->code, $decoded) :
77             $decoded;
78             }
79              
80             sub _encode
81             {
82 8     8   15 my ($self, $obj) = @_;
83              
84 8         14 my $json = undef;
85             eval {
86 8         53 $json = to_json($obj);
87 5         152 $self->_debug("JSON created: $json");
88 8 50       11 } or do {
89 8 100       87 if ($@) {
90 3         7 $self->{has_error} = 1;
91 3         10 $self->{error_string} = $@;
92 3         35 $self->{error_string} =~ s/\s+at\s+\S+\s+line\s+\d+\.?\s*//;
93 3         14 $self->_debug("Error serializing json from \$obj:" . $self->{error_string});
94             }
95             };
96 8         21 return $json;
97             }
98              
99             sub _decode
100             {
101 20     20   354 my ($self, $json) = @_;
102              
103 20         49 $self->_debug("Deserializing JSON");
104 20         28 my $obj = undef;
105             eval {
106 20         122 $obj = from_json($json);
107 17         477 $self->_debug("Deserializing successful:",Dumper($obj));
108 20 50       27 } or do {
109 20 100       178 if ($@) {
110 3         22 $self->{has_error} = 1;
111 3         8 $self->{error_string} = $@;
112 3         42 $self->{error_string} =~ s/\s+at\s+\S+\s+line\s+\d+\.?\s*//;
113 3         16 $self->_debug("Error deserializing: ".$self->{error_string});
114             }
115             };
116 20         143 return $obj;
117             }
118              
119             sub new
120             {
121 32     32 1 23695 my ($class, $base_url, %parameters) = @_;
122 32 100       192 return undef unless $base_url;
123              
124 31         85 my %ua_opts = %parameters;
125 31         52 map { delete $parameters{$_}; } qw(user pass realm debug);
  124         151  
126              
127 31         141 my $ua = LWP::UserAgent->new(%parameters);
128              
129 31   33     10940 my $self = bless ({
130             base_url => $base_url,
131             user_agent => $ua,
132             has_error => 0,
133             error_string => '',
134             debug => $ua_opts{debug},
135             }, ref ($class) || $class);
136              
137 31         70 my $server = $self->_server($base_url);
138 31 100       75 my $default_port = $base_url =~ m|^https://| ? 443 : 80;
139 31 100       108 $server .= ":$default_port" unless $server =~ /:\d+$/;
140 31 100 100     117 $ua->credentials($server, $ua_opts{realm}, $ua_opts{user}, $ua_opts{pass})
      100        
141             if ($ua_opts{realm} && $ua_opts{user} && $ua_opts{pass});
142              
143 31         126 return $self;
144             }
145              
146             sub get
147             {
148 12     12 1 17957 my ($self, $path, $data) = @_;
149 12 100       46 if ($data) {
150 2         16 my @qp = map { "$_=".uri_encode($data->{$_}, { encode_reserved => 1 }) } sort keys %$data;
  4         2177  
151 2         1875 $path .= "?".join("&", @qp);
152             }
153 12         48 $self->_http_req("GET", $path);
154             }
155              
156             sub put
157             {
158 4     4 1 9605 my ($self, $path, $data) = @_;
159 4         17 $self->_http_req("PUT", $path, $data);
160             }
161              
162             sub post
163             {
164 4     4 1 8548 my ($self, $path, $data) = @_;
165 4         21 $self->_http_req("POST", $path, $data);
166             }
167              
168             sub del
169             {
170 2     2 1 4602 my ($self, $path) = @_;
171 2         7 $self->_http_req("DELETE", $path);
172             }
173              
174             sub url
175             {
176 26     26 1 68 my ($self, $path) = @_;
177 26         189 my $url = $self->{base_url} . "/$path";
178             # REGEX-FU: look through the URL, replace any matches of /+ with '/',
179             # as long as the previous character was not a ':'
180             # (e.g. http://example.com//api//mypath/ becomes http://example.com/api/mypath/
181 26         302 $url =~ s|(?
182 26         63 return $url;
183             }
184              
185             sub errstr
186             {
187 5     5 1 3591 my ($self) = @_;
188 5 100       10 return ! $self->was_success ? $self->{error_string} : '';
189             }
190              
191             sub was_success
192             {
193 7     7 1 11 my ($self) = @_;
194 7 100       43 return $self->{has_error} ? 0 : 1;
195             }
196              
197             1;
198              
199             =head1 NAME
200              
201             JSON::API - Module to interact with a JSON API
202              
203             =head1 SYNOPSIS
204              
205             use JSON::API;
206             my $api = JSON::API->new("http://myapp.com/");
207             my $obj = { name => 'foo', type => 'bar' };
208             if ($api->put("/add/obj", $obj) {
209             print "Success!\n";
210             } else {
211             print $api->errstr . "\n";
212             }
213              
214             =head1 DESCRIPTION
215              
216             This module wraps JSON and LWP::UserAgent to create a flexible utility
217             for accessing APIs that accept/provide JSON data.
218              
219             It supports all the options LWP supports, including authentication.
220              
221             =head1 METHODS
222              
223             =head2 new
224              
225             Creates a new JSON::API object for connecting to any API that accepts
226             and provide JSON data.
227              
228             Example:
229              
230             my $api = JSON::API->new("https://myapp.com:8443/path/to/app",
231             user => 'foo',
232             pass => 'bar',
233             realm => 'my_protected_site',
234             agent => 'MySpecialBrowser/1.0',
235             cookie_jar => '/tmp/cookie_jar',
236             );
237              
238             Parameters:
239              
240             =over
241              
242             =item base_url
243              
244             The base URL to apply to all requests you send this api, for example:
245              
246             https://myapp.com:8443/path/to/app
247              
248             =item parameters
249              
250             This is a hash of options that can be passed in to an LWP object.
251             Additionally, the B, B, and B may be provided
252             to configure authentication for LWP. You must provide all three parameters
253             for authentication to work properly.
254              
255             Specifying debug => 1 in the parameters hash will also enable debugging output
256             within JSON::API.
257              
258             =back
259              
260             =head2 get|post|put|del
261              
262             Perform an HTTP action (GET|POST|PUT|DELETE) against the given API. All methods
263             take the B to the API endpoint as the first parameter. The B and
264             B methods also accept a second B parameter, which should be a reference
265             to be serialized into JSON for POST/PUTing to the endpoint.
266              
267             If called in scalar context, returns the deserialized JSON content returned by
268             the server. If no content was returned, returns an empty hashref. To check for errors,
269             call B or B.
270              
271             If called in list context, returns a two-value array. The first value will be the
272             HTTP response code for the request. The second value will either be the deserialized
273             JSON data. If no data is returned, returns an empty hashref.
274              
275             =head2 get
276              
277             Performs an HTTP GET on the given B. B will be appended to the
278             B provided when creating this object. If given a B object,
279             this will be turned into querystring parameters, with URI encoded values.
280              
281             my $obj = $api->get('/objects/1');
282             # Automatically add + encode querystring params
283             my $obj = $api->get('/objects/1', { param => 'value' });
284              
285             =head2 put
286              
287             Performs an HTTP PUT on the given B, with the provided B. Like
288             B, this will append path to the end of the B.
289              
290             $api->put('/objects/', $obj);
291              
292             =head2 post
293              
294             Performs an HTTP POST on the given B, with the provided B. Like
295             B, this will append path to the end of the B.
296              
297             $api->post('/objects/', [$obj1, $obj2]);
298              
299             =head2 del
300              
301             Performs an HTTP DELETE on the given B. Like B, this will append
302             path to the end of the B.
303              
304             $api->del('/objects/first');
305              
306             =head2 errstr
307              
308             Returns the current error string for the last call.
309              
310             =head2 was_success
311              
312             Returns whether or not the last request was successful.
313              
314             =head2 url
315              
316             Returns the complete URL of a request, when given a path.
317              
318             =cut
319              
320             =head1 REPOSITORY
321              
322             L
323              
324             =head1 AUTHOR
325              
326             Geoff Franks
327              
328             =head1 COPYRIGHT
329              
330             Copyright 2014, Geoff Franks
331              
332             This library is licensed under the GNU General Public License 3.0
333