File Coverage

blib/lib/Test/HTTP/MockServer.pm

Criterion	Covered	Total	%
statement	67	69	97.1
branch	12	20	60.0
condition	1	3	33.3
subroutine	15	16	93.7
pod	6	7	85.7
total	101	115	87.8

package Test::HTTP::MockServer;
use strict;
use warnings;
use HTTP::Parser;
use HTTP::Response;
use IO::Handle;
use Socket;

our $VERSION = '0.0.1';

sub new {
    my ($class) = @_;
    $class = ref $class || $class;
    return bless {}, $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 $!;
        my $host_s = '127.0.0.1';
        my $host = inet_aton($host_s);
        my $port;
        while (1) {
            $port = int(rand(5000))+10000;
            my $addr = sockaddr_in($port, $host);
            bind($s,$addr)
              or next;
            listen($s, 10)
              or die $!;
            last;
        }
        $self->{host} = $host_s;
        $self->{port} = $port;
        $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 url_base {
    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);

    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;
            $request = undef;
            my $response = $request_handle->($self, $rp, $copy);
            $response->header('Content-length' => length($response->content));
            my $strout = "HTTP/1.1 ".($response->as_string("\015\012"));
            $client->print($strout);
            # we don't support keep-alive
            $closed = 1;
        }
        last if $closed;
    }
};

my $server_loop = sub {
    my $self = shift;
    my $rp = shift;
    while (1) {
        accept my $client, $self->{socket}
          or die "Failed to accept new connections: $!";
        eval {
            $client_handle->($self, $rp, $client);
        };
        close $client;
    }
};

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

    die "There is already a mock server running"
      if $self->{mock_server_pid};

    $self->{mock_server_pid} = fork;
    if ($self->{mock_server_pid}) {
        return;
    } else {
        $DB::signal = 1;
        $SIG{INT} = sub { exit 1; };
        $SIG{TERM} = sub { exit 1; };
        $server_loop->($self,$rp);
        exit 0;
    }
}

sub stop_mock_server {
    my $self = shift;
    die "Mock server not started"
      unless $self->{mock_server_pid};
    kill 2, $self->{mock_server_pid};
    waitpid $self->{mock_server_pid}, 0;
    delete $self->{mock_server_pid};
}

sub DESTROY {
    my $self = shift;
    eval {
        $self->stop_mock_server
          if $self->{mock_server_pid};
    };
}

1;

__END__