File Coverage

blib/lib/Test/Mock/LWP/Dispatch.pm
Criterion Covered Total %
statement 88 97 90.7
branch 32 40 80.0
condition 10 19 52.6
subroutine 16 16 100.0
pod 5 5 100.0
total 151 177 85.3


line stmt bran cond sub pod time code
1             package Test::Mock::LWP::Dispatch;
2             $Test::Mock::LWP::Dispatch::VERSION = '0.08';
3 9     9   205025 use strict;
  9         20  
  9         235  
4 9     9   44 use warnings;
  9         17  
  9         281  
5              
6             # ABSTRACT: mocks LWP::UserAgent and dispatches your requests/responses
7              
8              
9 9     9   46 use base qw(Exporter Test::MockObject);
  9         20  
  9         8243  
10              
11             our @EXPORT = qw($mock_ua);
12             our @EXPORT_OK = @EXPORT;
13             our $DEFAULT_REQUEST_HEADERS = 1;
14              
15 9     9   29528 use Carp qw(croak);
  9         17  
  9         482  
16 9     9   9099 use Data::Dumper qw();
  9         92133  
  9         237  
17 9     9   6510 use HTTP::Request;
  9         264005  
  9         296  
18 9     9   8863 use HTTP::Response;
  9         65792  
  9         301  
19 9     9   12188 use LWP::UserAgent;
  9         152928  
  9         337  
20 9     9   86 use Test::MockObject;
  9         19  
  9         103  
21              
22             our $mock_ua;
23             BEGIN {
24 9     9   9378 my $default_resp = HTTP::Response->new(404);
25 9         731 my $orig_simple_request_fn = \&LWP::UserAgent::simple_request;
26              
27              
28              
29             sub simple_request {
30 33     33 1 87090 my $mo = shift;
31 33         57 my $in_req = shift;
32 33 50 33     372 $in_req = $mo->prepare_request($in_req)
33             if ( $DEFAULT_REQUEST_HEADERS && $mo->can('prepare_request') );
34              
35 33   100     5886 my $global_maps = $mock_ua->{_maps} || [];
36 33   100     107 my $local_maps = $mo->{_maps} || [];
37 33         49 my $matched_resp = $default_resp;
38 33         44 foreach my $map (@{$local_maps}, @{$global_maps}) {
  33         54  
  33         68  
39 35 100       121 next unless (defined($map));
40 33         111 my ($req, $resp) = @{$map};
  33         69  
41              
42 33 100       143 if (ref($req) eq 'HTTP::Request') {
    100          
    100          
    50          
43 4 50 33     35 $req = $mo->prepare_request($req)
44             if ( $DEFAULT_REQUEST_HEADERS && $mo->can('prepare_request') );
45 4         481 my $dd = Data::Dumper->new([$in_req]);
46 4         118 my $dd_in = Data::Dumper->new([$req]);
47 4         86 $dd->Sortkeys(1);
48 4         27 $dd_in->Sortkeys(1);
49 4 100       23 next unless ($dd_in->Dump eq $dd->Dump);
50             } elsif (ref($req) eq '') {
51 20 100       57 next unless ($in_req->uri eq $req);
52             } elsif (ref($req) eq 'Regexp') {
53 5 100       16 next unless ($in_req->uri =~ $req);
54             } elsif (ref($req) eq 'CODE') {
55 4 100       10 next unless ($req->($in_req));
56             } else {
57 0         0 warn "Unknown type of predefined request: " . ref($req);
58 0         0 next;
59             }
60              
61 19         444 $matched_resp = $resp;
62 19         39 last;
63             }
64 33 100       394 if (ref($matched_resp) eq 'HTTP::Response') {
    50          
65 27         74 return $matched_resp;
66             } elsif (ref($matched_resp) eq 'CODE') {
67 6         19 return $matched_resp->($in_req);
68             } else {
69 0         0 warn "Unknown type of predefined response: " . ref($matched_resp);
70 0         0 return $default_resp;
71             }
72             }
73              
74              
75             sub map {
76 21     21 1 24753 my $mo = shift;
77              
78 21         45 my ($req, $resp) = @_;
79 21 100 66     106 if (!defined($req) || !defined($resp)) {
80 3         44 croak "You should pass 2 arguments in map()";
81             }
82 18 100       104 if (ref($req) !~ /^(HTTP::Request|Regexp|CODE|)$/) {
83 1         11 croak "Type of request must be HTTP::Request, regexp, coderef or plain string\n";
84             }
85 17 100       98 if (ref($resp) !~ /^(HTTP::Response|CODE)$/) {
86 1         10 croak "Type of response must be HTTP::Response or coderef\n";
87             }
88              
89 16         56 my $map = [$req, $resp];
90 16         27 push @{$mo->{_maps}}, $map;
  16         66  
91 16         23 return scalar(@{$mo->{_maps}}) - 1;
  16         59  
92             }
93              
94              
95             sub map_passthrough {
96 1     1 1 637 my $mo = shift;
97              
98 1         2 my ($req) = @_;
99 1 50       5 if (!defined($req)) {
100 0         0 croak "You should pass 1 argument to map_passthrough()";
101             }
102              
103 1     1   8 return $mo->map($req, sub { return $orig_simple_request_fn->($mo, shift); });
  1         4  
104             }
105              
106              
107             sub unmap {
108 3     3 1 40233 my $mo = shift;
109 3         9 my $index = shift;
110 3 50 33     31 return if (!defined($index) || $index !~ /^\d+$/);
111 3 50       13 unless ($mo->{_maps}) {
112 0         0 warn "You call unmap() before any call of map()\n";
113 0         0 return;
114             }
115 3 50 33     20 if ($index < 0 || $index > (scalar(@{$mo->{_maps}}) - 1)) {
  3         19  
116 0         0 warn "Index $index is out of maps range\n";
117 0         0 return;
118             }
119 3         20 delete $mo->{_maps}->[$index];
120 3         8 return 1;
121             }
122              
123              
124             sub unmap_all {
125 2     2 1 1064 my $mo = shift;
126 2         6 $mo->{_maps} = [];
127 2         8 return 1;
128             }
129              
130 9         51 my %mock_methods = (
131             simple_request => \&simple_request,
132             map => \&map,
133             map_passthrough => \&map_passthrough,
134             unmap => \&unmap,
135             unmap_all => \&unmap_all,
136             );
137              
138 9         99 Test::MockObject->fake_module('LWP::UserAgent', %mock_methods);
139             # The global mock object, can be used directly, or can just create a new
140             # LWP::UserAgent object - that is mocked too.
141 9         832 $mock_ua = LWP::UserAgent->new;
142             }
143              
144             1;
145              
146             __END__