#!/usr/bin/perl
# $Id: 41_server_hang.t 332 2008-03-26 09:06:04Z  $

# Test the RPC::XML::Server bug that causes a hang when a client terminates in
# mid-message. Unlike 40_server.t, this isn't trying to fully exercise the
# server class, just looking for and (trying to) tickle a specific bug.

use strict;
use subs qw(start_server find_port);
use vars qw($dir $srv $bucket $child $req $port $socket $body);

use File::Spec;
use Test::More tests => 2;

use LWP::UserAgent;
use HTTP::Request;

require RPC::XML::Server;
require IO::Socket;

(undef, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
require File::Spec->catfile($dir, 'util.pl');

{
    package MyServer;

    use strict;

    our @ISA = qw(RPC::XML::Server);

    sub process_request
    {
        my $self = shift;
        $self->SUPER::process_request(@_);

        exit 1;
    }
}

die "No usable port found between 9000 and 10000, skipping"
    if (($port = find_port) == -1);
$srv = MyServer->new(no_default => 1, port => $port);
isa_ok($srv, 'RPC::XML::Server', 'Server instance');
$srv->add_method({ name      => 'echo',
                   signature => [ 'string string' ],
                   code      => sub { shift; return shift; } });

$req = HTTP::Request->new(POST => "http://localhost:$port/");
$body = RPC::XML::request->new('echo', 'foo')->as_string;
$req->content($body);
$req->protocol('HTTP/1.0');
$req->header(Content_Length => length($body));
$req->header(Content_Type => 'text/xml');
$req = $req->as_string;
substr($req, -32) = '';

$child = start_server($srv);
$bucket = 0;
$SIG{CHLD} = sub {
    my $dead = wait;
    if ($dead == $child)
    {
        $bucket = $? >> 8;
    }
    else
    {
        warn "PANIC: Unknown child return";
    }
};

# Create an IO::Socket object for the client-side. In order to fool the
# server with a bad Content-Length and terminate early, we have to ditch
# LWP and go old-skool.
$socket = IO::Socket::INET->new(Proto => 'tcp', PeerAddr => 'localhost',
                                PeerPort => $port)
    or die "Error creating IO::Socket obj: $!";
print $socket "$req";
# This *should* force the server to drop the request. The bug relates to the
# fact that (currently) the server just hangs:
close($socket);

# Give the server time to crap out:
sleep 95 unless $bucket;

# If it still hasn't, kill it:
$SIG{CHLD} = 'IGNORE';
kill 'KILL', $child unless $bucket;

is($bucket, 1, 'Check if server hangs on short requests');

exit;
