#!/usr/bin/perl
# 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 $vol $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;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
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;
}
}
SKIP: {
skip "This suite does not run on MSWin", 2 if ($^O eq "MSWin32");
$srv = MyServer->new(no_default => 1);
isa_ok($srv, 'RPC::XML::Server', 'Server instance');
$srv->add_method({ name => 'echo',
signature => [ 'string string' ],
code => sub { shift; return shift; } });
$port = $srv->port;
$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 (previously) 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;