initial commit
[chaz/p5-HTTP-AnyUA] / t / lib / Util.pm
1 package Util;
2 # ABSTRACT: Utility subroutines for testing HTTP::AnyUA
3
4 =head1 SYNOPSIS
5
6 use Util qw(:server :test :ua);
7
8 =cut
9
10 use warnings;
11 use strict;
12
13 use Exporter qw(import);
14 use Future;
15 use Test2::API qw(context release);
16 use Test::More;
17
18 our @EXPORT_OK = qw(
19 recv_env
20 send_env
21 start_server
22 use_server
23
24 is_response_content
25 is_response_header
26 is_response_reason
27 is_response_status
28 is_response_success
29 is_response_url
30 response_protocol_ok
31
32 test_all_user_agents
33 test_user_agent
34 user_agents
35 );
36 our %EXPORT_TAGS = (
37 server => [qw(
38 recv_env
39 send_env
40 start_server
41 use_server
42 )],
43 test => [qw(
44 is_response_content
45 is_response_header
46 is_response_reason
47 is_response_status
48 is_response_success
49 is_response_url
50 response_protocol_ok
51 )],
52 ua => [qw(
53 test_all_user_agents
54 test_user_agent
55 user_agents
56 )],
57 );
58
59 our @USER_AGENTS = qw(
60 AnyEvent::HTTP
61 Furl
62 HTTP::Tiny
63 LWP::UserAgent
64 Mojo::UserAgent
65 Net::Curl::Easy
66 );
67 our %USER_AGENT_TEST_WRAPPER;
68
69 sub _croak { require Carp; Carp::croak(@_) }
70 sub _carp { require Carp; Carp::carp(@_) }
71
72
73 =func use_server
74
75 use_server;
76
77 Try to use the test server package. If it fails, the test plan is set to C<skip_all>.
78
79 =cut
80
81 sub use_server {
82 eval 'use Server';
83 if (my $err = $@) {
84 diag $err;
85 plan skip_all => 'Could not compile test server runner.';
86 }
87 }
88
89 =func start_server
90
91 $server = start_server('app.psgi');
92
93 Start a test server.
94
95 =cut
96
97 sub start_server {
98 use_server;
99 my $server = eval { Server->new(@_) };
100 if (my $err = $@) {
101 diag $err;
102 plan skip_all => 'Could not start test server.';
103 }
104 return $server;
105 }
106
107 =func send_env
108
109 send_env(\%env);
110
111 Encode and send a L<PSGI> environment over C<STDOUT>, to be received by L</recv_env>.
112
113 =cut
114
115 sub send_env {
116 my $env = shift || {};
117 my $fh = shift || *STDOUT;
118
119 my %data = map { !/^psgi/ ? ($_ => $env->{$_}) : () } keys %$env;
120
121 # read in the request body
122 my $buffer;
123 my $body = '';
124 $env->{'psgix.input.buffered'} or die 'Expected buffered input';
125 while (1) {
126 my $bytes = $env->{'psgi.input'}->read($buffer, 32768);
127 defined $bytes or die 'Error while reading input stream';
128 last if !$bytes;
129 $body .= $buffer;
130 }
131 $data{content} = $body;
132
133 require JSON;
134 print $fh JSON::encode_json(\%data), "\n";
135 }
136
137 =func recv_env
138
139 my $env = recv_env($fh);
140
141 Receive and decode a L<PSGI> environment over a filehandle, sent by L</send_env>.
142
143 =cut
144
145 sub recv_env {
146 my $fh = shift;
147
148 my $data = <$fh>;
149
150 require JSON;
151 return JSON::decode_json($data);
152 }
153
154
155 =func is_response_content, is_response_reason, is_response_status, is_response_success, is_response_url, is_response_header
156
157 is_response_content($resp, $body, $test_name);
158 is_response_content($resp, $body);
159 # etc.
160
161 Test a response for various fields.
162
163 =cut
164
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(@_) }
171
172 =func response_protocol_ok
173
174 response_protocol_ok($resp);
175
176 Test that a response protocol is well-formed.
177
178 =cut
179
180 sub response_protocol_ok {
181 my ($resp) = @_;
182 my $ctx = context;
183 my $test;
184 if (ref($resp) ne 'HASH') {
185 $test = isa_ok($resp, 'HASH', 'response');
186 }
187 else {
188 my $proto = $resp->{protocol};
189 $test = ok(!$proto || $proto =~ m!^HTTP/!, 'response protocol matches or is missing');
190 }
191 release $ctx, $test;
192 }
193
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');
198 }
199 elsif (defined $val) {
200 $type ||= '';
201 if ($type eq 'bool') {
202 my $disp = $val ? 'true' : 'false';
203 return is(!!$resp->{$key}, !!$val, $name || "response $key matches \"$disp\"");
204 }
205 else {
206 my $disp = $val;
207 $disp =~ s/(.{40}).{4,}/$1.../;
208 return is($resp->{$key}, $val, $name || "response $key matches \"$disp\"");
209 }
210 }
211 else {
212 return ok(exists $resp->{$key}, $name || "response $key exists");
213 }
214 }
215
216 sub _test_response_header {
217 my ($resp, $key, $val, $name) = @_;
218 if (ref($resp) ne 'HASH') {
219 return isa_ok($resp, 'HASH', 'response');
220 }
221 elsif (ref($resp->{headers}) ne 'HASH') {
222 return isa_ok($resp, 'HASH', 'response headers');
223 }
224 elsif (defined $val) {
225 my $disp = $val;
226 $disp =~ s/(.{40}).{4,}/$1.../;
227 return is($resp->{headers}{$key}, $val, $name || "response header \"$key\" matches \"$disp\"");
228 }
229 else {
230 return ok(exists $resp->{headers}{$key}, $name || "response header $key exists");
231 }
232 }
233
234
235 =func user_agents
236
237 @user_agents = user_agents;
238
239 Get a list of user agents available for testing. Shortcut for C<@Util::USER_AGENTS>.
240
241 =cut
242
243 sub user_agents { @USER_AGENTS }
244
245 =func test_user_agent
246
247 test_user_agent($ua_type, \&test);
248
249 Run a subtest against one user agent.
250
251 =cut
252
253 sub test_user_agent {
254 my $name = shift;
255 my $code = shift;
256
257 my $wrapper = $USER_AGENT_TEST_WRAPPER{$name} || sub {
258 my $name = shift;
259 my $code = shift;
260
261 if (!eval "require $name") {
262 diag $@;
263 return;
264 }
265
266 my $ua = $name->new;
267 $code->($ua);
268
269 return 1;
270 };
271
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 };
275 alarm 5;
276 my $ret = $wrapper->($name, $code);
277 alarm 0;
278
279 plan skip_all => "Cannot create user agent ${name}" if !$ret;
280 }
281
282 =func test_all_user_agents
283
284 test_all_user_agents { ... };
285
286 Run the same subtest against all user agents returned by L</user_agents>.
287
288 =cut
289
290 sub test_all_user_agents(&) {
291 my $code = shift;
292
293 for my $name (user_agents) {
294 subtest $name => sub {
295 test_user_agent($name, $code);
296 };
297 }
298 }
299
300
301 $USER_AGENT_TEST_WRAPPER{'AnyEvent::HTTP'} = sub {
302 my $name = shift;
303 my $code = shift;
304
305 if (!eval "require $name") {
306 diag $@;
307 return;
308 }
309
310 require AnyEvent;
311 my $cv = AnyEvent->condvar;
312
313 my $ua = 'AnyEvent::HTTP';
314 my @futures = $code->($ua);
315 my $waiting = Future->wait_all(@futures)->on_ready(sub { $cv->send });
316
317 $cv->recv;
318
319 return 1;
320 };
321
322 $USER_AGENT_TEST_WRAPPER{'Mojo::UserAgent'} = sub {
323 my $name = shift;
324 my $code = shift;
325
326 if (!eval "require $name") {
327 diag $@;
328 return;
329 }
330
331 require Mojo::IOLoop;
332 my $loop = Mojo::IOLoop->singleton;
333
334 my $ua = Mojo::UserAgent->new;
335 my @futures = $code->($ua);
336 my $waiting = Future->wait_all(@futures)->on_ready(sub { $loop->reset });
337
338 $loop->start;
339
340 return 1;
341 };
342
343 1;
This page took 0.053082 seconds and 4 git commands to generate.