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.07';
3 9     9   232203 use strict;
  9         25  
  9         255  
4 9     9   48 use warnings;
  9         20  
  9         314  
5              
6             # ABSTRACT: mocks LWP::UserAgent and dispatches your requests/responses
7              
8              
9 9     9   48 use base qw(Exporter Test::MockObject);
  9         20  
  9         8817  
10              
11             our @EXPORT = qw($mock_ua);
12             our @EXPORT_OK = @EXPORT;
13             our $DEFAULT_REQUEST_HEADERS = 1;
14              
15 9     9   32038 use Carp qw(croak);
  9         22  
  9         547  
16 9     9   12053 use Data::Dumper qw();
  9         109613  
  9         283  
17 9     9   7657 use HTTP::Request;
  9         264842  
  9         329  
18 9     9   15370 use HTTP::Response;
  9         70280  
  9         322  
19 9     9   28194 use LWP::UserAgent;
  9         163406  
  9         333  
20 9     9   83 use Test::MockObject;
  9         18  
  9         101  
21              
22             our $mock_ua;
23             BEGIN {
24 9     9   9055 my $default_resp = HTTP::Response->new(404);
25 9         706 my $orig_simple_request_fn = \&LWP::UserAgent::simple_request;
26              
27              
28              
29             sub simple_request {
30 33     33 1 90535 my $mo = shift;
31 33         60 my $in_req = shift;
32 33 50 33     401 $in_req = $mo->prepare_request($in_req)
33             if ( $DEFAULT_REQUEST_HEADERS && $mo->can('prepare_request') );
34              
35 33   100     6077 my $global_maps = $mock_ua->{_maps} || [];
36 33   100     108 my $local_maps = $mo->{_maps} || [];
37 33         54 my $matched_resp = $default_resp;
38 33         49 foreach my $map (@{$local_maps}, @{$global_maps}) {
  33         56  
  33         69  
39 35 100       121 next unless (defined($map));
40 33         123 my ($req, $resp) = @{$map};
  33         75  
41              
42 33 100       146 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         504 my $dd = Data::Dumper->new([$in_req]);
46 4         229 my $dd_in = Data::Dumper->new([$req]);
47 4         84 $dd->Sortkeys(1);
48 4         29 $dd_in->Sortkeys(1);
49 4 100       23 next unless ($dd_in->Dump eq $dd->Dump);
50             } elsif (ref($req) eq '') {
51 20 100       69 next unless ($in_req->uri eq $req);
52             } elsif (ref($req) eq 'Regexp') {
53 5 100       18 next unless ($in_req->uri =~ $req);
54             } elsif (ref($req) eq 'CODE') {
55 4 100       12 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         481 $matched_resp = $resp;
62 19         43 last;
63             }
64 33 100       464 if (ref($matched_resp) eq 'HTTP::Response') {
    50          
65 27         79 return $matched_resp;
66             } elsif (ref($matched_resp) eq 'CODE') {
67 6         20 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 33816 my $mo = shift;
77              
78 21         46 my ($req, $resp) = @_;
79 21 100 66     118 if (!defined($req) || !defined($resp)) {
80 3         43 croak "You should pass 2 arguments in map()";
81             }
82 18 100       117 if (ref($req) !~ /^(HTTP::Request|Regexp|CODE|)$/) {
83 1         12 croak "Type of request must be HTTP::Request, regexp, coderef or plain string\n";
84             }
85 17 100       115 if (ref($resp) !~ /^(HTTP::Response|CODE)$/) {
86 1         11 croak "Type of response must be HTTP::Response or coderef\n";
87             }
88              
89 16         64 my $map = [$req, $resp];
90 16         30 push @{$mo->{_maps}}, $map;
  16         63  
91 16         23 return scalar(@{$mo->{_maps}}) - 1;
  16         57  
92             }
93              
94              
95             sub map_passthrough {
96 1     1 1 1142 my $mo = shift;
97              
98 1         4 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   9 return $mo->map($req, sub { return $orig_simple_request_fn->($mo, shift); });
  1         5  
104             }
105              
106              
107             sub unmap {
108 3     3 1 83466 my $mo = shift;
109 3         9 my $index = shift;
110 3 50 33     34 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         21  
116 0         0 warn "Index $index is out of maps range\n";
117 0         0 return;
118             }
119 3         21 delete $mo->{_maps}->[$index];
120 3         8 return 1;
121             }
122              
123              
124             sub unmap_all {
125 2     2 1 1252 my $mo = shift;
126 2         7 $mo->{_maps} = [];
127 2         9 return 1;
128             }
129              
130 9         53 my %mock_methods = (
131             simple_request => \&simple_request,
132             map => \&map,
133             map_passtrough => \&map_passthrough,
134             unmap => \&unmap,
135             unmap_all => \&unmap_all,
136             );
137              
138 9         96 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         854 $mock_ua = LWP::UserAgent->new;
142             }
143              
144             1;
145              
146             __END__