Dogcows Code - chaz/p5-HTTP-AnyUA/blob - 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;