File Coverage

blib/lib/HTTP/AnyUA.pm
Criterion Covered Total %
statement 125 165 75.7
branch 42 90 46.6
condition 27 82 32.9
subroutine 27 32 84.3
pod 14 14 100.0
total 235 383 61.3


line stmt bran cond sub pod time code
1             package HTTP::AnyUA;
2             # ABSTRACT: An HTTP user agent programming interface unification layer
3              
4              
5 17     17   44291 use 5.010;
  17         160  
6 17     17   91 use warnings;
  17         32  
  17         433  
7 17     17   86 use strict;
  17         40  
  17         851  
8              
9             our $VERSION = '0.903'; # VERSION
10              
11 17     17   7569 use HTTP::AnyUA::Util;
  17         49  
  17         948  
12 17     17   8971 use Module::Loader;
  17         311340  
  17         543  
13 17     17   122 use Scalar::Util;
  17         33  
  17         1743  
14              
15              
16             our $BACKEND_NAMESPACE;
17             our $MIDDLEWARE_NAMESPACE;
18             our @BACKENDS;
19             our %REGISTERED_BACKENDS;
20              
21             BEGIN {
22 17     17   66 $BACKEND_NAMESPACE = __PACKAGE__ . '::Backend';
23 17         36369 $MIDDLEWARE_NAMESPACE = __PACKAGE__ . '::Middleware';
24             }
25              
26              
27 19 50   19   74 sub _debug_log { print STDERR join(' ', @_), "\n" if $ENV{PERL_HTTP_ANYUA_DEBUG} }
28              
29 1     1   6 sub _croak { require Carp; Carp::croak(@_) }
  1         16  
