Commit ed8ccbbf6a369d01de32763210360505885557f1 - libhttp-async-perl

[svn-inject] Installing original source of libhttp-async-perl (0.09) Ernesto Hernández-Novich 13 years ago

27 changed file(s) with 2059 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all

+67

-0

CHANGES less more

	0	CHANGES to HTTP::Async
	1
	2	0.09 - Thu Sep 13 18:58:13 BST 2007
	3
	4	* added requirement for Pod::Coverage >= 0.19 if perl >= 5.9.0
	5
	6	* moved polite.t test into t/ so that it gets run by the makefile.
	7
	8	0.08 - Wed Sep 12 22:35:33 BST 2007
	9
	10	* Deleted Module::Build
	11
	12	* Removed test in bad-hosts.t that was unreliable. I think that it was failing
	13	under certain proxy configs.
	14
	15	0.07 - Sun Feb 18 15:00:46 GMT 2007
	16
	17	* Added proper handling of 304 responses based on code patch and test by
	18	Tomohiro Ikebe from livedoor.jp
	19
	20	0.06 - Tue Feb 6 10:48:15 GMT 2007
	21
	22	* Changed the request uri that is used so that it has the host in for proxy
	23	requests and does not otherwise. This is to comply with the RFC for HTTP
	24	( http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.1.2 ).
	25
	26	0.05 - Fri Nov 17 08:42:49 GMT 2006
	27
	28	* Added ability to pass arguments to new to configure the async object.
	29
	30	0.04 - Thu Sep 28 13:42:25 BST 2006
	31
	32	* Fixed stupid bug that caused the polite module to crash if the numbers of
	33	requests per domain were not the same.
	34
	35	0.03 - Wed Sep 27 11:00:14 BST 2006
	36
	37	* Created HTTP::Async::Polite that adds limits to the scraping to avoid over
	38	stretching the domain being scraped.
	39
	40	* Increased the delay in poll-interval tests to stop them failing on slow
	41	machines.
	42
	43	* Added pod tests, README and Makefile.PL in an attempt to achieve kwalitee.
	44
	45	0.02 - Wed Sep 6 09:36:01 BST 2006 - svn r30
	46
	47	* Changed the timeout to be an inactivity timeout and added a
	48	max_request_length to limit the amount of time that a request can be
	49	running for.
	50
	51	* Added more diagnostics to the tests to try to find the bug that is causing
	52	MIYAGAWA issues.
	53
	54	* Created TODO and CHANGES docs.
	55
	56	* Added error checking to catch connections that fail before the headers are
	57	sent. (patch submitted by Egor Egorov)
	58
	59	* Added ability to specify proxy to use. (based on patch from Egor Egorov)
	60
	61	* Added 'add_with_opts' method that lets you override the default options
	62	for this request.
	63
	64	0.01 - XXXXXXXXXX - svn r24
	65
	66	* Initial release onto CPAN.⏎

+27

-0

MANIFEST less more

	0	CHANGES
	1	diffs/connect.timeout.diff
	2	lib/HTTP/Async.pm
	3	lib/HTTP/Async/Polite.pm
	4	Makefile.PL
	5	MANIFEST This list of files
	6	README
	7	t/bad-connections.t
	8	t/bad-headers.t
	9	t/bad-hosts.t
	10	t/make-url-absolute.t
	11	t/not_modified.t
	12	t/pod-coverage.t
	13	t/pod.t
	14	t/polite.t
	15	t/poll-interval.t
	16	t/proxy.t
	17	t/real-servers.t
	18	t/redirects.t
	19	t/setup.t
	20	t/strip_host_from_uri.t
	21	t/template.t
	22	t/test_utils.pl
	23	t/TestServer.pm
	24	t/timeout.t
	25	TODO
	26	META.yml Module meta-data (added by MakeMaker)

+26

-0

META.yml less more

	0	--- #YAML:1.0
	1	name: HTTP-Async
	2	version: 0.09
	3	abstract: ~
	4	license: ~
	5	generated_by: ExtUtils::MakeMaker version 6.32
	6	distribution_type: module
	7	requires:
	8	Carp: 0
	9	Data::Dumper: 0
	10	HTTP::Request: 0
	11	HTTP::Response: 0
	12	HTTP::Server::Simple::CGI: 0
	13	HTTP::Status: 0
	14	IO::Select: 0
	15	LWP::UserAgent: 0
	16	Net::HTTP: 0
	17	Net::HTTP::NB: 0
	18	Test::HTTP::Server::Simple: 0
	19	Test::More: 0
	20	Time::HiRes: 0
	21	URI: 0
	22	URI::Escape: 0
	23	meta-spec:
	24	url: http://module-build.sourceforge.net/META-spec-v1.2.html
	25	version: 1.2

+26

-0

Makefile.PL less more

	0	use strict;
	1	use warnings;
	2
	3	use ExtUtils::MakeMaker;
	4
	5	WriteMakefile(
	6	'NAME' => 'HTTP::Async',
	7	'VERSION_FROM' => 'lib/HTTP/Async.pm',
	8	'PREREQ_PM' => {
	9	'Carp' => 0,
	10	'Data::Dumper' => 0,
	11	'HTTP::Request' => 0,
	12	'HTTP::Response' => 0,
	13	'HTTP::Server::Simple::CGI' => 0,
	14	'HTTP::Status' => 0,
	15	'IO::Select' => 0,
	16	'LWP::UserAgent' => 0,
	17	'Net::HTTP' => 0,
	18	'Net::HTTP::NB' => 0,
	19	'Test::HTTP::Server::Simple' => 0,
	20	'Test::More' => 0,
	21	'Time::HiRes' => 0,
	22	'URI' => 0,
	23	'URI::Escape' => 0,
	24	},
	25	);

+21

-0

README less more

	0	HTTP::Async
	1
	2	This module lets you process several HTTP connections at once, in parallel and
	3	without blocking.
	4
	5	INSTALLATION
	6
	7	To install you can use the following commands:
	8
	9	perl Makefile.PL
	10	make
	11	make test
	12	make install
	13
	14
	15	COPYRIGHT AND LICENCE
	16
	17	Copyright (C) 2006, Edmund von der Burg
	18
	19	This library is free software; you can redistribute it and/or modify
	20	it under the same terms as Perl itself.

+32

-0

TODO less more

	0	TODOs for HTTP::Async
	1
	2	* Add ability to pass in a file handle that will be used to store the
	3	content in. Aimed at people downloading large files that would otherwise
	4	fill up the memory. Could be done so that downloads greater than a certain
	5	size get sent to file rather than to memory. How to return this in the
	6	HTTP::Response though.
	7
	8	* Do what is needed to get CPANTS tests to pass / run.
	9
	10	* Make sending non blocking - both the data and the initial DNS lookup.
	11
	12	* Integrate the changes from Egor - set alarm to catch connection timeout.
	13
	14	* Change max_redirects to max_redirect to be consistent with LWP::UserAgent
	15
	16	* Add a max_content_size that will break connections if the content is to
	17	big - default is no limit.
	18
	19	* Switch to using Test::Class so that the tests are faster as they don't
	20	spend so much time starting and stopping the test server(s).
	21
	22	* Change tests so that the port used is chosen so as not to conflict with a
	23	port that is already in use.
	24
	25	* Change the user agent so that if it is not set in the request passed in then
	26	it defaults to 'HTTP::Async vx.xx' or some such. Should also be possible to
	27	set it in the opts or in the HTTP::Request.
	28
	29	* Add 'info' sub that can be linked to SIGINFO to provide a summary of what is
	30	going on eg "print $async->info( 'terse' )".
	31

+59

-0

