/
60_net_server.t
175 lines (146 loc) · 5.84 KB
/
60_net_server.t
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
#!/usr/bin/perl
# Test the RPC::XML::Server class with Net::Server rather than HTTP::Daemon
# This is run after the test suite for RPC::XML::Client, so we will use that
# for the client-side of the tests.
use strict;
use vars qw($dir $srv $pid_file $log_file $port $client $res @keys $meth $list
$bucket %seen);
use subs qw(start_server find_port);
use File::Spec;
use Test;
BEGIN
{
eval "use Net::Server";
if ($@)
{
# If they do not have Net::Server, quietly skip
plan tests => 0;
exit;
}
else
{
plan tests => 17;
}
}
require RPC::XML::Server;
require RPC::XML::Client;
(undef, $dir, undef) = File::Spec->splitpath($0);
require File::Spec->catfile($dir, 'util.pl');
$pid_file = File::Spec->catfile($dir, 'net_server.pid');
$log_file = File::Spec->catfile($dir, 'net_server.log');
die "No usable port found between 9000 and 10000, skipping"
if (($port = find_port) == -1);
unlink $log_file if (-e $log_file);
unlink $pid_file if (-e $pid_file);
# All this, and we haven't even created a server object or run a test yet
$srv = RPC::XML::Server->new(no_http => 1);
# Technically, this is overkill. But it never hurts...
ok(ref $srv);
# All of these parameters are passed to the run() method of
# Net::Server::MultiType
start_server($srv,
server_type => 'Single',
log_file => $log_file,
log_level => 4,
pid_file => $pid_file,
port => $port,
host => 'localhost',
background => 1);
sleep 1; # Allow time for server to spin up
# Unless we see "ok 2", we have a problem
ok(-e $pid_file);
# After this point, we have the obligation of killing the server manually
$client = RPC::XML::Client->new("http://localhost:$port");
ok($client->simple_request('system.identity') eq $srv->product_tokens);
# At this point, most of this is copied from the first server test suite (40).
# We do want to verify the full introspection API under Net::Server, though.
$res = $client->simple_request('system.listMethods');
@keys = $srv->list_methods;
ok((ref($res) eq 'ARRAY') && (@$res == @keys) &&
(join('', sort @$res) eq join('', sort @keys)));
# Test the substring-parameter calling of system.listMethods
$res = $client->simple_request('system.listMethods', 'method');
ok((ref($res) eq 'ARRAY') &&
(join(',', sort @$res) eq 'system.methodHelp,system.methodSignature'));
# Again, with a pattern that will produce no matches
$res = $client->simple_request('system.listMethods', 'microsquirt');
ok((ref($res) eq 'ARRAY') && (@$res == 0));
# system.status
$res = $client->simple_request('system.status');
@keys = qw(host port name version path date date_int started started_int
total_requests methods_known);
ok((ref($res) eq 'HASH') && (grep(defined $res->{$_}, @keys) == @keys) &&
($res->{total_requests} == 5));
# system.methodHelp
$res = $client->simple_request('system.methodHelp', 'system.identity');
ok($res eq $srv->get_method('system.identity')->{help});
# system.methodHelp with multiple arguments
$res = $client->simple_request('system.methodHelp',
[ 'system.identity', 'system.status' ]);
ok(join('', @$res) eq
$srv->get_method('system.identity')->{help} .
$srv->get_method('system.status')->{help});
# system.methodHelp with an invalid argument
$res = $client->send_request('system.methodHelp', 'system.teaseMe');
ok(ref($res) && $res->is_fault() && $res->string() =~ /Method.*unknown/);
# system.methodSignature
$res = $client->simple_request('system.methodSignature', 'system.methodHelp')
;
ok(join('', sort @$res) eq
join('', sort @{ $srv->get_method('system.methodHelp')->{signature} }));
# system.methodSignature, with an invalid request
$res = $client->send_request('system.methodSignature', 'system.pleaseMe');
ok(ref($res) && $res->is_fault() && $res->string() =~ /Method.*unknown/);
# system.introspection
$list = $client->simple_request('system.introspection');
$bucket = 0;
%seen = ();
for $res (@$list)
{
if ($seen{$res->{name}}++)
{
# If we somehow get the same name twice, that's a point off
$bucket++;
next;
}
$meth = $srv->get_method($res->{name});
if ($meth)
{
$bucket++ unless
(($meth->{help} eq $res->{help}) &&
($meth->{version} eq $res->{version}) &&
(join('', sort @{ $res->{signature } }) eq
join('', sort @{ $meth->{signature} })));
}
else
{
# That's a point
$bucket++;
}
}
ok(! $bucket);
# system.multicall
$res = $client->simple_request('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.listMethods',
params => [ 'intro' ] } ]);
ok((ref($res) eq 'ARRAY') && ($res->[0] eq $srv->product_tokens) &&
($res->[1]->[0] eq 'system.introspection'));
# system.multicall, with an attempt at illegal recursion
$res = $client->send_request('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.multicall',
params => [ 'intro' ] } ]);
ok($res->is_fault && $res->string =~ /Recursive/);
# system.multicall, with bad data on one of the call specifications
$res = $client->send_request('system.multicall',
[ { methodName => 'system.identity' },
{ methodName => 'system.listMethods',
params => 'intro' } ]);
ok($res->is_fault && $res->string =~ /value for.*params.*not an array/i);
# system.status, once more, to check the total_requests value
$res = $client->simple_request('system.status');
ok($res->{total_requests} == 19);
# Now that we're done, kill the server and exit
kill 'INT', `cat $pid_file`;
exit;