30 1     1   8 sub _usage { _croak("Usage: @_\n") }
31              
32              
33              
34             sub new {
35 10     10 1 58748 my $class = shift;
36 10 100       45 unshift @_, 'ua' if @_ % 2;
37 10         34 my %args = @_;
38 10 100       36 $args{ua} or _usage(q{HTTP::AnyUA->new(ua => $user_agent, %attr)});
39              
40 9         17 my $self;
41 9         28 my @attr = qw(ua backend response_is_future);
42              
43 9         25 for my $attr (@attr) {
44 27 100       83 $self->{$attr} = $args{$attr} if defined $args{$attr};
45             }
46              
47 9         20 bless $self, $class;
48              
49 9         28 $self->_debug_log('Created with user agent', $self->ua);
50              
51             # call accessors to get the checks to run
52 9         26 $self->ua;
53 9 100       30 $self->response_is_future($args{response_is_future}) if defined $args{response_is_future};
54              
55 9         46 return $self;
56             }
57              
58              
59 32 50   32 1 192 sub ua { shift->{ua} or _croak 'User agent is required' }
60              
61              
62             sub response_is_future {
63 27     27 1 50 my $self = shift;
64 27         40 my $val = shift;
65              
66 27 100 66     159 if (defined $val) {
    100          
67 1 50       4 $self->_debug_log('Set response_is_future to', $val ? 'ON' : 'OFF');
68              
69 1         5 $self->_check_response_is_future($val);
70 1         3 $self->{response_is_future} = $val;
71              
72 1 50       4 $self->_module_loader->load('Future') if $self->{response_is_future};
73             }
74             elsif (!defined $self->{response_is_future} && $self->{backend}) {
75 24         59 $self->{response_is_future} = $self->backend->response_is_future;
76              
77 24 100       181 $self->_module_loader->load('Future') if $self->{response_is_future};
78             }
79              
80 27   100     2477 return $self->{response_is_future} || '';
81             }
82              
83              
84             sub backend {
85 61     61 1 120 my $self = shift;
86              
87 61 100       264 return $self->{backend} if defined $self->{backend};
88              
89 7         27 $self->{backend} = $self->_build_backend;
90 7         29 $self->_check_response_is_future($self->response_is_future);
91              
92 7         66 return $self->{backend};
93             }
94              
95              
96             sub request {
97 15     15 1 43 my ($self, $method, $url, $args) = @_;
98 15   100     76 $args ||= {};
99 15 50 33     104 @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
      33        
100             or _usage(q{$any_ua->request($method, $url, \%options)});
101              
102 15         34 my $resp = eval { $self->backend->request(uc($method) => $url, $args) };
  15         33  
103 15 50       450 if (my $err = $@) {
104 0         0 return $self->_wrap_internal_exception($err);
105             }
106              
107 15         49 return $self->_wrap_response($resp);
108             }
109              
110              
111             # adapted from HTTP/Tiny.pm
112             for my $sub_name (qw{get head put post delete}) {
113             my %swap = (SUBNAME => $sub_name, METHOD => uc($sub_name));
114             my $code = q[
115             sub {{SUBNAME}} {
116             my ($self, $url, $args) = @_;
117             @_ == 2 || (@_ == 3 && ref $args eq 'HASH')
118             or _usage(q{$any_ua->{{SUBNAME}}($url, \%options)});
119             return $self->request('{{METHOD}}', $url, $args);
120             }
121             ];
122             $code =~ s/\{\{([A-Z_]+)\}\}/$swap{$1}/ge;
123 1 0 0 1 1 1136 eval $code; ## no critic
  1 50 33 7 1 6  
  1 0 33 1 1 3  
  7 50 66 4 1 9983  
  7 0 0 1 1 42  
  7   33     30  
  1   33     1432  
  1   66     5  
  1   0     10  
  4   33     2342  
  4         34  
  4         15  
  1         1063  
  1         4  
  1         5  
124             }
125              
126              
127             # adapted from HTTP/Tiny.pm
128             sub post_form {
129 1     1 1 14 my ($self, $url, $data, $args) = @_;
130 1 0 0     5 (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
      33        
131             or _usage(q{$any_ua->post_form($url, $formdata, \%options)});
132              
133 1         7 my $headers = HTTP::AnyUA::Util::normalize_headers($args->{headers});
134 1         3 delete $args->{headers};
135              
136 1         7 return $self->request(POST => $url, {
137             %$args,
138             content => HTTP::AnyUA::Util::www_form_urlencode($data),
139             headers => {
140             %$headers,
141             'content-type' => 'application/x-www-form-urlencoded',
142             },
143             });
144             }
145              
146              
147             # adapted from HTTP/Tiny.pm
148             sub mirror {
149 0     0 1 0 my ($self, $url, $file, $args) = @_;
150 0 0 0     0 @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
      0        
151             or _usage(q{$any_ua->mirror($url, $filepath, \%options)});
152              
153 0         0 $args->{headers} = HTTP::AnyUA::Util::normalize_headers($args->{headers});
154              
155 0 0 0     0 if (-e $file and my $mtime = (stat($file))[9]) {
156 0   0     0 $args->{headers}{'if-modified-since'} ||= HTTP::AnyUA::Util::http_date($mtime);
157             }
158 0         0 my $tempfile = $file . int(rand(2**31));
159              
160             # set up the response body to be written to the file
161 0         0 require Fcntl;
162 0 0       0 sysopen(my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY())
163             or return $self->_wrap_internal_exception(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
164 0         0 binmode $fh;
165 0     0   0 $args->{data_callback} = sub { print $fh $_[0] };
  0         0  
166              
167 0         0 my $resp = $self->request(GET => $url, $args);
168              
169             my $finish = sub {
170 0     0   0 my $resp = shift;
171              
172 0 0       0 close $fh
173             or return HTTP::AnyUA::Util::internal_exception(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
174              
175 0 0       0 if ($resp->{success}) {
176 0 0       0 rename($tempfile, $file)
177             or return HTTP::AnyUA::Util::internal_exception(qq/Error replacing $file with $tempfile: $!\n/);
178 0         0 my $lm = $resp->{headers}{'last-modified'};
179 0 0 0     0 if ($lm and my $mtime = HTTP::AnyUA::Util::parse_http_date($lm)) {
180 0         0 utime($mtime, $mtime, $file);
181             }
182             }
183 0         0 unlink($tempfile);
184              
185 0   0     0 $resp->{success} ||= $resp->{status} eq '304';
186              
187 0         0 return $resp;
188 0         0 };
189              
190 0 0       0 if ($self->response_is_future) {
191             return $resp->followed_by(sub {
192 0     0   0 my $future = shift;
193 0 0       0 my @resp = $future->is_done ? $future->get : $future->failure;
194 0         0 my $resp = $finish->(@resp);
195 0 0       0 if ($resp->{success}) {
196 0         0 return Future->done(@resp);
197             }
198             else {
199 0         0 return Future->fail(@resp);
200             }
201 0         0 });
202             }
203             else {
204 0         0 return $finish->($resp);
205             }
206             }
207              
208              
209             sub apply_middleware {
210 4     4 1 25 my $self = shift;
211 4         9 my $class = shift;
212              
213 4 50       11 if (!ref $class) {
214 4 50       27 $class = "${MIDDLEWARE_NAMESPACE}::${class}" unless $class =~ s/^\+//;
215 4         13 $self->_module_loader->load($class);
216             }
217              
218 4         62 $self->{backend} = $class->wrap($self->backend, @_);
219 4         16 $self->_check_response_is_future($self->response_is_future);
220              
221 4         39 return $self;
222             }
223              
224              
225             sub register_backend {
226 5     5 1 439 my ($class, $ua_type, $backend_class) = @_;
227 5 50       26 @_ == 3 or _usage(q{HTTP::AnyUA->register_backend($ua_type, $backend_package)});
228              
229 5 50       18 if ($backend_class) {
230 5 50       36 $backend_class = "${BACKEND_NAMESPACE}::${backend_class}" unless $backend_class =~ s/^\+//;
231 5         24 $REGISTERED_BACKENDS{$ua_type} = $backend_class;
232             }
233             else {
234 0         0 delete $REGISTERED_BACKENDS{$ua_type};
235             }
236             }
237              
238              
239             # turn a response into a Future if it needs to be
240             sub _wrap_response {
241 15     15   27 my $self = shift;
242 15         32 my $resp = shift;
243              
244 15 100 100     36 if ($self->response_is_future && !$self->backend->response_is_future) {
245             # wrap the response in a Future
246 1 50       3 if ($resp->{success}) {
247 0         0 $self->_debug_log('Wrapped successful response in a Future');
248 0         0 $resp = Future->done($resp);
249             }
250             else {
251 1         4 $self->_debug_log('Wrapped failed response in a Future');
252 1         10 $resp = Future->fail($resp);
253             }
254             }
255              
256 15         96 return $resp;
257             }
258              
259 0     0   0 sub _wrap_internal_exception { shift->_wrap_response(HTTP::AnyUA::Util::internal_exception(@_)) }
260              
261             # get a module loader object
262 14   66 14   100 sub _module_loader { shift->{_module_loader} ||= Module::Loader->new }
263              
264             # get a list of potential backends that may be able to handle the user agent
265             sub _build_backend {
266 7     7   16 my $self = shift;
267 7 50 33     31 my $ua = shift || $self->ua or _croak 'User agent is required';
268              
269 7         31 my $ua_type = Scalar::Util::blessed($ua);
270              
271 7         13 my @classes;
272              
273 7 100       23 if ($ua_type) {
274 1 50       4 push @classes, $REGISTERED_BACKENDS{$ua_type} if $REGISTERED_BACKENDS{$ua_type};
275              
276 1         6 push @classes, "${BACKEND_NAMESPACE}::${ua_type}";
277              
278 1 50       3 if (!@BACKENDS) {
279             # search for some backends to try
280 1         4 @BACKENDS = sort $self->_module_loader->find_modules($BACKEND_NAMESPACE);
281 1         8509 $self->_debug_log('Found backends to try (' . join(', ', @BACKENDS) . ')');
282             }
283              
284 1         4 for my $backend_type (@BACKENDS) {
285 7         13 my $plugin = $backend_type;
286 7         36 $plugin =~ s/^\Q${BACKEND_NAMESPACE}\E:://;
287 7 100       40 push @classes, $backend_type if $ua->isa($plugin);
288             }
289             }
290             else {
291 6 50       24 push @classes, $REGISTERED_BACKENDS{$ua} if $REGISTERED_BACKENDS{$ua};
292 6         24 push @classes, "${BACKEND_NAMESPACE}::${ua}";
293             }
294              
295 7         20 for my $class (@classes) {
296 7 50       13 if (eval { $self->_module_loader->load($class); 1 }) {
  7         22  
  7         1818  
297 7         42 $self->_debug_log("Found usable backend (${class})");
298 7         25 return $class->new($self->ua);
299             }
300             else {
301 0         0 $self->_debug_log($@);
302             }
303             }
304              
305 0         0 _croak 'Cannot find a usable backend that supports the given user agent';
306             }
307              
308             # make sure the response_is_future setting is compatible with the backend
309             sub _check_response_is_future {
310 12     12   23 my $self = shift;
311 12         20 my $val = shift;
312              
313             # make sure the user agent is not non-blocking
314 12 50 66     65 if (!$val && $self->{backend} && $self->backend->response_is_future) {
      33        
315 0           _croak 'Cannot disable response_is_future with a non-blocking user agent';
316             }
317             }
318              
319             1;
320              
321             __END__