File Coverage

blib/lib/Test2/Tools/HTTP.pm
Criterion Covered Total %
statement 228 247 92.3
branch 51 62 82.2
condition 16 24 66.6
subroutine 54 70 77.1
pod 31 31 100.0
total 380 434 87.5


line stmt bran cond sub pod time code
1             package Test2::Tools::HTTP;
2              
3 6     6   882623 use strict;
  6         32  
  6         178  
4 6     6   33 use warnings;
  6         13  
  6         141  
5 6     6   125 use 5.008001;
  6         30  
6 6     6   3931 use LWP::UserAgent;
  6         248237  
  6         242  
7 6     6   56 use parent qw( Exporter );
  6         12  
  6         42  
8 6     6   402 use Test2::API qw( context );
  6         16  
  6         313  
9 6     6   39 use Test2::Compare;
  6         15  
  6         235  
10 6     6   40 use Test2::Compare::Wildcard;
  6         13  
  6         178  
11 6     6   34 use Test2::Compare::Custom;
  6         11  
  6         195  
12 6     6   3140 use Test2::Tools::HTTP::UA;
  6         53  
  6         174  
13 6     6   39 use Test2::Tools::HTTP::Apps;
  6         32  
  6         106  
14 6     6   2246 use Test2::Tools::HTTP::Tx;
  6         15  
  6         196  
15 6     6   34 use URI;
  6         11  
  6         100  
16 6     6   27 use Carp ();
  6         382  
  6         998  
