1#!/usr/bin/env perl 2 3# http://rt.cpan.org/Ticket/Display.html?id=54183 4# 5# Test that the RPC::XML::Server class can handle SIGPIPE issues 6 7# Here, we don't care about the return value of eval's, because of the ALRM 8# signal handlers: 9## no critic(RequireCheckingReturnValueOfEval) 10 11use strict; 12use warnings; 13use subs qw(start_server stop_server); 14 15use Test::More; 16 17use File::Spec; 18 19use RPC::XML::Server; 20use RPC::XML::Client; 21 22my ($dir, $vol, $srv, $child, $port, $cli, $res); 23 24# This suite doesn't run on Windows, since it's based on *NIX signals 25if ($^O eq 'MSWin32' || $^O eq 'cygwin') 26{ 27 plan skip_all => 'Skipping *NIX signals-based test on Windows platform'; 28 exit; 29} 30 31($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); 32$dir = File::Spec->catpath($vol, $dir, q{}); 33require File::Spec->catfile($dir, 'util.pl'); 34 35$srv = RPC::XML::Server->new(host => 'localhost'); 36if (! ref $srv) 37{ 38 plan skip_all => "Creating server failed: $srv" 39} 40else 41{ 42 plan tests => 4; 43 $port = $srv->port; 44} 45 46$cli = RPC::XML::Client->new("http://localhost:$port"); 47$srv->add_method({ 48 name => 'test', 49 signature => [ 'string' ], 50 code => sub { 51 my ($server) = @_; 52 53 sleep 3; 54 55 return 'foo'; 56 } 57}); 58 59$child = start_server $srv; 60 61eval { 62 local $SIG{ALRM} = sub { die "alarm\n" }; 63 alarm 1; 64 $res = $cli->send_request('test'); 65 alarm 0; # Shouldn't reach here 66}; 67like($res, qr/alarm/, 'Initial request alarmed-out correctly'); 68 69eval { 70 local $SIG{ALRM} = sub { die "alarm\n" }; 71 alarm 6; 72 $res = $cli->send_request('test'); 73 alarm 0; # Shouldn't reach here 74}; 75unlike($res, qr/alarm/, 'Second request did not alarm-out'); 76 77ok(ref($res) && $res->value eq 'foo', 'Second request correct value'); 78 79eval { 80 local $SIG{ALRM} = sub { die "alarm\n" }; 81 alarm 2; 82 $res = $cli->send_request('system.status'); 83 alarm 0; 84}; 85ok(ref($res) && ref($res->value) eq 'HASH', 'Good system.status return'); 86 87stop_server $child, 'final'; 88 89exit; 90