File Coverage

blib/lib/AnyEvent/HTTP/MultiGet.pm
Criterion Covered Total %
statement 54 55 98.1
branch 7 10 70.0
condition n/a
subroutine 13 13 100.0
pod 3 4 75.0
total 77 82 93.9


line stmt bran cond sub pod time code
1             package AnyEvent::HTTP::MultiGet;
2              
3 3     3   695 use Modern::Perl;
  3         7  
  3         20  
4 3     3   897 use Moo;
  3         2351  
  3         16  
5 3     3   1422 use MooX::Types::MooseLike::Base qw(:all);
  3         5724  
  3         944  
6 3     3   25 use Data::Dumper;
  3         6  
  3         188  
7 3     3   29 use Ref::Util qw(is_plain_arrayref);
  3         8  
  3         126  
8 3     3   16 use namespace::clean;
  3         6  
  3         36  
9             Log::Log4perl->wrapper_register(__PACKAGE__);
10              
11             BEGIN {
12 3     3   2364 extends 'HTTP::MultiGet';
13             }
14              
15             our $VERSION=$HTTP::MultiGet::VERSION;
16              
17             =head1 NAME
18              
19             AnyEvent::HTTP::MultiGet - AnyEvent->condvar Control Freindly LWP Like agent
20              
21             =head1 SYNOPSIS
22              
23             use Modern::Perl;
24             use AnyEvent::HTTP::MultiGet;
25              
26             my $self=AnyEvent::HTTP::MultiGet->new();
27             my $count=0;
28             TEST_LOOP: {
29             my $req=HTTP::Request->new(GET=>'http://google.com');
30             my $req_b=HTTP::Request->new(GET=>'https://127.0.0.1:5888');
31             my @todo=HTTP::Request->new(GET=>'http://yahoo.com');
32             push @todo,HTTP::Request->new(GET=>'http://news.com');
33             push @todo,HTTP::Request->new(GET=>'https://news.com');
34              
35             my $total=2 + scalar(@todo);
36             my $cv=AnyEvent->condvar;
37              
38             my $code;
39             $code=sub {
40             my ($obj,$request,$result)=@_;
41             printf 'HTTP Response code: %i'."\n",$result->code;
42             ++$count;
43             if(my $next=shift @todo) {
44             $self->add_cb($req,$code);
45             $self->run_next;
46             }
47             no warnings;
48             $cv->send if $total==$count;
49             };
50             $self->add_cb($req,$code);
51             $self->add_cb($req_b,$code);
52             $self->run_next;
53             $cv->recv;
54             }
55              
56             Handling Multiple large http requests at once
57              
58             use Modern::Perl;
59             use AnyEvent::HTTP::MultiGet;
60              
61             my $self=AnyEvent::HTTP::MultiGet->new();
62             my $chunks=0;
63             my $count=0;
64              
65              
66             my $req=HTTP::Request->new(GET=>'https://google.com');
67             my $req_b=HTTP::Request->new(GET=>'https://yahoo.com');
68             my $req_c=HTTP::Request->new(GET=>'https://news.com');
69             $total=3;
70              
71             my @todo;
72             push @todo,HTTP::Request->new(GET=>'https://127.0.0.1:5888');
73             push @todo,HTTP::Request->new(GET=>'https://127.0.0.1:5887');
74             push @todo,HTTP::Request->new(GET=>'https://127.0.0.1:5886');
75             push @todo,HTTP::Request->new(GET=>'https://127.0.0.1:5885');
76             $total +=scalar(@todo);
77              
78             TEST_LOOP: {
79             my $on_body=sub {
80             my ($getter,$request,$headers,$chunk)=@_;
81             # 0: Our AnyEvent::HTTP::MultiGet instance
82             # 1: the HTTP::Request object
83             # 2: An HTTP::Headers object representing the current headers
84             # 3: Current Data Chunk
85              
86             ++$chunks;
87             printf 'request is %s'."\n",$request->uri;
88             printf 'status code was: %i'."\n",$headers->header('Status');
89             printf 'content length was: %i'."\n",length($body);
90             };
91              
92             my $code;
93             my $cb=AnyEvent->condvar;
94             $code=sub {
95             my ($obj,$request,$result)=@_;
96             printf 'HTTP Response code: %i %s'."\n",$result->code,$request->url;
97             ++$count;
98             print "We are at response $count\n";
99             if(my $next=shift @todo) {
100             $self->add_cb([$next,on_body=>$on_body],$code);
101             $self->run_next;
102             }
103             no warnings;
104             $cv->send if $count==$total;
105             };
106             $self->add_cb([$req,on_body=>$on_body],$code);
107             $self->add_cb([$req_b,on_body=>$on_body],$code);
108             $self->add_cb([$req_c,on_body=>$on_body],$code);
109              
110             $self->run_next;
111             $cv->recv;
112             }
113              
114              
115              
116             =head1 DESCRIPTION
117              
118             This class provides an AnyEvent->condvar frienddly implementation of HTTP::MultiGet.
119              
120             =head1 OO Arguments and accessors
121              
122             Arguemnts and object accessors:
123              
124             logger: DOES(Log::Log4perl::Logger)
125             request_opts: See AnyEvent::HTTP params for details
126             timeout: Global timeout for everything
127             max_que_count: How many requests to run at once
128             max_retry: How many times to retry if we get a connection/negotiation error
129              
130             For internal use only:
131              
132             in_control_loop: true when in the control loop
133             stack: Data::Queue object
134             que_count: Total Number of elements active in the que
135             retry: Anonymous hash used to map ids to retry counts
136             cb_map: Anonymous hash used to map ids to callbacks
137              
138             =cut
139              
140             has cb_map=>(
141             is=>'ro',
142             isa=>HashRef,
143             default=>sub { {} },
144             required=>1,
145             );
146              
147             # This method runs after the new constructor
148             sub BUILD {
149 3     3 0 50 my ($self)=@_;
150             }
151              
152             # this method runs before the new constructor, and can be used to change the arguments passed to the module
153             around BUILDARGS => sub {
154             my ($org,$class,@args)=@_;
155            
156             return $class->$org(@args);
157             };
158              
159             =head1 OO Methods
160              
161             =over 4
162              
163             =item * my $id=$self->add_cb($request,$code)
164              
165             Adds a request with a callback handler.
166              
167             =item * my $id=$self->add_cb([$request,key=>value],$code);
168              
169             Wrapping [$request] allows passing additional key value to L<AnyEvent::HTTP::Request>, with one exception, on_body=>$code is wrapped an additional callback.
170              
171             =cut
172              
173             sub add_cb {
174 2     2 1 5 my ($self,$request,$code)=@_;
175 2         15 my ($id)=$self->add($request);
176 2 50       7 my $req=is_plain_arrayref($request) ? $request->[0] : $request;
177 2         9 $self->cb_map->{$id}=[$code,$req];
178 2         9 return $id;
179             }
180              
181             sub que_function {
182 2     2 1 4 my ($self,$req,$id)=@_;
183 2         9 my $code=$self->SUPER::que_function($req,$id);
184              
185             return sub {
186 2     2   395 $code->(@_);
187 2         8 $self->_common_handle_callback($id);
188 2         8 $self->run_next;
189 2         218 $self->log_always("our que count is: ".$self->que_count);
190 2         21 };
191             }
192              
193             sub _common_handle_callback {
194 8     8   19 my ($self,$id)=@_;
195 8 100       36 if(exists $self->cb_map->{$id}) {
196 2 50       47 if(exists $self->results->{$id}) {
197 2         18 my ($code,$req)=@{delete $self->cb_map->{$id}};
  2         9  
198 2         33 my $result=delete $self->results->{$id};
199 2         14 my $response;
200 2 50       6 if($result) {
201 2         105 $response=$result->get_data;
202             } else {
203 0         0 $response=$self->RESPONSE_CLASS->new('',{Status=>500,Reason=>"Request Timed out"})->to_http_message;
204             }
205 2         13 $code->($self,$req,$response);
206             }
207             } else {
208             }
209             }
210              
211             sub block_for_ids {
212 6     6 1 15 my ($self,@ids)=@_;
213 6         26 my $result=$self->SUPER::block_for_ids(@ids);
214              
215 6 100       1751 if($result) {
216 2         96 foreach my $id (@ids) {
217 2         7 $self->results->{$id}=$result->get_data->{$id};
218 2         55 $self->_common_handle_callback($id);
219 2         82 delete $self->results->{$id};
220             }
221             } else {
222 4         195 foreach my $id (@ids) {
223 4         11 $self->results->{$id}=$self->new_false("$result");
224 4         983 $self->_common_handle_callback($id);
225 4         64 delete $self->results->{$id};
226             }
227             }
228              
229 6         451 return $result;
230             }
231              
232             =back
233              
234             =head1 AUTHOR
235              
236             Michael Shipper <AKALINUX@CPAN.ORG>
237              
238             =cut
239              
240             1;