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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
|
package Event_RPC_Test_Server;
use strict;
use utf8;
use lib qw(t);
use Fcntl qw( :flock );
sub start_server {
my $class = shift;
my %opts = @_;
#-- fork
my $server_pid = fork();
die "can't fork" unless defined $server_pid;
#-- Client?
if ( $server_pid ) {
#-- client tries to make a log connection to
#-- verify that the server is up and running
#-- (20 times with a usleep of 0.25, so the
#-- overall timeout is 5 seconds)
for ( 1..20 ) {
eval {
Event::RPC::Client->log_connect (
server => "localhost",
port => $opts{p}+1,
);
};
#-- return to client code if connect succeeded
return $server_pid if !$@;
#-- bail out if the limit is reached
if ( $_ == 20 ) {
die "Couldn't start server: $@";
}
#-- wait a quarter second...
select(undef, undef, undef, 0.25);
}
#-- Client is finished here
return $server_pid;
}
#-- We're in the server
require Event::RPC::Server;
require Event::RPC::Logger;
require Event_RPC_Test;
require Event_RPC_Test2;
#-- This code is mainly copied from the server.pl
#-- example and works with a command line style
#-- %opts hash
my %ssl_args;
if ( $opts{s} ) {
%ssl_args = (
ssl => 1,
ssl_key_file => 't/ssl/server.key',
ssl_cert_file => ($opts{sf}||'t/ssl/server.crt'),
ssl_passwd_cb => sub { 'eventrpc' },
);
if ( not -f 't/ssl/server.key' ) {
print "please execute from toplevel directory\n";
}
}
my %auth_args;
if ( $opts{a} ) {
my ($user, $pass) = split(":", $opts{a});
$pass = Event::RPC->crypt($user, $pass);
%auth_args = (
auth_required => 1,
auth_passwd_href => { $user => $pass },
);
}
#-- Create a logger object
my $logger = $opts{l} ? Event::RPC::Logger->new (
min_level => $opts{l},
fh_lref => [ \*STDOUT ],
) : undef;
#-- Create a loop object
my $loop;
my $loop_module = $opts{L};
if ( $loop_module ) {
eval "use $loop_module";
die $@ if $@;
$loop = $loop_module->new();
}
my $port = $opts{p} || 5555;
my $disconnect_cnt = $opts{S};
#-- Create a Server instance and declare the
#-- exported interface
my $server;
$server = Event::RPC::Server->new (
name => "test daemon",
port => $port,
loop => $loop,
logger => $logger,
start_log_listener => 1,
load_modules => 0,
message_formats => $opts{f},
insecure_msg_fmt_ok => $opts{i},
%auth_args,
%ssl_args,
classes => {
'Event_RPC_Test' => {
new => '_constructor',
singleton => '_singleton',
set_data => 1,
get_data => 1,
hello => 1,
quit => 1,
clone => '_object',
multi => '_object',
get_object2 => '_object',
new_object2 => '_object',
echo => 1,
get_cid => 1,
get_object_cnt => 1,
get_undef_object => '_object',
get_big_data_struct => 1,
async_call_1 => 'object:async:reeintrant'
},
'Event_RPC_Test2' => {
new => '_constructor',
set_data => 1,
get_data => 1,
hello => 1,
quit => 1,
clone => '_object',
multi => '_object',
get_object2 => '_object',
new_object2 => '_object',
echo => 1,
get_cid => 1,
get_object_cnt => 1,
get_undef_object => '_object',
get_big_data_struct => 1,
async_call_1 => 'object:async:reeintrant'
},
'Event_RPC_Test2' => {
new => '_constructor',
set_data => 1,
get_data => 1,
get_object_copy => 1,
},
},
connection_hook => sub {
my ($conn, $event) = @_;
return if $event eq 'connect';
--$disconnect_cnt;
$server->stop
if $disconnect_cnt <= 0 &&
$server->get_clients_connected == 0;
1;
},
);
$server->set_max_packet_size($opts{M}) if $opts{M};
#-- Start the server resp. the Event loop.
$server->start;
#-- Exit the program
exit;
}
sub port {
my $file = "port.txt";
open (my $fh, "+>>", $file) or die "Can't open '$file': $!";
flock($fh, LOCK_EX) or die "Cannot lock $file: $!";
seek $fh, 0, 0;
my $port = <$fh> || 27808;
chomp $port;
truncate $fh, 0;
$port += 2;
$port = 27810 if $port > 65000;
print $fh "$port\n";
close $fh;
return $port;
}
1;
|
