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