File Coverage

blib/lib/Test/HTTP/MockServer/Once.pm

Criterion	Covered	Total	%
statement	56	71	78.8
branch	11	22	50.0
condition	3	5	60.0
subroutine	12	15	80.0
pod	6	6	100.0
total	88	119	73.9

package Test::HTTP::MockServer::Once;
use strict;
use warnings;
use HTTP::Parser;
use HTTP::Response;
use IO::Handle;
use Socket;
use Storable qw(freeze);

our $VERSION = '0.0.2';

sub new {
	my ($class, %params) = @_;
    $class = ref $class || $class;
    return bless {
		port => $params{port} || undef
	}, $class;
}

sub bind_mock_server {
    my $self = shift;
    if (!$self->{socket}) {
        my $proto = getprotobyname("tcp")
          or die $!;
        socket my $s, PF_INET, SOCK_STREAM, $proto
          or die $!;
        setsockopt($s,SOL_SOCKET,SO_REUSEADDR,1) or die "setsockopt: $!";
        my $host_s = '127.0.0.1';
        my $host = inet_aton($host_s);
        if(defined($self->{port}))
        {
			my $addr = sockaddr_in($self->{port}, $host);
			bind($s,$addr) or die $!;
			listen($s, 10)
			  or die $!;
		}
		else
		{
	        my $random_port;
			while (1) {
				$random_port = int(rand(5000))+10000;
				my $addr = sockaddr_in($random_port, $host);
				bind($s,$addr)
				  or next;
				listen($s, 10)
				  or die $!;
				last;
			}
			$self->{port} = $random_port;
		}
        $self->{host} = $host_s;
        $self->{socket} = $s;
    }
    return 1;
}

sub host {
    my $self = shift;
    $self->bind_mock_server;
    return $self->{host};
}

sub port {
    my $self = shift;
    $self->bind_mock_server;
    return $self->{port};
}

sub base_url {
    my $self = shift;
    my $host = $self->host;
    my $port = $self->port;
    return "http://$host:$port";
}

my $request_handle = sub {
    my $self = shift;
    my $rp = shift;
    my $request = shift;
    my $response;
    eval {
        $response = HTTP::Response->new(200, 'OK');
        $response->header('Content-type' => 'text/plain');
        $rp->($request, $response);
    };
    if ($@) {
        my $err = $@;
        return HTTP::Response->new(
            500, 'Internal Server Error',
            HTTP::Headers->new("Content-type" => "text/plain"),
            $err
        );
    } else {
        return $response;
    }
};

my $client_handle = sub {
    my $self = shift;
    my $rp = shift;
    my $client = shift;
    my $parser = HTTP::Parser->new(request => 1);

	my $ret;
    while (1) {
        my $buf;
        # read a byte at a time so we can do a blocking read instead of
        # having to manage a non-blocking read loop.
        my $r = read $client, $buf, 1;
        my $request;
        my $closed;
        if (defined $r) {
            my $p = $parser->add($buf);
            if ($p == 0) {
                $request = $parser->object;
            }
            $closed = 0;
        } else {
            $request = $parser->object;
            $closed = 1;
        }
        if ($request) {
            my $copy = $request;
            $ret->{request} = $request;
            $request = undef;
            my $response = $request_handle->($self, $rp, $copy);
            $response->header('Content-length' => length($response->content));
            $ret->{response} = $response;
            my $strout = "HTTP/1.1 ".($response->as_string("\015\012"));
            $client->print($strout);
            # we don't support keep-alive
            $closed = 1;
        }
        last if $closed;
    }
    return $ret;
};

sub start_mock_server {
    my $self = shift;
    my $rp = shift or die "No request processor";

	$self->bind_mock_server();

	$DB::signal = 1;
	$SIG{INT} = sub { exit 1; };
	$SIG{TERM} = sub { exit 1; };
	accept my $client, $self->{socket}
	  or die "Failed to accept new connections: $!";
	my $interaction;
	eval {
		$interaction = $client_handle->($self, $rp, $client);
	};
	close $client;
	close $self->{socket};
	return freeze $interaction;
}

1;

__END__