Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

220 lines (196 sloc) 6.403 kB
package Utils;
use strict;
use base 'Exporter';
use Test::More ();
use Socket qw/SOMAXCONN/;
use IO::Socket::INET;
use bytes; no bytes;
use blib;
use Carp qw(carp cluck confess croak);
use Encode ();
use AnyEvent ();
use AnyEvent::Handle ();
use Guard ();
use Scalar::Util qw/blessed weaken/;
use utf8;
$SIG{PIPE} = 'IGNORE';
my $CRLF = "\015\012";
sub import {
my ($pkg) = caller;
no strict 'refs';
*{$pkg.'::carp'} = \&Carp::carp;
*{$pkg.'::cluck'} = \&Carp::cluck;
*{$pkg.'::confess'} = \&Carp::confess;
*{$pkg.'::croak'} = \&Carp::croak;
*{$pkg.'::guard'} = \&Guard::guard;
*{$pkg.'::scope_guard'} = \&Guard::scope_guard;
*{$pkg.'::weaken'} = \&Scalar::Util::weaken;
*{$pkg.'::blessed'} = \&Scalar::Util::blessed;
*{$pkg.'::get_listen_socket'} = \&get_listen_socket;
*{$pkg.'::simple_client'} = \&simple_client;
return 1;
}
our $last_port;
sub get_listen_socket {
my $start = shift || 10000;
my $max = shift || $start + 10000;
for (my $i=$start; $i <= $max; $i++) {
my $socket = IO::Socket::INET->new(
LocalAddr => "localhost:$i",
ReuseAddr => 1,
Proto => 'tcp',
Listen => SOMAXCONN,
Blocking => 0,
);
if ($socket) {
$last_port = $i;
return $socket unless wantarray;
return ($socket,$i);
}
}
}
sub _cb_ewrapper {
my ($code, $name) = @_;
return(sub {}) unless $code;
return sub {
eval { $code->(@_) };
if ($@) {
Test::More::fail "$name callback failed";
Test::More::diag $@
}
};
}
sub simple_client ($$;@) {
my $done_cb = pop;
my $method = shift;
my $uri = shift;
my %opts = @_;
my $name = delete $opts{name} || 'simple_client';
my $port = delete $opts{port} || $last_port;
$done_cb = _cb_ewrapper($done_cb, "$name done");
my $conn_cb = _cb_ewrapper(delete $opts{on_connect}, "$name connect");
my $buf = '';
my %hdrs;
my $err_cb = sub {
my ($h,$fatal,$msg) = @_;
$hdrs{Status} = 599;
$hdrs{Reason} = $msg;
$h->destroy;
$done_cb->(undef,\%hdrs);
};
require AnyEvent::Handle;
my $h; $h = AnyEvent::Handle->new(
connect => ['127.0.0.1',$port],
on_connect => sub {
my $h = shift;
Test::More::pass("$name connected");
$conn_cb->($h);
return;
},
on_error => $err_cb,
timeout => $opts{timeout} || 30,
);
my $strong_h = $h;
weaken($h);
my $done = sub { $done_cb->($buf,\%hdrs); $h->destroy if $h; };
$h->on_read(sub {
Test::More::fail "$name got extra bytes!";
});
$h->push_read(line => "$CRLF$CRLF", sub {
{
my @hdrs = split($CRLF, $_[1]);
my $status_line = shift @hdrs;
%hdrs = map {
my ($k,$v) = split(/:\s+/,$_);
(lc($k),$v);
} @hdrs;
# $hdrs{OrigHead} = $head;
if ($status_line =~ m{HTTP/(1.\d) (\d{3}) +(.+)\s*}) {
$hdrs{HTTPVersion} = $1;
$hdrs{Status} = $2;
$hdrs{Reason} = $3;
}
}
$hdrs{'content-length'} = 0 if ($hdrs{Status} == 204);
if ($hdrs{Status} == 304) {
# should have no body
$h->on_read(sub {
$buf .= substr($_[0]->{rbuf},0,length($_[0]->{rbuf}),'');
});
$h->on_eof($done);
}
elsif (exists $hdrs{'content-length'}) {
return $done->() unless ($hdrs{'content-length'});
# Test::More::diag "$name waiting for C-L body";
$h->push_read(chunk => $hdrs{'content-length'}, sub {
$buf = $_[1];
return $done->();
});
}
elsif (($hdrs{'transfer-encoding'}||'') eq 'chunked') {
# Test::More::diag "$name waiting for T-E:chunked body";
my $len = 0;
my ($chunk_reader, $chunk_handler);
$chunk_handler = sub {
if ($len == 0) {
undef $chunk_reader;
undef $chunk_handler;
return $done->();
}
# remove CRLF at end of chunk:
$buf .= substr($_[1],0,-2);
$h->push_read(line => $CRLF, $chunk_reader);
};
$chunk_reader = sub {
my $hex = $_[1];
$len = hex $hex;
if (!defined($len)) {
$err_cb->($h,0,"invalid chunk length '$hex'");
undef $chunk_reader;
undef $chunk_handler;
return;
}
else {
# add two for after-chunk CRLF
$h->push_read(chunk => $len+2, $chunk_handler);
}
};
$h->push_read(line => $CRLF, $chunk_reader);
}
elsif ($hdrs{HTTPVersion} eq '1.0' or
($hdrs{connection}||'') eq 'close')
{
# Test::More::diag "$name waiting for conn:close body";
$h->on_read(sub {
$buf .= substr($_[0]->{rbuf},0,length($_[0]->{rbuf}),'');
});
$h->on_eof($done);
}
else {
$err_cb->($h,0,
"got a response that I don't know how to handle the body for");
return;
}
});
my $host = 'localhost'; #delete $opts{host}
my $headers = delete $opts{headers};
my $proto = delete $opts{proto} || '1.1';
my $body = delete $opts{body} || '';
$headers->{'User-Agent'} ||= 'FeersumSimpleClient/1.0';
$headers->{'Host'} ||= $host.':'.$port;
if (length($body)) {
$headers->{'Content-Length'} ||= length($body);
$headers->{'Content-Type'} ||= 'text/plain';
}
# HTTP/1.1 default is 'keep-alive'
$headers->{'Connection'} ||= 'close';
my $head = join($CRLF, map {$_.': '.$headers->{$_}} sort keys %$headers);
my $http_req = "$method $uri HTTP/$proto$CRLF";
$strong_h->push_write($http_req);
$strong_h->push_write($head.$CRLF.$CRLF.$body)
unless $opts{skip_head};
# $http_req =~ s/$CRLF/<CRLF>\n/sg;
# Test::More::diag($http_req);
return $strong_h;
}
1;
Jump to Line
Something went wrong with that request. Please try again.