diffs/connect.timeout.diff less more

	0	6c6
	1	< our $VERSION = '0.03';
	2	---
	3	> our $VERSION = '0.04';
	4	87,90c87,91
	5	< slots: 20
	6	< timeout: 180 (seconds)
	7	< max_redirects: 7
	8	< poll_interval: 0.05 (seconds)
	9	---
	10	> slots: 20
	11	> timeout: 180 (seconds)
	12	> connect_timeout: 30 (seconds)
	13	> max_redirects: 7
	14	> poll_interval: 0.05 (seconds)
	15	105,108c106,110
	16	< slots => 20,
	17	< max_redirects => 7,
	18	< timeout => 180,
	19	< poll_interval => 0.05,
	20	---
	21	> slots => 20,
	22	> max_redirects => 7,
	23	> timeout => 180,
	24	> connect_timeout => 30,
	25	> poll_interval => 0.05,
	26	122c124
	27	< =head2 slots, timeout, poll_interval and max_redirects
	28	---
	29	> =head2 slots, timeout, connect_timeout, poll_interval and max_redirects
	30	127c129
	31	< Get/setters for the C<$async> objects config settings. Timeout is in seconds
	32	---
	33	> Get/setters for the C<$async> objects config settings. Timeouts are in seconds
	34	145a148,153
	35	> sub connect_timeout {
	36	> my $self = shift;
	37	> $$self{connect_timeout} = shift if @_;
	38	> return $$self{connect_timeout};
	39	> }
	40	>
	41	538,539c546,553
	42	< my $s =
	43	< eval { Net::HTTP::NB->new(%$arguments) };
	44	---
	45	>
	46	> my $s;
	47	> eval {
	48	> local $SIG{ALRM} = sub { die "Connect timeout\n" }; # NB: \n required
	49	> alarm($self->connect_timeout());
	50	> $s=Net::HTTP::NB->new(%$arguments);
	51	> alarm(0);
	52	> };
	53	543,544c557
	54	< if ( !$s ) {
	55	<
	56	---
	57	> if (!$s) {
	58

+208

-0

lib/HTTP/Async/Polite.pm less more

	0	use strict;
	1	use warnings;
	2
	3	package HTTP::Async::Polite;
	4	use base 'HTTP::Async';
	5
	6	our $VERSION = '0.05';
	7
	8	use Carp;
	9	use Data::Dumper;
	10	use Time::HiRes qw( time sleep );
	11	use URI;
	12
	13	=head1 NAME
	14
	15	HTTP::Async::Polite - politely process multiple HTTP requests
	16
	17	=head1 SYNOPSIS
	18
	19	See L<HTTP::Async> - the usage is unchanged.
	20
	21	=head1 DESCRIPTION
	22
	23	This L<HTTP::Async> module allows you to have many requests going on at once.
	24	This can be very rude if you are fetching several pages from the same domain.
	25	This module add limits to the number of simultaneous requests to a given
	26	domain and adds an interval between the requests.
	27
	28	In all other ways it is identical in use to the original L<HTTP::Async>.
	29
	30	=head1 NEW METHODS
	31
	32	=head2 send_interval
	33
	34	Getter and setter for the C<send_interval> - the time in seconds to leave
	35	between each request for a given domain. By default this is set to 5 seconds.
	36
	37	=cut
	38
	39	sub send_interval {
	40	my $self = shift;
	41	return scalar @_
	42	? $self->_set_opt( 'send_interval', @_ )
	43	: $self->_get_opt('send_interval');
	44	}
	45
	46	=head1 OVERLOADED METHODS
	47
	48	These methods are overloaded but otherwise work exactly as the original
	49	methods did. The docs here just describe what they do differently.
	50
	51	=head2 new
	52
	53	Sets the C<send_interval> value to the default of 5 seconds.
	54
	55	=cut
	56
	57	sub new {
	58	my $class = shift;
	59
	60	my $self = $class->SUPER::new;
	61
	62	# Set the interval between sends.
	63	$self->{opts}{send_interval} = 5; # seconds
	64	$class->_add_get_set_key('send_interval');
	65
	66	$self->_init(@_);
	67
	68	return $self;
	69	}
	70
	71	=head2 add_with_opts
	72
	73	Adds the request to the correct queue depending on the domain.
	74
	75	=cut
	76
	77	sub add_with_opts {
	78	my $self = shift;
	79	my $req = shift;
	80	my $opts = shift;
	81	my $id = $self->_next_id;
	82
	83	# Instead of putting this request and opts directly onto the to_send array
	84	# instead get the domain and add it to the domain's queue. Store this
	85	# domain with the opts so that it is easy to get at.
	86	my $uri = URI->new( $req->uri );
	87	my $host = $uri->host;
	88	my $port = $uri->port;
	89	my $domain = "$host:$port";
	90	$opts->{_domain} = $domain;
	91
	92	# Get the domain array - create it if needed.
	93	my $domain_arrayref = $self->{domain_stats}{$domain}{to_send} \|\|= [];
	94
	95	push @{$domain_arrayref}, [ $req, $id ];
	96	$self->{id_opts}{$id} = $opts;
	97
	98	$self->poke;
	99
	100	return $id;
	101	}
	102
	103	=head2 to_send_count
	104
	105	Returns the number of requests waiting to be sent. This is the number in the
	106	actual queue plus the number in each domain specific queue.
	107
	108	=cut
	109
	110	sub to_send_count {
	111	my $self = shift;
	112	$self->poke;
	113
	114	my $count = scalar @{ $$self{to_send} };
	115
	116	$count += scalar @{ $self->{domain_stats}{$_}{to_send} }
	117	for keys %{ $self->{domain_stats} };
	118
	119	return $count;
	120	}
	121
	122	sub _process_to_send {
	123	my $self = shift;
	124
	125	# Go through the domain specific queues and add all requests that we can
	126	# to the real queue.
	127	foreach my $domain ( keys %{ $self->{domain_stats} } ) {
	128
	129	my $domain_stats = $self->{domain_stats}{$domain};
	130	next unless scalar @{ $domain_stats->{to_send} };
	131
	132	# warn "TRYING TO ADD REQUEST FOR $domain";
	133	# warn sleep 5;
	134
	135	# Check that this request is good to go.
	136	next if $domain_stats->{count};
	137	next unless time > ( $domain_stats->{next_send} \|\| 0 );
	138
	139	# We can add this request.
	140	$domain_stats->{count}++;
	141	push @{ $self->{to_send} }, shift @{ $domain_stats->{to_send} };
	142	}
	143
	144	# Use the original to send the requests on the queue.
	145	return $self->SUPER::_process_to_send;
	146	}
	147
	148	sub _add_to_return_queue {
	149	my $self = shift;
	150	my $req_and_id = shift;
	151
	152	# decrement the count for this domain so that another request can start.
	153	# Also set the interval so that we don't scrape too fast.
	154	my $id = $req_and_id->[1];
	155	my $domain = $self->{id_opts}{$id}{_domain};
	156	my $domain_stat = $self->{domain_stats}{$domain};
	157	my $interval = $self->_get_opt( 'send_interval', $id );
	158
	159	$domain_stat->{count}--;
	160	$domain_stat->{next_send} = time + $interval;
	161
	162	return $self->SUPER::_add_to_return_queue($req_and_id);
	163	}
	164
	165	=head1 SEE ALSO
	166
	167	L<HTTP::Async> - the module that this one is based on.
	168
	169	=head1 AUTHOR
	170
	171	Edmund von der Burg C<< <evdb@ecclestoad.co.uk> >>.
	172
	173	L<http://www.ecclestoad.co.uk/>
	174
	175	=head1 LICENCE AND COPYRIGHT
	176
	177	Copyright (c) 2006, Edmund von der Burg C<< <evdb@ecclestoad.co.uk> >>.
	178	All rights reserved.
	179
	180	This module is free software; you can redistribute it and/or modify it under
	181	the same terms as Perl itself.
	182
	183	=head1 DISCLAIMER OF WARRANTY
	184
	185	BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE
	186	SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE
	187	STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE
	188	SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED,
	189	INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
	190	FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
	191	PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE,
	192	YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
	193
	194	IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY
	195	COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE
	196	SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES,
	197	INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING
	198	OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO
	199	LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR
	200	THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER
	201	SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
	202	POSSIBILITY OF SUCH DAMAGES.
	203
	204	=cut
	205
	206	1;
	207

+772

-0

lib/HTTP/Async.pm less more

	0	use strict;
	1	use warnings;
	2
	3	package HTTP::Async;
	4
	5	our $VERSION = '0.09';
	6
	7	use Carp;
	8	use Data::Dumper;
	9	use HTTP::Response;
	10	use IO::Select;
	11	use Net::HTTP::NB;
	12	use Net::HTTP;
	13	use URI;
	14	use Time::HiRes qw( time sleep );
	15
	16	=head1 NAME
	17
	18	HTTP::Async - process multiple HTTP requests in parallel without blocking.
	19
	20	=head1 SYNOPSIS
	21
	22	Create an object and add some requests to it:
	23
	24	use HTTP::Async;
	25	my $async = HTTP::Async->new;
	26
	27	# create some requests and add them to the queue.
	28	$async->add( HTTP::Request->new( GET => 'http://www.perl.org/' ) );
	29	$async->add( HTTP::Request->new( GET => 'http://www.ecclestoad.co.uk/' ) );
	30
	31	and then EITHER process the responses as they come back:
	32
	33	while ( my $response = $async->wait_for_next_response ) {
	34	# Do some processing with $response
	35	}
	36
	37	OR do something else if there is no response ready:
	38
	39	while ( $async->not_empty ) {
	40	if ( my $response = $async->next_response ) {
	41	# deal with $response
	42	} else {
	43	# do something else
	44	{
	45	}
	46
	47	OR just use the async object to fetch stuff in the background and deal with
	48	the responses at the end.
	49
	50	# Do some long code...
	51	for ( 1 .. 100 ) {
	52	some_function();
	53	$async->poke; # lets it check for incoming data.
	54	}
	55
	56	while ( my $response = $async->wait_for_next_response ) {
	57	# Do some processing with $response
	58	}
	59
	60	=head1 DESCRIPTION
	61
	62	Although using the conventional C<LWP::UserAgent> is fast and easy it does
	63	have some drawbacks - the code execution blocks until the request has been
	64	completed and it is only possible to process one request at a time.
	65	C<HTTP::Async> attempts to address these limitations.
	66
	67	It gives you a 'Async' object that you can add requests to, and then get the
	68	requests off as they finish. The actual sending and receiving of the requests
	69	is abstracted. As soon as you add a request it is transmitted, if there are
	70	too many requests in progress at the moment they are queued. There is no
	71	concept of starting or stopping - it runs continuously.
	72
	73	Whilst it is waiting to receive data it returns control to the code that
	74	called it meaning that you can carry out processing whilst fetching data from
	75	the network. All without forking or threading - it is actually done using
	76	C<select> lists.
	77
	78	=head1 Default settings:
	79
	80	There are a number of default settings that should be suitable for most uses.
	81	However in some circumstances you might wish to change these.
	82
	83	slots: 20
	84	timeout: 180 (seconds)
	85	max_request_time: 300 (seconds)
	86	max_redirects: 7
	87	poll_interval: 0.05 (seconds)
	88	proxy_host: ''
	89	proxy_port: ''
	90
	91	=head1 METHODS
	92
	93	=head2 new
	94
	95	my $async = HTTP::Async->new( %args );
	96
	97	Creates a new HTTP::Async object and sets it up. Variations from the default
	98	can be set by passing them in as C<%args>.
	99
	100	=cut
	101
	102	sub new {
	103	my $class = shift;
	104	my $self = bless {
	105
	106	opts => {
	107	slots => 20,
	108	max_redirects => 7,
	109	timeout => 180,
	110	max_request_time => 300,
	111	poll_interval => 0.05,
	112	},
	113
	114	id_opts => {},
	115
	116	to_send => [],
	117	in_progress => {},
	118	to_return => [],
	119
	120	current_id => 0,
	121	fileno_to_id => {},
	122	}, $class;
	123
	124	$self->_init(@_);
	125
	126	return $self;
	127	}
	128
	129	sub _init {
	130	my $self = shift;
	131	my %args = @_;
	132	$self->_set_opt( $_ => $args{$_} ) for sort keys %args;
	133	return $self;
	134	}
	135
	136	sub _next_id { return ++$_[0]->{current_id} }
	137
	138	=head2 slots, timeout, max_request_time, poll_interval, max_redirects, proxy_host and proxy_port
	139
	140	$old_value = $async->slots;
	141	$new_value = $async->slots( $new_value );
	142
	143	Get/setters for the C<$async> objects config settings. Timeout is for
	144	inactivity and is in seconds.
	145
	146	Slots is the maximum number of parallel requests to make.
	147
	148	=cut
	149
	150	my %GET_SET_KEYS =
	151	map { $_ => 1 }
	152	qw( slots poll_interval
	153	timeout max_request_time max_redirects
	154	proxy_host proxy_port );
	155
	156	sub _add_get_set_key {
	157	my $class = shift;
	158	my $key = shift;
	159	$GET_SET_KEYS{$key} = 1;
	160	}
	161
	162	sub _get_opt {
	163	my $self = shift;
	164	my $key = shift;
	165	my $id = shift;
	166	die "$key not valid for _get_opt" unless $GET_SET_KEYS{$key};
	167
	168	# If there is an option set for this id then use that, otherwise fall back
	169	# to the defaults.
	170	return $self->{id_opts}{$id}{$key}
	171	if $id && defined $self->{id_opts}{$id}{$key};
	172
	173	return $self->{opts}{$key};
	174
	175	}
	176
	177	sub _set_opt {
	178	my $self = shift;
	179	my $key = shift;
	180	die "$key not valid for _set_opt" unless $GET_SET_KEYS{$key};
	181	$self->{opts}{$key} = shift if @_;
	182	return $self->{opts}{$key};
	183	}
	184
	185	foreach my $key ( keys %GET_SET_KEYS ) {
	186	eval "
	187	sub $key {
	188	my \$self = shift;
	189	return scalar \@_
	190	? \$self->_set_opt( '$key', \@_ )
	191	: \$self->_get_opt( '$key' );
	192	}
	193	";
	194	}
	195
	196	=head2 add
	197
	198	my @ids = $async->add(@requests);
	199	my $first_id = $async->add(@requests);
	200
	201	Adds requests to the queues. Each request is given an unique integer id (for
	202	this C<$async>) that can be used to track the requests if needed. If called in
	203	list context an array of ids is returned, in scalar context the id of the
	204	first request added is returned.
	205
	206	=cut
	207
	208	sub add {
	209	my $self = shift;
	210	my @returns = ();
	211
	212	foreach my $req (@_) {
	213	push @returns, $self->add_with_opts( $req, {} );
	214	}
	215
	216	return wantarray ? @returns : $returns[0];
	217	}
	218
	219	=head2 add_with_opts
	220
	221	my $id = $async->add_with_opts( $request, \%opts );
	222
	223	This method lets you add a single request to the queue with options that
	224	differ from the defaults. For example you might wish to set a longer timeout
	225	or to use a specific proxy. Returns the id of the request.
	226
	227	=cut
	228
	229	sub add_with_opts {
	230	my $self = shift;
	231	my $req = shift;
	232	my $opts = shift;
	233	my $id = $self->_next_id;
	234
	235	push @{ $$self{to_send} }, [ $req, $id ];
	236	$self->{id_opts}{$id} = $opts;
	237	$self->poke;
	238
	239	return $id;
	240	}
	241
	242	=head2 poke
	243
	244	$async->poke;
	245
	246	At fairly frequent intervals some housekeeping needs to performed - such as
	247	reading recieved data and starting new requests. Calling C<poke> lets the
	248	object do this and then return quickly. Usually you will not need to use this
	249	as most other methods do it for you.
	250
	251	You should use C<poke> if your code is spending time elsewhere (ie not using
	252	the async object) to allow it to keep the data flowing over the network. If it
	253	is not used then the buffers may fill up and completed responses will not be
	254	replaced with new requests.
	255
	256	=cut
	257
	258	sub poke {
	259	my $self = shift;
	260
	261	$self->_process_in_progress;
	262	$self->_process_to_send;
	263
	264	return 1;
	265	}
	266
	267	=head2 next_response
	268
	269	my $response = $async->next_response;
	270	my ( $response, $id ) = $async->next_response;
	271
	272	Returns the next response (as a L<HTTP::Response> object) that is waiting, or
	273	returns undef if there is none. In list context it returns a (response, id)
	274	pair, or an empty list if none. Does not wait for a response so returns very
	275	quickly.
	276
	277	=cut
	278
	279	sub next_response {
	280	my $self = shift;
	281	return $self->_next_response(0);
	282	}
	283
	284	=head2 wait_for_next_response
	285
	286	my $response = $async->wait_for_next_response( 3.5 );
	287	my ( $response, $id ) = $async->wait_for_next_response( 3.5 );
	288
	289	As C<next_response> but only returns if there is a next response or the time
	290	in seconds passed in has elapsed. If no time is given then it blocks. Whilst
	291	waiting it checks the queues every c<poll_interval> seconds. The times can be
	292	fractional seconds.
	293
	294	=cut
	295
	296	sub wait_for_next_response {
	297	my $self = shift;
	298	my $wait_for = shift;
	299
	300	$wait_for = $self->max_request_time
	301	if !defined $wait_for;
	302
	303	return $self->_next_response($wait_for);
	304	}
	305
	306	sub _next_response {
	307	my $self = shift;
	308	my $wait_for = shift \|\| 0;
	309	my $end_time = time + $wait_for;
	310	my $resp_and_id = undef;
	311
	312	while ( !$self->empty ) {
	313	$resp_and_id = shift @{ $$self{to_return} };
	314
	315	# last if we have a response or we have run out of time.
	316	last
	317	if $resp_and_id
	318	\|\| time > $end_time;
	319
	320	# sleep for the default sleep time.
	321	# warn "sleeping for " . $self->poll_interval;
	322	sleep $self->poll_interval;
	323	}
	324
	325	# If there is no result return false.
	326	return unless $resp_and_id;
	327
	328	# We have a response - delete the options for it from the store.
	329	delete $self->{id_opts}{ $resp_and_id->[1] };
	330
	331	# If we have a result return list or response depending on
	332	# context.
	333	return wantarray
	334	? @$resp_and_id
	335	: $resp_and_id->[0];
	336	}
	337
	338	=head2 to_send_count, to_return_count, in_progress_count and total_count
	339
	340	my $pending = $async->to_send_count;
	341
	342	Returns the number of items in the various stages of processing.
	343
	344	=cut
	345
	346	sub to_send_count { my $s = shift; $s->poke; scalar @{ $$s{to_send} }; }
	347	sub to_return_count { my $s = shift; $s->poke; scalar @{ $$s{to_return} }; }
	348
	349	sub in_progress_count {
	350	my $s = shift;
	351	$s->poke;
	352	scalar keys %{ $$s{in_progress} };
	353	}
	354
	355	sub total_count {
	356	my $self = shift;
	357
	358	my $count = 0 #
	359	+ $self->to_send_count #
	360	+ $self->in_progress_count #
	361	+ $self->to_return_count;
	362
	363	return $count;
	364	}
	365
	366	=head2 info
	367
	368	print $async->info;
	369
	370	Prints a line describing what the current state is.
	371
	372	=cut
	373
	374	sub info {
	375	my $self = shift;
	376
	377	return sprintf(
	378	"HTTP::Async status: %4u,%4u,%4u (send, progress, return)\n",
	379	$self->to_send_count, #
	380	$self->in_progress_count, #
	381	$self->to_return_count
	382	);
	383	}
	384
	385	=head2 empty, not_empty
	386
	387	while ( $async->not_empty ) { ...; }
	388	while (1) { ...; last if $async->empty; }
	389
	390	Returns true or false depending on whether there are request or responses
	391	still on the object.
	392
	393	=cut
	394
	395	sub empty {
	396	my $self = shift;
	397	return $self->total_count ? 0 : 1;
	398	}
	399
	400	sub not_empty {
	401	my $self = shift;
	402	return !$self->empty;
	403	}
	404
	405	=head2 DESTROY
	406
	407	The destroy method croaks if an object is destroyed but is not empty. This is
	408	to help with debugging.
	409
	410	=cut
	411
	412	sub DESTROY {
	413	my $self = shift;
	414	my $class = ref $self;
	415
	416	carp "$class object destroyed but still in use"
	417	if $self->total_count;
	418
	419	carp "$class INTERNAL ERROR: 'id_opts' not empty"
	420	if scalar keys %{ $self->{id_opts} };
	421
	422	return;
	423	}
	424
	425	# Go through all the values on the select list and check to see if
	426	# they have been fully received yet.
	427
	428	sub _process_in_progress {
	429	my $self = shift;
	430
	431	HANDLE:
	432	foreach my $s ( $self->_io_select->can_read(0) ) {
	433
	434	my $id = $self->{fileno_to_id}{ $s->fileno };
	435	die unless $id;
	436	my $hashref = $$self{in_progress}{$id};
	437	my $tmp = $hashref->{tmp} \|\|= {};
	438
	439	# warn Dumper $hashref;
	440
	441	# Check that we have not timed-out.
	442	if ( time > $hashref->{timeout_at}
	443	\|\| time > $hashref->{finish_by} )
	444	{
	445
	446	# warn sprintf "Timeout: %.3f > %.3f", #
	447	# time, $hashref->{timeout_at};
	448
	449	$self->_add_error_response_to_return(
	450	id => $id,
	451	code => 504,
	452	request => $hashref->{request},
	453	previous => $hashref->{previous},
	454	content => 'Timed out',
	455	);
	456
	457	$self->_io_select->remove($s);
	458	delete $$self{fileno_to_id}{ $s->fileno };
	459	next HANDLE;
	460	}
	461
	462	# If there is a code then read the body.
	463	if ( $$tmp{code} ) {
	464	my $buf;
	465	my $n = $s->read_entity_body( $buf, 1024 * 16 ); # 16kB
	466	$$tmp{is_complete} = 1 unless $n;
	467	$$tmp{content} .= $buf;
	468
	469	# warn "Received " . length( $buf ) ;
	470
	471	# Reset the timeout.
	472	# warn( "reseting the timeout " . time );
	473	$hashref->{timeout_at} = time + $self->_get_opt( 'timeout', $id );
	474
	475	# warn $buf;
	476	}
	477
	478	# If no code try to read the headers.
	479	else {
	480	$s->flush;
	481
	482	my ( $code, $message, %headers );
	483
	484	eval {
	485	( $code, $message, %headers ) =
	486	$s->read_response_headers( laxed => 1, junk_out => [] );
	487	};
	488
	489	if ($@) {
	490	$self->_add_error_response_to_return(
	491	'code' => 504,
	492	'content' => $@,
	493	'id' => $id,
	494	'request' => $hashref->{request},
	495	'previous' => $hashref->{previous}
	496	);
	497	$self->_io_select->remove($s);
	498	delete $$self{fileno_to_id}{ $s->fileno };
	499	next HANDLE;
	500	}
	501
	502	if ($code) {
	503
	504	# warn "Got headers: $code $message " . time;
	505
	506	$$tmp{code} = $code;
	507	$$tmp{message} = $message;
	508	my @headers_array = map { $_, $headers{$_} } keys %headers;
	509	$$tmp{headers} = \@headers_array;
	510
	511	# Reset the timeout.
	512	$hashref->{timeout_at} =
	513	time + $self->_get_opt( 'timeout', $id );
	514	}
	515	}
	516
	517	# If the message is complete then create a request and add it
	518	# to 'to_return';
	519	if ( $$tmp{is_complete} ) {
	520	delete $$self{fileno_to_id}{ $s->fileno };
	521	$self->_io_select->remove($s);
	522
	523	# warn Dumper $$hashref{content};
	524
	525	my $response =
	526	HTTP::Response->new(
	527	@$tmp{ 'code', 'message', 'headers', 'content' } );
	528
	529	$response->request( $hashref->{request} );
	530	$response->previous( $hashref->{previous} ) if $hashref->{previous};
	531
	532	# If it was a redirect and there are still redirects left
	533	# create a new request and unshift it onto the 'to_send'
	534	# array.
	535	if (
	536	$response->is_redirect # is a redirect
	537	&& $hashref->{redirects_left} > 0 # and we still want to follow
	538	&& $response->code != 304 # not a 'not modified' reponse
	539	)
	540	{
	541
	542	$hashref->{redirects_left}--;
	543
	544	my $loc = $response->header('Location');
	545	my $uri = $response->request->uri;
	546
	547	warn "Problem: " . Dumper( { loc => $loc, uri => $uri } )
	548	unless $uri && ref $uri && $loc && !ref $loc;
	549
	550	my $url = _make_url_absolute( url => $loc, ref => $uri );
	551
	552	my $request = HTTP::Request->new( 'GET', $url );
	553
	554	$self->_send_request( [ $request, $id ] );
	555	$hashref->{previous} = $response;
	556	}
	557	else {
	558	$self->_add_to_return_queue( [ $response, $id ] );
	559	delete $$self{in_progress}{$id};
	560	}
	561
	562	delete $hashref->{tmp};
	563	}
	564	}
	565
	566	return 1;
	567	}
	568
	569	sub _add_to_return_queue {
	570	my $self = shift;
	571	my $req_and_id = shift;
	572	push @{ $$self{to_return} }, $req_and_id;
	573	return 1;
	574	}
	575
	576	# Add all the items waiting to be sent to 'to_send' up to the 'slots'
	577	# limit.
	578
	579	sub _process_to_send {
	580	my $self = shift;
	581
	582	while ( scalar @{ $$self{to_send} }
	583	&& $self->slots > scalar keys %{ $$self{in_progress} } )
	584	{
	585	$self->_send_request( shift @{ $$self{to_send} } );
	586	}
	587
	588	return 1;
	589	}
	590
	591	sub _send_request {
	592	my $self = shift;
	593	my $r_and_id = shift;
	594	my ( $request, $id ) = @$r_and_id;
	595
	596	my $uri = URI->new( $request->uri );
	597
	598	my %args = ();
	599
	600	# We need to use a different request_uri for proxied requests. Decide to use
	601	# this if a proxy port or host is set.
	602	#
	603	# http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.1.2
	604	$args{Host} = $uri->host;
	605	$args{PeerAddr} = $self->_get_opt( 'proxy_host', $id );
	606	$args{PeerPort} = $self->_get_opt( 'proxy_port', $id );
	607
	608	my $request_is_to_proxy =
	609	( $args{PeerAddr} \|\| $args{PeerPort} ) # if either are set...
	610	? 1 # ...then we are a proxy request
	611	: 0; # ...otherwise not
	612
	613	# If we did not get a setting from the proxy then use the uri values.
	614	$args{PeerAddr} \|\|= $uri->host;
	615	$args{PeerPort} \|\|= $uri->port;
	616
	617	my $s = eval { Net::HTTP::NB->new(%args) };
	618
	619	# We could not create a request - fake up a 503 response with
	620	# error as content.
	621	if ( !$s ) {
	622
	623	$self->_add_error_response_to_return(
	624	id => $id,
	625	code => 503,
	626	request => $request,
	627	previous => $$self{in_progress}{$id}{previous},
	628	content => $@,
	629	);
	630
	631	return 1;
	632	}
	633
	634	my %headers = %{ $request->{_headers} };
	635
	636	# Decide what to use as the request_uri
	637	my $request_uri = $request_is_to_proxy # is this a proxy request....
	638	? $uri->as_string # ... if so use full url
	639	: _strip_host_from_uri($uri); # ...else strip off scheme, host and port
	640
	641	croak "Could not write request to $uri '$!'"
	642	unless $s->write_request( $request->method, $request_uri, %headers,
	643	$request->content );
	644
	645	$self->_io_select->add($s);
	646
	647	$$self{fileno_to_id}{ $s->fileno } = $id;
	648	$$self{in_progress}{$id}{request} = $request;
	649	$$self{in_progress}{$id}{timeout_at} =
	650	time + $self->_get_opt( 'timeout', $id );
	651	$$self{in_progress}{$id}{finish_by} =
	652	time + $self->_get_opt( 'max_request_time', $id );
	653
	654	$$self{in_progress}{$id}{redirects_left} =
	655	$self->_get_opt( 'max_redirects', $id )
	656	unless exists $$self{in_progress}{$id}{redirects_left};
	657
	658	return 1;
	659	}
	660
	661	sub _strip_host_from_uri {
	662	my $uri = shift;
	663
	664	my $scheme_and_auth = quotemeta( $uri->scheme . '://' . $uri->authority );
	665	my $url = $uri->as_string;
	666
	667	$url =~ s/^$scheme_and_auth//;
	668	$url = "/$url" unless $url =~ m{^/};
	669
	670	return $url;
	671	}
	672
	673	sub _io_select {
	674	my $self = shift;
	675	return $$self{io_select} \|\|= IO::Select->new();
	676	}
	677
	678	sub _make_url_absolute {
	679	my %args = @_;
	680
	681	my $in = $args{url};
	682	my $ref = $args{ref};
	683
	684	return $in if $in =~ m{ \A http:// }xms;
	685
	686	my $ret = $ref->scheme . '://' . $ref->authority;
	687	return $ret . $in if $in =~ m{ \A / }xms;
	688
	689	$ret .= $ref->path;
	690	return $ret . $in if $in =~ m{ \A [\?\#\;] }xms;
	691
	692	$ret =~ s{ [^/]+ \z }{}xms;
	693	return $ret . $in;
	694	}
	695
	696	sub _add_error_response_to_return {
	697	my $self = shift;
	698	my %args = @_;
	699
	700	use HTTP::Status;
	701
	702	my $response =
	703	HTTP::Response->new( $args{code}, status_message( $args{code} ),
	704	undef, $args{content} );
	705
	706	$response->request( $args{request} );
	707	$response->previous( $args{previous} ) if $args{previous};
	708
	709	$self->_add_to_return_queue( [ $response, $args{id} ] );
	710	delete $$self{in_progress}{ $args{id} };
	711
	712	return $response;
	713
	714	}
	715
	716	=head1 SEE ALSO
	717
	718	L<HTTP::Async::Polite> - a polite form of this module. Slows the scraping down
	719	by domain so that the remote server is not overloaded.
	720
	721	=head1 GOTCHAS
	722
	723	The responses may not come back in the same order as the requests were made.
	724
	725	=head1 THANKS
	726
	727	Egor Egorov contributed patches for proxies, catching connections that die
	728	before headers sent and more.
	729
	730	Tomohiro Ikebe from livedoor.jp submitted patches (and a test) to properly
	731	handle 304 responses.
	732
	733	=head1 AUTHOR
	734
	735	Edmund von der Burg C<< <evdb@ecclestoad.co.uk> >>.
	736
	737	L<http://www.ecclestoad.co.uk/>
	738
	739	=head1 LICENCE AND COPYRIGHT
	740
	741	Copyright (c) 2006, Edmund von der Burg C<< <evdb@ecclestoad.co.uk> >>.
	742	All rights reserved.
	743
	744	This module is free software; you can redistribute it and/or modify it under
	745	the same terms as Perl itself.
	746
	747	=head1 DISCLAIMER OF WARRANTY
	748
	749	BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE
	750	SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE
	751	STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE
	752	SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED,
	753	INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
	754	FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
	755	PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE,
	756	YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
	757
	758	IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY
	759	COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE
	760	SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES,
	761	INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING
	762	OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO
	763	LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR
	764	THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER
	765	SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
	766	POSSIBILITY OF SUCH DAMAGES.
	767
	768	=cut
	769
	770	1;
	771

+142

-0

t/TestServer.pm less more

	0	use strict;
	1	use warnings;
	2
	3	# Provide a simple server that can be used to test the various bits.
	4	package TestServer;
	5	use base qw/Test::HTTP::Server::Simple HTTP::Server::Simple::CGI/;
	6
	7	use Time::HiRes qw(sleep time);
	8	use Data::Dumper;
	9	use LWP::UserAgent;
	10
	11	sub handle_request {
	12	my ( $self, $cgi ) = @_;
	13	my $params = $cgi->Vars;
	14
	15	# If we are on port 8081 then we are a proxy - we should forward the
	16	# requests.
	17	return act_as_proxy(@_) if $self->port == 8081;
	18
	19	# We should act as a final destination server and so expect an absolute URL.
	20	my $request_uri = $ENV{REQUEST_URI};
	21	if ( $request_uri !~ m!^/! ) {
	22	warn "ERROR - not absolute request_uri '$request_uri'";
	23	return;
	24	}
	25
	26	# Flush the output so that it goes straight away. Needed for the timeout
	27	# trickle tests.
	28	$self->stdout_handle->autoflush(1);
	29
	30	# warn "START REQUEST - " . time;
	31
	32	# Do the right thing depending on what is asked of us.
	33	if ( exists $params->{redirect} ) {
	34	my $num = $params->{redirect} \|\| 0;
	35	$num--;
	36
	37	if ( $num > 0 ) {
	38	print $cgi->redirect( -uri => "?redirect=$num", -nph => 1, );
	39	print "You are being redirected...";
	40	}
	41	else {
	42	print $cgi->header( -nph => 1 );
	43	print "No longer redirecting";
	44	}
	45	}
	46
	47	elsif ( exists $params->{delay} ) {
	48	sleep( $params->{delay} );
	49	print $cgi->header( -nph => 1 );
	50	print "Delayed for '$params->{delay}'.\n";
	51
	52	}
	53
	54	elsif ( exists $params->{trickle} ) {
	55
	56	my $trickle_for = $params->{trickle};
	57	my $finish_at = time + $trickle_for;
	58
	59	print $cgi->header( -nph => 1 );
	60
	61	while ( time <= $finish_at ) {
	62	print time . " trickle $$\n";
	63	sleep 0.1;
	64	}
	65
	66	print "Trickled for '$trickle_for'.\n";
	67	}
	68
	69	elsif ( exists $params->{bad_header} ) {
	70	my $headers = $cgi->header( -nph => 1, );
	71
	72	# trim trailing whitspace to single newline.
	73	$headers =~ s{ \s* \z }{\n}xms;
	74
	75	# Add a bad header:
	76	$headers .= "Bad header: BANG!\n";
	77
	78	print $headers . "\n\n";
	79	print "Produced some bad headers.";
	80	}
	81
	82	elsif ( my $when = $params->{break_connection} ) {
	83
	84	for (1) {
	85	last if $when eq 'before_headers';
	86	print $cgi->header( -nph => 1 );
	87
	88	last if $when eq 'before_content';
	89	print "content\n";
	90	}
	91	}
	92
	93	elsif ( my $id = $params->{set_time} ) {
	94	my $now = time;
	95	print $cgi->header( -nph => 1 );
	96	print "$id\n$now\n";
	97	}
	98
	99	elsif ( exists $params->{not_modified} ) {
	100	my $last_modified = HTTP::Date::time2str( time - 60 * 60 * 24 );
	101	print $cgi->header(
	102	-status => '304',
	103	-nph => 1,
	104	'Last-Modified' => $last_modified,
	105	);
	106	print "content\n";
	107	}
	108
	109	else {
	110	warn "DON'T KNOW WHAT TO DO: " . Dumper $params;
	111	}
	112
	113	# warn "STOP REQUEST - " . time;
	114
	115	}
	116
	117	sub act_as_proxy {
	118	my ( $self, $cgi ) = @_;
	119
	120	my $request_uri = $ENV{REQUEST_URI};
	121
	122	# According to the RFC the request_uri must be fully qualified if the
	123	# request is to a proxy and absolute if it is to a destination server. CHeck
	124	# that this is the case.
	125	#
	126	# http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.1.2
	127	if ( $request_uri !~ m!^http://! ) {
	128	warn "ERROR - not fully qualified request_uri '$request_uri'";
	129	return;
	130	}
	131
	132	my $response = LWP::UserAgent->new( max_redirect => 0 )->get($request_uri);
	133
	134	# Add a header so that we know that this was proxied.
	135	$response->header( WasProxied => 'yes' );
	136
	137	print $response->as_string;
	138	return 1;
	139	}
	140
	141	1;

+25

-0

t/bad-connections.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 5;
	5	use HTTP::Request;
	6
	7	require 't/TestServer.pm';
	8	my $s = TestServer->new;
	9	my $url_root = $s->started_ok("starting a test server");
	10
	11	use HTTP::Async;
	12	my $q = HTTP::Async->new;
	13
	14	my %tests = (
	15	"$url_root/foo/bar?break_connection=before_headers" => 504,
	16	"$url_root/foo/bar?break_connection=before_content" => 200,
	17	);
	18
	19	while ( my ( $url, $code ) = each %tests ) {
	20	my $req = HTTP::Request->new( 'GET', $url );
	21	ok $q->add($req), "Added request to the queue - $url";
	22	my $res = $q->wait_for_next_response;
	23	is $res->code, $code, "Got a '$code' response";
	24	}

+26

-0

t/bad-headers.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 3;
	5	use HTTP::Request;
	6
	7	require 't/TestServer.pm';
	8	my $s = TestServer->new;
	9	my $url_root = $s->started_ok("starting a test server");
	10
	11	use HTTP::Async;
	12	my $q = HTTP::Async->new;
	13
	14	# Check that a couple of redirects work.
	15	my $url = "$url_root/foo/bar?bad_header=1";
	16
	17	# warn $url;
	18	# getc;
	19
	20	my $req = HTTP::Request->new( 'GET', $url );
	21	ok $q->add($req), "Added request to the queue";
	22	$q->poke while !$q->to_return_count;
	23
	24	my $res = $q->next_response;
	25	is $res->code, 200, "Got a response";

+28

-0

t/bad-hosts.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 9;
	5
	6	use HTTP::Request;
	7
	8	use HTTP::Async;
	9	my $q = HTTP::Async->new;
	10
	11	# Try to add some requests for bad hosts. HTTP::Async should not fail
	12	# but should return HTTP::Responses with the correct status code etc.
	13
	14	my @bad_requests =
	15	map { HTTP::Request->new( GET => $_ ) }
	16	( 'http://i.dont.exist/foo/bar', 'ftp://wrong.protocol.com/foo/bar' );
	17
	18	ok $q->add(@bad_requests), "Added bad requests";
	19
	20	while ( $q->not_empty ) {
	21	my $res = $q->next_response \|\| next;
	22
	23	isa_ok $res, 'HTTP::Response', "Got a proper response";
	24	ok !$res->is_success, "Response was not a success";
	25	ok $res->is_error, "Response was an error";
	26	ok $res->request, "response has a request attached.";
	27	}

+24

-0

t/make-url-absolute.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 4;
	5
	6	use HTTP::Async;
	7	use URI;
	8
	9	my $full_url = URI->new('http://www.test.com:8080/foo/bar?baz=bundy');
	10
	11	my @tests = (
	12	'http://www.test.com:8080/foo/bar?baz=bundy', '/foo/bar?baz=bundy',
	13	'bar?baz=bundy', '?baz=bundy',
	14	);
	15
	16	foreach my $test (@tests) {
	17	my $url = HTTP::Async::_make_url_absolute(
	18	url => $test,
	19	ref => $full_url,
	20	);
	21
	22	is "$url", "$full_url", "$test -> $full_url";
	23	}

+29

-0

t/not_modified.t less more

	0	use strict;
	1	use warnings;
	2
	3	use Test::More tests => 4;
	4	use HTTP::Request;
	5	use HTTP::Async;
	6
	7	require 't/TestServer.pm';
	8
	9	my $s = TestServer->new;
	10	my $url_root = $s->started_ok("starting a test server");
	11
	12	my $q = HTTP::Async->new;
	13
	14	{
	15	my $url = "$url_root/?not_modified=1";
	16
	17	my $req = HTTP::Request->new( 'GET', $url );
	18	ok $q->add($req), "Added request to the queue";
	19	my $res = $q->wait_for_next_response;
	20
	21	# use Data::Dumper;
	22	# warn Dumper $res;
	23
	24	is $res->code, 304, "304 Not modified";
	25	ok !$res->previous, "does not have a previous reponse";
	26	}
	27
	28	1;

+14

-0

t/pod-coverage.t less more

	0	use strict;
	1	use warnings;
	2
	3	use Test::More;
	4
	5	eval "use Test::Pod::Coverage 1.00;";
	6	plan skip_all => "Test::Pod::Coverage > 1.00 required" if $@;
	7
	8	if ( $] >= 5.009 ) {
	9	eval "use Pod::Coverage 0.19;";
	10	plan skip_all => "Pod::Coverage >= 0.19 required for perls >= 5.9" if $@;
	11	}
	12
	13	all_pod_coverage_ok();

-0

t/pod.t less more

	0	use strict;
	1	use warnings;
	2
	3	use Test::More;
	4	eval "use Test::Pod 1.00";
	5	plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
	6	all_pod_files_ok();

+87

-0

t/polite.t less more

	0	use strict;
	1	use warnings;
	2
	3	use Test::More tests => 14;
	4	use HTTP::Request;
	5	use Data::Dumper;
	6
	7	use HTTP::Async::Polite;
	8	my $q = HTTP::Async::Polite->new;
	9
	10	# Check that we can set and get the interval.
	11	is $q->send_interval, 5, "default interval is 5 seconds";
	12	ok $q->send_interval(3), "change interval to 3 seconds";
	13	is $q->send_interval, 3, "new interval is 3 seconds";
	14
	15	require 't/TestServer.pm';
	16
	17	my @servers = map { TestServer->new($_) } 80800 .. 80801;
	18	my @url_roots = ();
	19
	20	foreach my $s (@servers) {
	21	push @url_roots, $s->started_ok("starting a test server");
	22	}
	23
	24	# Fire off three requests to two different servers. Check that the correct
	25	# interval is observed between each request and that the two different servers
	26	# were scaped in parallel. Also add another request so that the lists are not
	27	# balanced.
	28	my @urls =
	29	map {
	30	my $url_root = $_;
	31	my ($port) = $url_root =~ m/\d+$/g;
	32	my $number = $_ eq $url_roots[0] ? 3 : 4;
	33	my @ret = map { "$url_root/?set_time=$port-$_" } 1 .. $number;
	34	@ret;
	35	} @url_roots;
	36
	37	my @requests = map { HTTP::Request->new( GET => $_ ) } @urls;
	38	ok $q->add(@requests), "Add the requests";
	39
	40	is $q->to_send_count, 5, "Got correct to_send count";
	41	is $q->total_count, 7, "Got correct total count";
	42
	43	# Get all the responses.
	44	my @responses = ();
	45	while ( my $res = $q->wait_for_next_response ) {
	46	push @responses, $res;
	47	}
	48
	49	is scalar(@responses), 7, "got six responses back";
	50
	51	# Extract the url and the timestamp from the responses;
	52	my %data = ();
	53	foreach my $res (@responses) {
	54	my ( $id, $timestamp ) = split /\n/, $res->content, 2;
	55	my ( $port, $number ) = split /-/, $id, 2;
	56
	57	# Skip if the number is greater than 3 - extra req to test unbalanced list
	58	next if $number > 3;
	59
	60	s/\s+//g for $port, $number, $timestamp;
	61	$data{$port}{$number} = $timestamp;
	62	}
	63
	64	# diag Dumper \%data;
	65
	66	# Check that the requests did not come too close together.
	67	my @first_times = ();
	68	foreach my $port ( sort keys %data ) {
	69
	70	my @times = sort { $a <=> $b } values %{ $data{$port} };
	71
	72	my $last_time = shift @times;
	73	push @first_times, $last_time;
	74
	75	foreach my $time (@times) {
	76
	77	cmp_ok $time - $last_time, ">", 3,
	78	"at least three seconds between requests to same domain";
	79
	80	$last_time = $time;
	81	}
	82	}
	83
	84	# check that the first two requests were near each other.
	85	cmp_ok abs( $first_times[0] - $first_times[1] ), "<", 1,
	86	"at most 1 second between first two requests";

+85

-0

t/poll-interval.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 24;
	5	use HTTP::Request;
	6	use Time::HiRes 'time';
	7
	8	BEGIN {
	9	require 't/test_utils.pl';
	10	}
	11
	12	require 't/TestServer.pm';
	13	my $s = TestServer->new;
	14	my $url_root = $s->started_ok("starting a test server");
	15
	16	use HTTP::Async;
	17	my $q = HTTP::Async->new;
	18
	19	# Send off a long request - check that next_response returns at once
	20	# but that wait_for_next_response returns only when the response has arrived.
	21
	22	# Check that the poll interval is at a sensible default.
	23	is $q->poll_interval, 0.05, "\$q->poll_interval == 0.05";
	24
	25	# Check that the poll interval is changeable.
	26	is $q->poll_interval(0.1), 0.1, "set poll_interval to 0.1";
	27	is $q->poll_interval, 0.1, "\$q->poll_interval == 0.1";
	28
	29	{
	30
	31	# Get the time since the request was made.
	32	reset_timer();
	33
	34	my $url = "$url_root?delay=3";
	35	my $req = HTTP::Request->new( 'GET', $url );
	36	ok $q->add($req), "Added request to the queue - $url";
	37
	38	# Does next_response return immediately
	39	ok !$q->next_response, "next_response returns at once";
	40	delay_lt_ok 0.4, "Returned quickly (less than 0.4 secs)";
	41
	42	ok !$q->wait_for_next_response(0),
	43	"wait_for_next_response(0) returns at once";
	44	delay_lt_ok 0.4, "Returned quickly (less than 0.4 secs)";
	45
	46	ok !$q->wait_for_next_response(1),
	47	"wait_for_next_response(1) returns after 1 sec without a response";
	48
	49	delay_ge_ok 1, "Returned after 1 sec delay";
	50	delay_lt_ok 1.4, "Returned before 1.4 sec delay";
	51
	52	my $response = $q->wait_for_next_response();
	53	ok $response, "wait_for_next_response got the response";
	54	delay_gt_ok 3, "Returned after 3 sec delay";
	55
	56	is $response->code, 200, "good response (200)";
	57	ok $response->is_success, "is a success";
	58	}
	59
	60	{
	61	reset_timer();
	62
	63	my $url = "$url_root?delay=1";
	64	my $req = HTTP::Request->new( 'GET', $url );
	65	ok $q->add($req), "Added request to the queue - $url";
	66
	67	my $response = $q->wait_for_next_response;
	68
	69	ok $response, "wait_for_next_response got the response";
	70
	71	delay_gt_ok 1, "Returned after 1 sec delay";
	72	delay_lt_ok 2, "Returned before 2 sec delay";
	73
	74	is $response->code, 200, "good response (200)";
	75	ok $response->is_success, "is a success";
	76	}
	77
	78	{ # Check that wait_for_next_response does not hang if there is nothing
	79	# to wait for.
	80	reset_timer();
	81	ok !$q->wait_for_next_response, "Did not get a response";
	82	delay_lt_ok 1, "Returned in less than 1 sec";
	83	}
	84

+50

-0

t/proxy.t less more

	0
	1	use strict;
	2	use warnings;
	3	use URI::Escape;
	4
	5	use Test::More tests => 16;
	6	use HTTP::Request;
	7
	8	require 't/TestServer.pm';
	9	my $s1 = TestServer->new(8080);
	10	my $s1_url_root = $s1->started_ok("starting a test server");
	11
	12	my $s2 = TestServer->new(8081);
	13	my $s2_url_root = $s2->started_ok("starting a test server");
	14
	15	ok( $_, "got $_" ) for $s1_url_root, $s2_url_root;
	16
	17	my %tests = (
	18	"$s1_url_root/foo/bar?redirect=2" => 200,
	19	"$s1_url_root/foo/bar?delay=1" => 200,
	20	);
	21
	22	use HTTP::Async;
	23	my $q = HTTP::Async->new;
	24
	25	foreach my $via_proxy ( 0, 1 ) {
	26
	27	while ( my ( $url, $code ) = each %tests ) {
	28
	29	my $req = HTTP::Request->new( 'GET', $url );
	30
	31	my %opts = ( proxy_host => '127.0.0.1', proxy_port => 8081, );
	32
	33	my $id =
	34	$via_proxy
	35	? $q->add_with_opts( $req, \%opts )
	36	: $q->add($req);
	37
	38	ok $id, "Added request to the queue - $url";
	39
	40	my $res = $q->wait_for_next_response;
	41	is( $res->code, $code, "Got a '$code' response" )
	42	\|\| warn $res->as_string;
	43
	44	# check that the proxy header was found if this was a proxy request.
	45	my $proxy_header = $res->header('WasProxied') \|\| '';
	46	my $expected = $via_proxy ? 'yes' : '';
	47	is $proxy_header, $expected, "check for proxy header '$expected'";
	48	}
	49	}

+51

-0

t/real-servers.t less more

	0	use strict;
	1	use warnings;
	2
	3	use Test::More;
	4
	5	plan skip_all => "enable these tests by setting REAL_SERVERS"
	6	unless $ENV{REAL_SERVERS};
	7
	8	use HTTP::Request;
	9	use Time::HiRes 'usleep';
	10
	11	# Create requests for a few well known sites.
	12	my @requests =
	13	map { HTTP::Request->new( GET => "http://www.$_" ) }
	14	sort qw( google.com yahoo.com ecclestoad.co.uk );
	15
	16	my $tests_per_request = 4;
	17	plan tests => 3 + $tests_per_request * scalar @requests;
	18
	19	use_ok 'HTTP::Async';
	20
	21	my $q = HTTP::Async->new;
	22	isa_ok $q, 'HTTP::Async';
	23
	24	# Put all of these onto the queue.
	25	ok( $q->add($_), "Added request for " . $_->uri ) for @requests;
	26
	27	# Process the queue until they all complete.
	28	my @responses = ();
	29
	30	while ( $q->not_empty ) {
	31
	32	my $res = $q->next_response;
	33	if ($res) {
	34	pass "Got the response from " . $res->request->uri;
	35	push @responses, $res;
	36	}
	37	else {
	38	usleep( 1_000_000 * 0.1 ); # 0.1 seconds
	39	next;
	40	}
	41
	42	ok $res->is_success, "is success";
	43	}
	44
	45	# Check that we got the number needed and that all the responses are
	46	# HTTP::Response objects.
	47	is scalar @responses, scalar @requests, "Got the expected number of responses";
	48	isa_ok( $_, 'HTTP::Response', "Got a HTTP::Response object" ) for @responses;
	49
	50	# print $_->content for @responses;

+81

-0

t/redirects.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 21;
	5	use HTTP::Request;
	6
	7	require 't/TestServer.pm';
	8	my $s = TestServer->new;
	9	my $url_root = $s->started_ok("starting a test server");
	10
	11	use HTTP::Async;
	12	my $q = HTTP::Async->new;
	13
	14	# Check that the max_redirects is at a sensible level.
	15	is $q->max_redirects, 7, "max_redirects == 7";
	16
	17	# Send a request to somewhere that will redirect a certain number of
	18	# times:
	19	#
	20	# ?redirect=$num - if $num is > 0 then it redirects to $num - 1;
	21
	22	{ # Check that a couple of redirects work.
	23	my $url = "$url_root/foo/bar?redirect=3";
	24
	25	# warn $url;
	26	# getc;
	27
	28	my $req = HTTP::Request->new( 'GET', $url );
	29	ok $q->add($req), "Added request to the queue";
	30	$q->poke while !$q->to_return_count;
	31
	32	my $res = $q->next_response;
	33	is $res->code, 200, "No longer a redirect";
	34	ok $res->previous, "Has a previous reponse";
	35	is $res->previous->code, 302, "previous request was a redirect";
	36	}
	37
	38	{ # check that 20 redirects stop after the expected number.
	39	my $url = "$url_root?redirect=20";
	40	my $req = HTTP::Request->new( 'GET', $url );
	41	ok $q->add($req), "Added request to the queue";
	42	$q->poke while !$q->to_return_count;
	43
	44	my $res = $q->next_response;
	45	is $res->code, 302, "Still a redirect";
	46	ok $res->previous, "Has a previous reponse";
	47	is $res->previous->code, 302, "previous request was a redirect";
	48	is $res->request->uri->as_string, 'http://localhost:8080?redirect=13',
	49	"last request url correct";
	50	}
	51
	52	{ # Set the max_redirect higher and try again.
	53
	54	ok $q->max_redirects(30), "Set the max_redirects higher.";
	55
	56	my $url = "$url_root?redirect=20";
	57	my $req = HTTP::Request->new( 'GET', $url );
	58	ok $q->add($req), "Added request to the queue";
	59	$q->poke while !$q->to_return_count;
	60
	61	my $res = $q->next_response;
	62	is $res->code, 200, "No longer a redirect";
	63	ok $res->previous, "Has a previous reponse";
	64	is $res->previous->code, 302, "previous request was a redirect";
	65	}
	66
	67	{ # Set the max_redirect to zero and check that none happen.
	68
	69	is $q->max_redirects(0), 0, "Set the max_redirects to zero.";
	70	is $q->max_redirects, 0, "max_redirects is set to zero.";
	71
	72	my $url = "$url_root?redirect=20";
	73	my $req = HTTP::Request->new( 'GET', $url );
	74	ok $q->add($req), "Added request to the queue";
	75	$q->poke while !$q->to_return_count;
	76
	77	my $res = $q->next_response;
	78	is $res->code, 302, "No longer a redirect";
	79	ok !$res->previous, "Have no previous reponse";
	80	}

+21

-0

t/setup.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 16;
	5
	6	use HTTP::Async;
	7	use HTTP::Async::Polite;
	8
	9	foreach my $class ( 'HTTP::Async', 'HTTP::Async::Polite' ) {
	10	foreach my $number ( 0, 3 ) {
	11
	12	my $q1 = $class->new;
	13	is $q1->max_redirects($number), $number, "set to $number";
	14	is $q1->max_redirects, $number, "got $number";
	15
	16	my $q2 = $class->new( max_redirects => $number );
	17	ok $q2, "created object";
	18	is $q2->max_redirects, $number, "got $number";
	19	}
	20	}

+28

-0

t/strip_host_from_uri.t less more

	0	use strict;
	1	use warnings;
	2
	3	use Test::More;
	4	use HTTP::Async;
	5	use URI;
	6
	7	my %tests = (
	8	'http://www.w3.org:8080/Protocols/rfc2616/rfc2616-sec5.html?foo=bar#sec5.1.2'
	9	=> '/Protocols/rfc2616/rfc2616-sec5.html?foo=bar#sec5.1.2',
	10
	11	'http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html?foo=bar#sec5.1.2' =>
	12	'/Protocols/rfc2616/rfc2616-sec5.html?foo=bar#sec5.1.2',
	13
	14	'https://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html?foo=bar#sec5.1.2' =>
	15	'/Protocols/rfc2616/rfc2616-sec5.html?foo=bar#sec5.1.2',
	16
	17	'https://www.w3.org:80/Protocols' => '/Protocols',
	18
	19	'http://localhost:8080?delay=3' => '/?delay=3'
	20	);
	21
	22	plan tests => scalar keys %tests;
	23
	24	while ( my ( $in, $expected ) = each %tests ) {
	25	my $out = HTTP::Async::_strip_host_from_uri( URI->new($in) );
	26	is $out, $expected, "correctly stripped $in to $out";
	27	}

+20

-0

t/template.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More skip_all => 'just a template to base other tests on';
	5
	6	use Test::More tests => 5;
	7
	8	use HTTP::Async;
	9	my $q = HTTP::Async->new;
	10
	11	require 't/TestServer.pm';
	12
	13	# my $s = TestServer->new;
	14	# my $url_root = $s->started_ok("starting a test server");
	15
	16	my @servers = map { TestServer->new($_) } 80800 .. 80804;
	17	foreach my $s (@servers) {
	18	my $url_root = $s->started_ok("starting a test server");
	19	}

+26

-0

t/test_utils.pl less more

	0	use strict;
	1	use warnings;
	2
	3	use Time::HiRes qw(time);
	4
	5	{
	6	my $start_time = undef;
	7
	8	sub reset_timer { return $start_time = time; }
	9
	10	sub delay_lt_ok ($$) { return delay_ok( '<', @_ ); }
	11	sub delay_le_ok ($$) { return delay_ok( '<=', @_ ); }
	12	sub delay_ge_ok ($$) { return delay_ok( '>=', @_ ); }
	13	sub delay_gt_ok ($$) { return delay_ok( '>', @_ ); }
	14
	15	sub delay_ok ($$$) {
	16	my ( $cmp, $delay, $message ) = @_;
	17
	18	my $timer = time - $start_time;
	19
	20	my $display_test = sprintf '%.2f %s %.2f', $timer, $cmp, $delay;
	21	return cmp_ok $timer, $cmp, $delay, "$message ($display_test)";
	22	}
	23	}
	24
	25	1;

+77

-0

t/timeout.t less more

	0
	1	use strict;
	2	use warnings;
	3
	4	use Test::More tests => 20;
	5	use HTTP::Request;
	6
	7	require 't/TestServer.pm';
	8	my $s = TestServer->new;
	9	my $url_root = $s->started_ok("starting a test server");
	10
	11	use HTTP::Async;
	12	my $q = HTTP::Async->new;
	13
	14	# Check that the timeout is at a sensible default.
	15	is $q->timeout, 180, "\$q->timeout == 180";
	16
	17	{ # Send a request that should return quickly
	18	my $url = "$url_root?delay=0";
	19	my $req = HTTP::Request->new( 'GET', $url );
	20	ok $q->add($req), "Added request to the queue - $url";
	21	$q->poke while !$q->to_return_count;
	22
	23	my $res = $q->next_response;
	24	is $res->code, 200, "Not timed out (200)";
	25	}
	26
	27	is $q->timeout(1), 1, "Set the timeout really low";
	28
	29	{ # Send a request that should timeout
	30	my $url = "$url_root?delay=3";
	31	my $req = HTTP::Request->new( 'GET', $url );
	32	ok $q->add($req), "Added delayed request to the queue - $url";
	33	$q->poke while !$q->to_return_count;
	34
	35	my $res = $q->next_response;
	36	is $res->code, 504, "timed out (504)";
	37	ok $res->is_error, "is an error";
	38	}
	39
	40	{ # Send a request that should not timeout as it is trickling back data.
	41	my $url = "$url_root?trickle=3";
	42	my $req = HTTP::Request->new( 'GET', $url );
	43	ok $q->add($req), "Added trickle request to the queue - $url";
	44	$q->poke while !$q->to_return_count;
	45
	46	my $res = $q->next_response;
	47	is $res->code, 200, "response ok (200)";
	48	ok !$res->is_error, "is not an error";
	49	}
	50
	51	is $q->timeout(1), 1, "Set the timeout really low";
	52	is $q->max_request_time(1), 1, "Set the max_request_time really low";
	53
	54	{ # Send a request that should timeout despite trickling back data.
	55	my $url = "$url_root?trickle=3";
	56	my $req = HTTP::Request->new( 'GET', $url );
	57	ok $q->add($req), "Added trickle request to the queue - $url";
	58	$q->poke while !$q->to_return_count;
	59
	60	my $res = $q->next_response;
	61	is $res->code, 504, "timed out (504)";
	62	ok $res->is_error, "is an error";
	63	}
	64
	65	is $q->timeout(10), 10, "Lengthen the timeout";
	66	is $q->max_request_time(300), 300, "Set the max_request_time really low";
	67
	68	{ # Send same request that should now be ok
	69	my $url = "$url_root?delay=3";
	70	my $req = HTTP::Request->new( 'GET', $url );
	71	ok $q->add($req), "Added delayed request to the queue - $url";
	72	$q->poke while !$q->to_return_count;
	73
	74	my $res = $q->next_response;
	75	is $res->code, 200, "Not timed out (200)";
	76	}