17              
18             our %EXPORT_TAGS = (
19             short => [qw(
20             app_add req ua res code message content content_type charset content_length content_length_ok location location_uri tx headers header
21             )],
22             );
23              
24             our @EXPORT = qw(
25             http_request http_ua http_base_url psgi_app_add psgi_app_del http_response http_code http_message http_content http_tx http_is_success
26             http_is_info http_is_success http_is_redirect http_is_error http_is_client_error http_is_server_error
27             http_isnt_info http_isnt_success http_isnt_redirect http_isnt_error http_isnt_client_error http_isnt_server_error
28             http_content_type http_content_type_charset http_content_length http_content_length_ok http_location http_location_uri
29             http_headers http_header
30             psgi_app_guard
31             );
32              
33             our @EXPORT_OK = (
34             @{ $EXPORT_TAGS{'short'} },
35             );
36              
37             *ua = \&http_ua;
38             *req = \&http_request;
39             *res = \&http_response;
40             *app_add = \&psgi_app_add;
41             *charset = \&http_content_type_charset;
42              
43             foreach my $short (qw( code message content content_type content_length content_length_ok location location_uri tx header headers ))
44             {
45 6     6   43 no strict 'refs';
  6         16  
  6         16358  
46             *{$short} = \&{"http_$short"};
47             }
48              
49             # ABSTRACT: Test HTTP / PSGI
50             our $VERSION = '0.09'; # VERSION
51              
52              
53             my $tx;
54             my $apps = Test2::Tools::HTTP::UA->apps;
55             my $ua_wrapper;
56              
57             sub http_request
58             {
59 35     35 1 7627 my($req, $check, $message) = @_;
60              
61 35         68 my %options;
62              
63 35 100       105 if(ref $req eq 'ARRAY')
64             {
65 1         5 ($req, %options) = @$req;
66             }
67              
68 35         119 $req = $req->clone;
69              
70 35         6363 my $url = URI->new_abs($req->uri, http_base_url());
71              
72 35   33     4895 $message ||= "@{[ $req->method ]} @{[ $url ]}";
  35         98  
  35         489  
73              
74 35         346 my $ctx = context();
75 35         14151 my $ok = 1;
76 35         60 my @diag;
77 35         55 my $connection_error = 0;
78              
79 35 100       108 unless($apps->uri_to_app($req->uri))
80             {
81 3 100       10 if($req->uri =~ /^\//)
82             {
83 1         16 $req->uri(
84             URI->new_abs($req->uri, $apps->base_url),
85             );
86             }
87             }
88              
89 35         458 http_ua(); # sets $ua_wrapper if not already
90 35         54 my $res = eval { $ua_wrapper->request($req, %options) };
  35         125  
91              
92 35 100       121 if(my $error = $@)
93             {
94 1         2 $ok = 0;
95 1         3 $connection_error = "$error";
96 1         3 push @diag, "$error";
97 1         2 $res = eval { $error->res };
  1         4  
98             }
99            
100 35 50       89 if(defined $res)
101             {
102 35         152 bless($res, 'Test2::Tools::HTTP::Tx::Response'),
103             }
104              
105 35 100 100     157 if($ok && defined $check)
106             {
107 31         103 my $delta = Test2::Compare::compare($res, $check, \&Test2::Compare::strict_convert);
108 31 100       565 if($delta)
109             {
110 9         17 $ok = 0;
111 9         27 push @diag, $delta->diag;
112             }
113             }
114              
115 35         90122 $ctx->ok($ok, $message, \@diag);
116 35         8884 $ctx->release;
117              
118             $tx = bless {
119             req => bless($req, 'Test2::Tools::HTTP::Tx::Request'),
120             res => $res,
121             ok => $ok,
122             connection_error => $connection_error,
123 35         990 location => do {
124 35 100       171 $res
    50          
125             ? $res->header('Location')
126             ? URI->new_abs($res->header('Location'), $res->base)
127             : undef
128             : undef;
129             },
130             }, 'Test2::Tools::HTTP::Tx';
131              
132 35         5775 $ok;
133             }
134              
135              
136             sub http_response (&)
137             {
138 40     40 1 22628 Test2::Compare::build(
139             'Test2::Tools::HTTP::ResponseCompare',
140             @_,
141             );
142             }
143              
144              
145             sub _caller
146             {
147 70     70   97 my $i = 1;
148 70         96 my @caller;
149 70         452 while(@caller = caller $i)
150             {
151 155 100       361 last if $caller[0] ne __PACKAGE__;
152 85         451 $i++;
153             }
154 70         255 @caller;
155             }
156              
157             sub _build
158             {
159 72 100   72   150 defined(my $build = Test2::Compare::get_build()) or Carp::croak "No current build!";
160 71 100       554 Carp::croak "'$build' is not a Test2::Tools::HTTP::ResponseCompare"
161             unless $build->isa('Test2::Tools::HTTP::ResponseCompare');
162              
163 70         124 my @caller = _caller;
164              
165 70         121 my $func_name = $caller[3];
166 70         341 $func_name =~ s/^.*:://;
167 70 100       273 Carp::croak "'$func_name' should only ever be called in void context"
168             if defined $caller[5];
169              
170 69         288 ($build, file => $caller[1], lines => [$caller[2]]);
171             }
172              
173             sub _add_call
174             {
175 17     17   39 my($name, $expect, $context) = @_;
176 17   50     78 $context ||= 'scalar';
177 17         37 my($build, @cmpargs) = _build;
178 14         71 $build->add_call(
179             $name,
180             Test2::Compare::Wildcard->new(
181             expect => $expect,
182             @cmpargs,
183             ),
184             undef,
185             $context
186             );
187             }
188              
189             sub http_code ($)
190             {
191 12     12 1 2038 my($expect) = @_;
192 12         30 _add_call('code', $expect);
193             }
194              
195              
196             sub http_message ($)
197             {
198 4     4 1 183 my($expect) = @_;
199 4         13 _add_call('message', $expect);
200             }
201              
202              
203             sub http_content ($)
204             {
205 17     17 1 543 my($expect) = @_;
206 17         41 my($build, @cmpargs) = _build;
207             $build->add_http_check(
208             sub {
209 17     17   38 my($res) = @_;
210 17   33     70 ($res->decoded_content || $res->content, 1);
211             },
212 17         127 [DREF => 'content'],
213             Test2::Compare::Wildcard->new(
214             expect => $expect,
215             @cmpargs,
216             )
217             );
218             }
219              
220              
221             sub _T()
222             {
223 0     0   0 my @caller = _caller;
224             Test2::Compare::Custom->new(
225 0 0   0   0 code => sub { $_ ? 1 : 0 },
226 0         0 name => 'TRUE',
227             operator => 'TRUE()',
228             file => $caller[1],
229             lines => [$caller[2]],
230             );
231             }
232              
233 0     0 1 0 sub http_is_info { _add_call('is_info', _T()) }
234 0     0 1 0 sub http_is_success { _add_call('is_success', _T()) }
235 0     0 1 0 sub http_is_redirect { _add_call('is_redirect', _T()) }
236 0     0 1 0 sub http_is_error { _add_call('is_error', _T()) }
237 0     0 1 0 sub http_is_client_error { _add_call('is_client_error', _T()) }
238 0     0 1 0 sub http_is_server_error { _add_call('is_server_error', _T()) }
239              
240              
241             sub _F()
242             {
243 0     0   0 my @caller = _caller;
244             Test2::Compare::Custom->new(
245 0 0   0   0 code => sub { $_ ? 0 : 1 },
246 0         0 name => 'TRUE',
247             operator => 'TRUE()',
248             file => $caller[1],
249             lines => [$caller[2]],
250             );
251             }
252              
253 0     0 1 0 sub http_isnt_info { _add_call('is_info', _F()) }
254 0     0 1 0 sub http_isnt_success { _add_call('is_success', _F()) }
255 0     0 1 0 sub http_isnt_redirect { _add_call('is_redirect', _F()) }
256 0     0 1 0 sub http_isnt_error { _add_call('is_error', _F()) }
257 0     0 1 0 sub http_isnt_client_error { _add_call('is_client_error', _F()) }
258 0     0 1 0 sub http_isnt_server_error { _add_call('is_server_error', _F()) }
259              
260              
261             sub http_headers
262             {
263 3     3 1 845 my($expect) = @_;
264 3         9 my($build, @cmpargs) = _build;
265             $build->add_http_check(
266             sub {
267 3     3   8 my($res) = @_;
268              
269 3         29 my @headers = $res->flatten;
270 3         715 my %headers;
271 3         14 while(@headers)
272             {
273 20         56 my($key, $val) = splice @headers, 0, 2;
274 20         27 push @{ $headers{$key} }, $val;
  20         58  
275             }
276 3         12 $_ = join ',', @{$_} for values %headers;
  16         45  
277              
278 3         12 (\%headers, 1);
279             },
280 3         26 [DREF => 'headers'],
281             Test2::Compare::Wildcard->new(
282             expect => $expect,
283             @cmpargs,
284             ),
285             );
286             }
287              
288              
289             sub http_header
290             {
291 11     11 1 761 my($name, $expect) = @_;
292 11         28 my($build, @cmpargs) = _build;
293             $build->add_http_check(
294             sub {
295 11     11   21 my($res) = @_;
296 11         37 my @values = $res->header($name);
297 11 100       553 return (0,0) unless @values;
298 10 100 100     36 if(ref($expect) eq 'ARRAY' || eval { $expect->isa('Test2::Compare::Array') })
  8         65  
299             {
300 4         7 return ([map { split /,/, $_ } @values], 1);
  8         31  
301             }
302             else
303             {
304 6         30 return (join(',',@values),1);
305             }
306             },
307 11         71 [DREF => "header $name"],
308             Test2::Compare::Wildcard->new(
309             expect => $expect,
310             @cmpargs,
311             ),
312             );
313             }
314              
315              
316             sub http_content_type
317             {
318 6     6 1 118 my($expect) = @_;
319 6         18 my($build, @cmpargs) = _build;
320             $build->add_http_check(
321             sub {
322 6     6   11 my($res) = @_;
323 6         24 my $content_type = $res->content_type;
324 6 50       210 defined $content_type
325             ? ($content_type, 1)
326             : ($content_type, 0);
327             },
328 6         45 [DREF => 'header content-type'],
329             Test2::Compare::Wildcard->new(
330             expect => $expect,
331             @cmpargs,
332             )
333             );
334             }
335              
336             sub http_content_type_charset
337             {
338 6     6 1 32 my($expect) = @_;
339 6         16 my($build, @cmpargs) = _build;
340             $build->add_http_check(
341             sub {
342 6     6   15 my($res) = @_;
343 6         18 my $charset = $res->content_type_charset;
344 6 50       606 defined $charset
345             ? ($charset, 1)
346             : ($charset, 0);
347             },
348 6         42 [DREF => 'header content-type charset'],
349             Test2::Compare::Wildcard->new(
350             expect => $expect,
351             @cmpargs,
352             )
353             );
354             }
355              
356             # TODO: header $key => $check
357             # TODO: cookie $key => $check ??
358              
359              
360             sub http_content_length
361             {
362 1     1 1 7 my($check) = @_;
363 1         3 _add_call('content_length', $check);
364             }
365              
366              
367             sub http_content_length_ok
368             {
369 3     3 1 45 my($build, @cmpargs) = _build;
370              
371             $build->add_http_check(
372             sub {
373 3     3   5 my($res) = @_;
374              
375             (
376 3         15 $res->content_length,
377             1,
378             Test2::Compare::Wildcard->new(
379             expect => length($res->content),
380             @cmpargs,
381             ),
382             )
383             },
384 3         19 [METHOD => 'content_length'],
385             undef,
386             );
387              
388              
389             }
390              
391              
392             sub http_location
393             {
394 5     5 1 179 my($expect) = @_;
395 5         16 my($build, @cmpargs) = _build;
396             $build->add_http_check(
397             sub {
398 5     5   11 my($res) = @_;
399 5         17 my $location = $res->header('Location');
400             (
401 5         232 $location,
402             defined $location
403             )
404             },
405 5         39 [DEREF => "header('Location')"],
406             Test2::Compare::Wildcard->new(
407             expect => $expect,
408             @cmpargs,
409             ),
410             );
411             }
412              
413             sub http_location_uri
414             {
415 4     4 1 426 my($expect) = @_;
416 4         12 my($build, @cmpargs) = _build;
417             $build->add_http_check(
418             sub {
419 4     4   10 my($res) = @_;
420 4         16 my $location = $res->header('Location');
421 4 100       195 defined $location
422             ? (URI->new_abs($location, $res->base), 1)
423             : (undef, 0);
424             },
425 4         31 [DEREF => "header('Location')"],
426             Test2::Compare::Wildcard->new(
427             expect => $expect,
428             @cmpargs,
429             ),
430             );
431             }
432              
433              
434             sub http_tx
435             {
436 36     36 1 17439 $tx;
437             }
438              
439              
440             sub http_base_url
441             {
442 52     52 1 20551 my($new) = @_;
443 52         222 $apps->base_url($new);
444             }
445              
446              
447             sub http_ua
448             {
449 37     37 1 16449 my($new) = @_;
450              
451 37 50 66     121 if( (!defined $ua_wrapper) && !$new)
452             {
453 4         40 $new = LWP::UserAgent->new;
454 4         11544 $new->env_proxy;
455 4         15783 $new->cookie_jar({});
456             }
457              
458 37 100       29595 if($new)
459             {
460 4         44 $ua_wrapper = Test2::Tools::HTTP::UA->new($new);
461 4         18 $ua_wrapper->instrument;
462             }
463              
464 37         361 $ua_wrapper->ua;
465             }
466              
467              
468             sub psgi_app_add
469             {
470 13 100   13 1 17977 my($url, $app) = @_ == 1 ? (http_base_url, @_) : (@_);
471 13         65 $apps->add_psgi($url, $app);
472 13         37 return;
473             }
474              
475              
476             sub psgi_app_del
477             {
478 8     8 1 2414 my($url) = @_;
479 8   66     29 $url ||= http_base_url;
480 8         41 $apps->del_psgi($url);
481 8         22 return;
482             }
483              
484              
485             sub psgi_app_guard
486             {
487 4 100   4 1 3747 my(%h) = @_ == 1 ? (http_base_url, @_) : (@_);
488            
489 4 100       173 Carp::croak "psgi_app_guard called in void context" unless defined wantarray;
490            
491 3         6 my %save;
492 3         13 my $apps = Test2::Tools::HTTP::Apps->new;
493            
494 3         8 foreach my $url (keys %h)
495             {
496 3   100     9 my $old = $apps->uri_to_app($url) || 1;
497 3         8 my $new = $h{$url};
498 3         6 $save{$url} = $old;
499 3 100       13 $apps->del_psgi($url) if ref $old;
500 3         8 $apps->add_psgi($url => $new);
501             }
502            
503 3         20 Test2::Tools::HTTP::Guard->new(%save);
504             }
505              
506             package Test2::Tools::HTTP::Guard;
507              
508             sub new
509             {
510 3     3   11 my($class, %save) = @_;
511 3         13 bless \%save, $class;
512             }
513              
514             sub restore
515             {
516 3     3   5 my($self) = @_;
517            
518 3         16 my $apps = Test2::Tools::HTTP::Apps->new;
519            
520 3         14 foreach my $url (keys %$self)
521             {
522 3         6 my $app = $self->{$url};
523 3         10 $apps->del_psgi($url);
524 3 100       16 $apps->add_psgi($url => $app)
525             if ref $app;
526             }
527             }
528              
529             sub DESTROY
530             {
531 3     3   31 my($self) = @_;
532 3         8 $self->restore;
533             }
534              
535             package Test2::Tools::HTTP::ResponseCompare;
536              
537 6     6   54 use parent 'Test2::Compare::Object';
  6         13  
  6         29  
538              
539 13     13   6575 sub name { '' }
540 39     39   6175 sub object_base { 'HTTP::Response' }
541              
542             sub init
543             {
544 40     40   1166 my($self) = @_;
545 40   50     241 $self->{HTTP_CHECK} ||= [];
546 40         141 $self->SUPER::init();
547             }
548              
549             sub add_http_check
550             {
551 55     55   1299 my($self, $cb, $id, $expect) = @_;
552              
553 55         72 push @{ $self->{HTTP_CHECK} }, [ $cb, $id, $expect ];
  55         208  
554             }
555              
556             sub deltas
557             {
558 38     38   190 my $self = shift;
559 38         122 my @deltas = $self->SUPER::deltas(@_);
560 38         4894 my %params = @_;
561              
562 38         91 my ($got, $convert, $seen) = @params{qw/got convert seen/};
563              
564 38         50 foreach my $pair (@{ $self->{HTTP_CHECK} })
  38         94  
565             {
566 55         2682 my($cb, $id, $check) = @$pair;
567              
568 55         92 my($val, $exists, $alt_check) = eval { $cb->($got) };
  55         126  
569 55         9491 my $error = $@;
570              
571 55 100       130 $check = $alt_check if defined $alt_check;
572              
573 55         161 $check = $convert->($check);
574              
575 55 50       6009 if($error)
576             {
577 0         0 push @deltas => $self->delta_class->new(
578             verified => undef,
579             id => $id,
580             got => undef,
581             check => $check,
582             exception => $error,
583             );
584             }
585             else
586             {
587 55 50       247 push @deltas => $check->run(
    100          
588             id => $id,
589             convert => $convert,
590             seen => $seen,
591             exists => $exists,
592             $exists ? ( got => $val eq '' ? '[empty string]' : $val ) : (),
593             );
594             }
595             }
596              
597 38         6160 @deltas;
598             }
599              
600             1;
601              
602             __END__