1#!/usr/bin/env perl
2
3# Test the RPC::XML::Server bug that causes a hang when a client terminates in
4# mid-message. Unlike 40_server.t, this isn't trying to fully exercise the
5# server class, just looking for and (trying to) tickle a specific bug.
6
7## no critic(RequireCheckedClose)
8
9use strict;
10use warnings;
11use subs qw(start_server);
12
13use Carp qw(carp croak);
14use File::Spec;
15use IO::Socket::IP;
16use Test::More;
17
18use HTTP::Request;
19
20use RPC::XML::Server;
21
22my ($dir, $vol, $srv, $bucket, $child, $req, $port, $socket, $body);
23
24plan tests => 2;
25
26($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
27$dir = File::Spec->catpath($vol, $dir, q{});
28require File::Spec->catfile($dir, 'util.pl');
29
30{
31    package MyServer;
32
33    use strict;
34    use base qw(RPC::XML::Server);
35
36    sub process_request
37    {
38        my $self = shift;
39        $self->SUPER::process_request(@_);
40
41        exit 1;
42    }
43}
44
45SKIP: {
46    if ($^O eq 'MSWin32' || $^O eq 'cygwin')
47    {
48        skip 'This suite does not run on MSWin/cygwin', 2;
49    }
50
51    $srv = MyServer->new(no_default => 1);
52    isa_ok($srv, 'RPC::XML::Server', 'Server instance');
53    $srv->add_method({ name      => 'echo',
54                       signature => [ 'string string' ],
55                       code      => sub { shift; return shift; } });
56
57    $port = $srv->port;
58    $req = HTTP::Request->new(POST => "http://localhost:$port/");
59    $body = RPC::XML::request->new('echo', 'foo')->as_string;
60    $req->content($body);
61    $req->protocol('HTTP/1.0');
62    $req->header(Content_Length => length $body);
63    $req->header(Content_Type => 'text/xml');
64    $req = $req->as_string;
65    $req = substr $req, 0, (length($req) - 32);
66
67    $child = start_server $srv;
68    $bucket = 0;
69    local $SIG{CHLD} = sub {
70        my $dead = wait;
71        if ($dead == $child)
72        {
73            $bucket = $? >> 8;
74        }
75        else
76        {
77            carp 'PANIC: Unknown child return';
78        }
79    };
80
81    # Create an IO::Socket object for the client-side. In order to fool the
82    # server with a bad Content-Length and terminate early, we have to ditch
83    # LWP and go old-skool.
84    $socket = IO::Socket::IP->new(Proto => 'tcp', PeerAddr => 'localhost',
85                                    PeerPort => $port)
86        or croak "Error creating IO::Socket obj: $!";
87    print {$socket} $req;
88    # This *should* force the server to drop the request. The bug relates to
89    # the fact that (previously) the server just hangs:
90    close $socket;
91
92    # Give the server time to crap out:
93    if (! $bucket)
94    {
95        sleep 95;
96    }
97
98    # If it still hasn't, kill it:
99    local $SIG{CHLD} = 'IGNORE';
100    if (! $bucket)
101    {
102        kill 'KILL', $child;
103    }
104
105    is($bucket, 1, 'Check if server hangs on short requests');
106}
107
108exit;
109