2 # ABSTRACT: Utility subroutines for testing HTTP::AnyUA
6 use Util qw(:server :test :ua);
13 use Exporter
qw(import);
15 use Test2
::API
qw(context release);
59 our @USER_AGENTS = qw(
67 our %USER_AGENT_TEST_WRAPPER;
69 sub _croak
{ require Carp
; Carp
::croak
(@_) }
70 sub _carp
{ require Carp
; Carp
::carp
(@_) }
77 Try to
use the test server
package. If it fails
, the test plan
is set to C
<skip_all
>.
85 plan skip_all
=> 'Could not compile test server runner.';
91 $server = start_server
('app.psgi');
99 my $server = eval { Server-
>new(@_) };
102 plan skip_all
=> 'Could not start test server.';
111 Encode
and send a L
<PSGI
> environment over C
<STDOUT
>, to be received by L
</recv_env
>.
116 my $env = shift || {};
117 my $fh = shift || *STDOUT
;
119 my %data = map { !/^psgi/ ? ($_ => $env->{$_}) : () } keys %$env;
121 # read in the request body
124 $env->{'psgix.input.buffered'} or die 'Expected buffered input';
126 my $bytes = $env->{'psgi.input'}->read($buffer, 32768);
127 defined $bytes or die 'Error while reading input stream';
131 $data{content
} = $body;
134 print $fh JSON
::encode_json
(\
%data), "\n";
139 my $env = recv_env
($fh);
141 Receive
and decode a L
<PSGI
> environment over a filehandle
, sent by L
</send_env
>.
151 return JSON
::decode_json
($data);
155 =func is_response_content
, is_response_reason
, is_response_status
, is_response_success
, is_response_url
, is_response_header
157 is_response_content
($resp, $body, $test_name);
158 is_response_content
($resp, $body);
161 Test a response
for various fields
.
165 sub is_response_content
{ my $ctx = context
; release
$ctx, _test_response_field
($_[0], 'content', @_[1,2]) }
166 sub is_response_reason
{ my $ctx = context
; release
$ctx, _test_response_field
($_[0], 'reason', @_[1,2]) }
167 sub is_response_status
{ my $ctx = context
; release
$ctx, _test_response_field
($_[0], 'status', @_[1,2]) }
168 sub is_response_success
{ my $ctx = context
; release
$ctx, _test_response_field
($_[0], 'success', @_[1,2], 'bool') }
169 sub is_response_url
{ my $ctx = context
; release
$ctx, _test_response_field
($_[0], 'url', @_[1,2]) }
170 sub is_response_header
{ my $ctx = context
; release
$ctx, _test_response_header
(@_) }
172 =func response_protocol_ok
174 response_protocol_ok
($resp);
176 Test that a response protocol
is well-formed
.
180 sub response_protocol_ok
{
184 if (ref($resp) ne 'HASH') {
185 $test = isa_ok
($resp, 'HASH', 'response');
188 my $proto = $resp->{protocol
};
189 $test = ok
(!$proto || $proto =~ m!^HTTP/!, 'response protocol matches or is missing');
194 sub _test_response_field
{
195 my ($resp, $key, $val, $name, $type) = @_;
196 if (ref($resp) ne 'HASH') {
197 return isa_ok
($resp, 'HASH', 'response');
199 elsif (defined $val) {
201 if ($type eq 'bool') {
202 my $disp = $val ? 'true' : 'false';
203 return is(!!$resp->{$key}, !!$val, $name || "response $key matches \"$disp\"");
207 $disp =~ s/(.{40}).{4,}/$1.../;
208 return is($resp->{$key}, $val, $name || "response $key matches \"$disp\"");
212 return ok
(exists $resp->{$key}, $name || "response $key exists");
216 sub _test_response_header
{
217 my ($resp, $key, $val, $name) = @_;
218 if (ref($resp) ne 'HASH') {
219 return isa_ok
($resp, 'HASH', 'response');
221 elsif (ref($resp->{headers
}) ne 'HASH') {
222 return isa_ok
($resp, 'HASH', 'response headers');
224 elsif (defined $val) {
226 $disp =~ s/(.{40}).{4,}/$1.../;
227 return is($resp->{headers
}{$key}, $val, $name || "response header \"$key\" matches \"$disp\"");
230 return ok
(exists $resp->{headers
}{$key}, $name || "response header $key exists");
237 @user_agents = user_agents
;
239 Get a list of user agents available
for testing
. Shortcut
for C
<@Util::USER_AGENTS
>.
243 sub user_agents
{ @USER_AGENTS }
245 =func test_user_agent
247 test_user_agent
($ua_type, \
&test
);
249 Run a subtest against one user agent
.
253 sub test_user_agent
{
257 my $wrapper = $USER_AGENT_TEST_WRAPPER{$name} || sub {
261 if (!eval "require $name") {
272 # this is quite gross, but we don't want any active event loops from preventing us from
273 # committing suicide if things are looking deadlocked
274 local $SIG{ALRM
} = sub { $@ = 'Deadlock or test is slow'; _carp
$@; exit 1 };
276 my $ret = $wrapper->($name, $code);
279 plan skip_all
=> "Cannot create user agent ${name}" if !$ret;
282 =func test_all_user_agents
284 test_all_user_agents
{ ... };
286 Run the same subtest against all user agents returned by L
</user_agents
>.
290 sub test_all_user_agents
(&) {
293 for my $name (user_agents
) {
294 subtest
$name => sub {
295 test_user_agent
($name, $code);
301 $USER_AGENT_TEST_WRAPPER{'AnyEvent::HTTP'} = sub {
305 if (!eval "require $name") {
311 my $cv = AnyEvent-
>condvar;
313 my $ua = 'AnyEvent::HTTP';
314 my @futures = $code->($ua);
315 my $waiting = Future-
>wait_all(@futures)->on_ready(sub { $cv->send });
322 $USER_AGENT_TEST_WRAPPER{'Mojo::UserAgent'} = sub {
326 if (!eval "require $name") {
331 require Mojo
::IOLoop
;
332 my $loop = Mojo
::IOLoop-
>singleton;
334 my $ua = Mojo
::UserAgent-
>new;
335 my @futures = $code->($ua);
336 my $waiting = Future-
>wait_all(@futures)->on_ready(sub { $loop->reset });