File Coverage

lib/Test/Mock/LWP/Conditional.pm
Criterion Covered Total %
statement 51 51 100.0
branch 12 12 100.0
condition 4 5 80.0
subroutine 14 14 100.0
pod 2 2 100.0
total 83 84 98.8


line stmt bran cond sub pod time code
1             package Test::Mock::LWP::Conditional;
2              
3 7     7   924961 use 5.008001;
  7         21  
4 7     7   24 use strict;
  7         7  
  7         109  
5 7     7   22 use warnings;
  7         9  
  7         158  
6 7     7   3937 use LWP::UserAgent;
  7         76918  
  7         212  
7 7     7   44 use Scalar::Util qw(blessed refaddr);
  7         17  
  7         435  
8 7     7   3378 use Sub::Install qw(install_sub);
  7         8002  
  7         23  
9 7     7   3674 use Class::Method::Modifiers qw(install_modifier);
  7         7520  
  7         391  
10 7     7   3196 use Math::Random::Secure qw(irand);
  7         835232  
  7         473  
11 7     7   2287 use Test::Mock::LWP::Conditional::Stubs;
  7         10  
  7         3129  
12              
13             our $VERSION = '0.04';
14             $VERSION = eval $VERSION;
15              
16             our $Stubs = +{ __GLOBAL__ => +{} };
17             our $Regex = +{ __GLOBAL__ => +{} };
18              
19             sub _set_stub {
20 15     15   30 my ($key, $uri, $res) = @_;
21              
22 15   100     129 $Stubs->{$key} ||= +{};
23              
24 15 100       63 if (ref $uri eq 'Regexp') {
25 2         23 my $rng = irand('9999999999999999');
26 2         46382 $Regex->{$key}->{$rng} = $uri;
27 2         8 $uri = $rng;
28             }
29              
30 15   66     371 $Stubs->{$key}->{$uri} ||= Test::Mock::LWP::Conditional::Stubs->new;
31 15         65 $Stubs->{$key}->{$uri}->add($res);
32             }
33              
34             sub _get_stub {
35 37     37   220 my ($key, $uri) = @_;
36              
37 37 100       210 if (exists $Stubs->{$key}) {
    100          
38 9 100       33 if (exists $Stubs->{$key}->{$uri}) {
39 6         56 return $Stubs->{$key}->{$uri};
40             }
41 3         18 return _check_regex($key, $uri);
42             }
43             elsif (exists $Stubs->{__GLOBAL__}->{$uri}) {
44 17         112 return $Stubs->{__GLOBAL__}->{$uri};
45             } else {
46 11         104 return _check_regex("__GLOBAL__", $uri);
47             }
48             }
49              
50             sub _check_regex {
51 14     14   57 my ($key, $uri) = @_;
52              
53 14         20 foreach my $marker (keys %{$Regex->{$key}}) {
  14         115  
54 5 100       21 if ($uri =~ $Regex->{$key}->{$marker}) {
55 4         41 return $Stubs->{$key}->{$marker};
56             }
57             }
58             }
59              
60             sub stub_request {
61 15     15 1 303721 my ($self, $uri, $res) = @_;
62 15 100       121 my $key = blessed($self) ? refaddr($self) : '__GLOBAL__';
63 15         222 _set_stub($key, $uri, $res);
64             }
65              
66             sub reset_all {
67 1     1 1 479 $Stubs = +{ __GLOBAL__ => +{} };
68 1         27 $Regex = +{ __GLOBAL__ => +{} };
69             }
70              
71             { # LWP::UserAgent injection
72             install_modifier('LWP::UserAgent', 'around', 'simple_request', sub {
73             my $orig = shift;
74             my ($self, $req, @rest) = @_;
75              
76             my $stub = _get_stub(refaddr($self), $req->uri);
77             return $stub ? $stub->execute($req) : $orig->(@_);
78             });
79              
80             install_sub({
81             code => __PACKAGE__->can('stub_request'),
82             into => 'LWP::UserAgent',
83             as => 'stub_request',
84             });
85             }
86              
87             1;
88              
89             =head1 NAME
90              
91             Test::Mock::LWP::Conditional - stubbing on LWP request
92              
93             =head1 SYNOPSIS
94              
95             use LWP::UserAgent;
96             use HTTP::Response;
97              
98             use Test::More
99             use Test::Mock::LWP::Conditional;
100              
101             my $uri = 'http://example.com/';
102              
103             # global
104             Test::Mock::LWP::Conditional->stub_request($uri => HTTP::Response->new(503));
105             is LWP::UserAgent->new->get($uri)->code => 503;
106              
107             # lexical
108             my $ua = LWP::UserAgent->new;
109             $ua->stub_request($uri => sub { HTTP::Response->new(500) });
110             is $ua->get($uri)->code => 500;
111             is LWP::UserAgent->new->get($uri)->code => 503;
112              
113             # reset
114             Test::Mock::LWP::Conditional->reset_all;
115             is $ua->get($uri)->code => 200;
116             is LWP::UserAgent->new->get($uri)->code => 200;
117              
118             =head1 DESCRIPTION
119              
120             This module stubs out LWP::UserAgent's request.
121              
122             =head1 METHODS
123              
124             =over 4
125              
126             =item * stub_request($uri, $res)
127              
128             Sets stub response for requesed URI.
129              
130             =item * reset_all
131              
132             Clear all stub requests.
133              
134             =back
135              
136             =head1 AUTHOR
137              
138             NAKAGAWA Masaki Emasaki@cpan.orgE
139              
140             =head1 LICENSE
141              
142             This library is free software; you can redistribute it and/or modify
143             it under the same terms as Perl itself.
144              
145             =head1 SEE ALSO
146              
147             L, L, L, L
148              
149             L
150              
151             L, L
152              
153             =cut