File Coverage

blib/lib/Event/RPC/Server.pm
Criterion Covered Total %
statement 24 237 10.1
branch 0 58 0.0
condition 0 4 0.0
subroutine 8 82 9.7
pod 10 71 14.0
total 42 452 9.2


line stmt bran cond sub pod time code
1             #-----------------------------------------------------------------------
2             # Copyright (C) 2002-2006 Jörn Reder .
3             # All Rights Reserved. See file COPYRIGHT for details.
4             #
5             # This module is part of Event::RPC, which is free software; you can
6             # redistribute it and/or modify it under the same terms as Perl itself.
7             #-----------------------------------------------------------------------
8              
9             package Event::RPC::Server;
10              
11 1     1   1335 use Event::RPC;
  1         2  
  1         26  
12 1     1   453 use Event::RPC::Message;
  1         4  
  1         42  
13 1     1   1059 use Event::RPC::Connection;
  1         5  
  1         46  
14 1     1   690 use Event::RPC::LogConnection;
  1         6  
  1         141  
15              
16 1     1   29 use Carp;
  1         3  
  1         131  
17 1     1   11 use strict;
  1         4  
  1         49  
18 1     1   6027 use IO::Socket::INET;
  1         20656  
  1         8  
19 1     1   17795 use Sys::Hostname;
  1         7181  
  1         4574  
20              
21 0     0 0   sub get_host { shift->{host} }
22 0     0 0   sub get_port { shift->{port} }
23 0     0 0   sub get_name { shift->{name} }
24 0     0 0   sub get_loop { shift->{loop} }
25 0     0 0   sub get_classes { shift->{classes} }
26 0     0 0   sub get_singleton_classes { shift->{singleton_classes} }
27 0     0 0   sub get_loaded_classes { shift->{loaded_classes} }
28 0     0 1   sub get_clients_connected { shift->{clients_connected} }
29 0     0 1   sub get_log_clients_connected { shift->{log_clients_connected} }
30 0     0 0   sub get_logging_clients { shift->{logging_clients} }
31 0     0 0   sub get_logger { shift->{logger} }
32 0     0 0   sub get_start_log_listener { shift->{start_log_listener} }
33 0     0 0   sub get_objects { shift->{objects} }
34 0     0 0   sub get_rpc_socket { shift->{rpc_socket} }
35 0     0 0   sub get_ssl { shift->{ssl} }
36 0     0 0   sub get_ssl_key_file { shift->{ssl_key_file} }
37 0     0 0   sub get_ssl_cert_file { shift->{ssl_cert_file} }
38 0     0 0   sub get_ssl_passwd_cb { shift->{ssl_passwd_cb} }
39 0     0 0   sub get_ssl_opts { shift->{ssl_opts} }
40 0     0 0   sub get_auth_required { shift->{auth_required} }
41 0     0 0   sub get_auth_passwd_href { shift->{auth_passwd_href} }
42 0     0 0   sub get_auth_module { shift->{auth_module} }
43 0     0 0   sub get_listeners_started { shift->{listeners_started} }
44 0     0 0   sub get_connection_hook { shift->{connection_hook} }
45 0     0 0   sub get_load_modules { shift->{load_modules} }
46 0     0 0   sub get_auto_reload_modules { shift->{auto_reload_modules} }
47 0     0 1   sub get_active_connection { shift->{active_connection} }
48              
49 0     0 0   sub set_host { shift->{host} = $_[1] }
50 0     0 0   sub set_port { shift->{port} = $_[1] }
51 0     0 0   sub set_name { shift->{name} = $_[1] }
52 0     0 0   sub set_loop { shift->{loop} = $_[1] }
53 0     0 0   sub set_classes { shift->{classes} = $_[1] }
54 0     0 0   sub set_singleton_classes { shift->{singleton_classes} = $_[1] }
55 0     0 0   sub set_loaded_classes { shift->{loaded_classes} = $_[1] }
56 0     0 0   sub set_clients_connected { shift->{clients_connected} = $_[1] }
57 0     0 0   sub set_log_clients_connected { shift->{log_clients_connected}= $_[1] }
58 0     0 0   sub set_logging_clients { shift->{logging_clients} = $_[1] }
59 0     0 0   sub set_logger { shift->{logger} = $_[1] }
60 0     0 0   sub set_start_log_listener { shift->{start_log_listener} = $_[1] }
61 0     0 0   sub set_objects { shift->{objects} = $_[1] }
62 0     0 0   sub set_rpc_socket { shift->{rpc_socket} = $_[1] }
63 0     0 0   sub set_ssl { shift->{ssl} = $_[1] }
64 0     0 0   sub set_ssl_key_file { shift->{ssl_key_file} = $_[1] }
65 0     0 0   sub set_ssl_cert_file { shift->{ssl_cert_file} = $_[1] }
66 0     0 0   sub set_ssl_passwd_cb { shift->{ssl_passwd_cb} = $_[1] }
67 0     0 0   sub set_ssl_opts { shift->{ssl_opts} = $_[1] }
68 0     0 0   sub set_auth_required { shift->{auth_required} = $_[1] }
69 0     0 0   sub set_auth_passwd_href { shift->{auth_passwd_href} = $_[1] }
70 0     0 0   sub set_auth_module { shift->{auth_module} = $_[1] }
71 0     0 0   sub set_listeners_started { shift->{listeners_started} = $_[1] }
72 0     0 0   sub set_connection_hook { shift->{connection_hook} = $_[1] }
73 0     0 0   sub set_load_modules { shift->{load_modules} = $_[1] }
74 0     0 0   sub set_auto_reload_modules { shift->{auto_reload_modules} = $_[1] }
75 0     0 0   sub set_active_connection { shift->{active_connection} = $_[1] }
76              
77             my $INSTANCE;
78 0     0 1   sub instance { $INSTANCE }
79              
80             sub get_max_packet_size {
81 0     0 1   return Event::RPC::Message->get_max_packet_size;
82             }
83              
84             sub set_max_packet_size {
85 0     0 1   my $class = shift;
86 0           my ($value) = @_;
87 0           Event::RPC::Message->set_max_packet_size($value);
88             }
89              
90             sub new {
91 0     0 0   my $class = shift;
92 0           my %par = @_;
93             my ($host, $port, $classes, $name, $logger, $start_log_listener) =
94 0           @par{'host','port','classes','name','logger','start_log_listener'};
95             my ($ssl, $ssl_key_file, $ssl_cert_file, $ssl_passwd_cb, $ssl_opts) =
96 0           @par{'ssl','ssl_key_file','ssl_cert_file','ssl_passwd_cb','ssl_opts'};
97             my ($auth_required, $auth_passwd_href, $auth_module, $loop) =
98 0           @par{'auth_required','auth_passwd_href','auth_module','loop'};
99             my ($connection_hook, $auto_reload_modules, $load_modules) =
100 0           @par{'connection_hook','auto_reload_modules','load_modules'};
101              
102 0   0       $name ||= "Event-RPC-Server";
103              
104             #-- for backwards compatibility 'load_modules' defaults to 1
105 0 0         if ( !exists $par{load_modules} ) {
106 0           $load_modules = 1;
107             }
108              
109 0 0         if ( not $loop ) {
110 0           foreach my $impl ( qw/AnyEvent Event Glib/ ) {
111 0           $loop = "Event::RPC::Loop::$impl";
112 0           eval "use $loop";
113 0 0         if ( $@ ) {
114 0           $loop = undef;
115             }
116             else {
117 0           $loop = $loop->new;
118 0           last;
119             }
120             }
121 0 0         die "It seems no supported event loop module is installed"
122             unless $loop;
123             }
124              
125 0           my $self = bless {
126             host => $host,
127             port => $port,
128             name => $name,
129             classes => $classes,
130             singleton_classes => {},
131             logger => $logger,
132             start_log_listener => $start_log_listener,
133             loop => $loop,
134              
135             ssl => $ssl,
136             ssl_key_file => $ssl_key_file,
137             ssl_cert_file => $ssl_cert_file,
138             ssl_passwd_cb => $ssl_passwd_cb,
139             ssl_opts => $ssl_opts,
140              
141             auth_required => $auth_required,
142             auth_passwd_href => $auth_passwd_href,
143             auth_module => $auth_module,
144              
145             load_modules => $load_modules,
146             auto_reload_modules => $auto_reload_modules,
147             connection_hook => $connection_hook,
148              
149             rpc_socket => undef,
150             loaded_classes => {},
151             objects => {},
152             logging_clients => {},
153             clients_connected => 0,
154             listeners_started => 0,
155             log_clients_connected => 0,
156             active_connection => undef,
157             }, $class;
158              
159 0           $INSTANCE = $self;
160              
161 0           $self->log ($self->get_name." started");
162              
163 0           return $self;
164             }
165              
166             sub DESTROY {
167 0     0     my $self = shift;
168              
169 0           my $rpc_socket = $self->get_rpc_socket;
170 0 0         close ($rpc_socket) if $rpc_socket;
171              
172 0           1;
173             }
174              
175             sub setup_listeners {
176 0     0 1   my $self = shift;
177              
178             #-- Listener options
179 0           my $host = $self->get_host;
180 0           my $port = $self->get_port;
181 0 0         my @LocalHost = $host ? ( LocalHost => $host ) : ();
182 0   0       $host ||= "*";
183              
184             #-- get event loop manager
185 0           my $loop = $self->get_loop;
186              
187             #-- setup rpc listener
188 0           my $rpc_socket;
189 0 0         if ( $self->get_ssl ) {
190 0           eval { require IO::Socket::SSL };
  0            
191 0 0         croak "SSL requested, but IO::Socket::SSL not installed" if $@;
192 0 0         croak "ssl_key_file not set" unless $self->get_ssl_key_file;
193 0 0         croak "ssl_cert_file not set" unless $self->get_ssl_cert_file;
194              
195 0           my $ssl_opts = $self->get_ssl_opts;
196              
197             $rpc_socket = IO::Socket::SSL->new (
198             Listen => SOMAXCONN,
199             @LocalHost,
200             LocalPort => $port,
201             Proto => 'tcp',
202             ReuseAddr => 1,
203             SSL_key_file => $self->get_ssl_key_file,
204             SSL_cert_file => $self->get_ssl_cert_file,
205             SSL_passwd_cb => $self->get_ssl_passwd_cb,
206 0 0         ($ssl_opts?%{$ssl_opts}:()),
  0 0          
207             ) or die "can't start SSL RPC listener: $IO::Socket::SSL::ERROR";
208             }
209             else {
210 0 0         $rpc_socket = IO::Socket::INET->new (
211             Listen => SOMAXCONN,
212             @LocalHost,
213             LocalPort => $port,
214             Proto => 'tcp',
215             ReuseAddr => 1,
216             ) or die "can't start RPC listener: $!";
217             }
218              
219 0           $self->set_rpc_socket($rpc_socket);
220              
221             $loop->add_io_watcher (
222             fh => $rpc_socket,
223             poll => 'r',
224 0     0     cb => sub { $self->accept_new_client($rpc_socket); 1 },
  0            
225 0           desc => "rpc listener port $port",
226             );
227              
228 0 0         if ( $self->get_ssl ) {
229 0           $self->log ("Started SSL RPC listener on port $host:$port");
230             } else {
231 0           $self->log ("Started RPC listener on $host:$port");
232             }
233              
234             # setup log listener
235 0 0         if ( $self->get_start_log_listener ) {
236 0 0         my $log_socket = IO::Socket::INET->new (
237             Listen => SOMAXCONN,
238             LocalPort => $port + 1,
239             @LocalHost,
240             Proto => 'tcp',
241             ReuseAddr => 1,
242             ) or die "can't start log listener: $!";
243              
244             $loop->add_io_watcher (
245             fh => $log_socket,
246             poll => 'r',
247 0     0     cb => sub { $self->accept_new_log_client($log_socket); 1 },
  0            
248 0           desc => "log listener port ".($port+1),
249             );
250              
251 0           $self->log ("Started log listener on $host:".($port+1));
252             }
253              
254 0           $self->determine_singletons;
255              
256 0           $self->set_listeners_started(1);
257              
258 0           1;
259             }
260              
261             sub setup_auth_module {
262 0     0 0   my $self = shift;
263              
264             #-- Exit if no auth is required or setup already
265 0 0         return if not $self->get_auth_required;
266 0 0         return if $self->get_auth_module;
267              
268             #-- Default to Event::RPC::AuthPasswdHash
269 0           require Event::RPC::AuthPasswdHash;
270              
271             #-- Setup an instance
272 0           my $passwd_href = $self->get_auth_passwd_href;
273 0           my $auth_module = Event::RPC::AuthPasswdHash->new ($passwd_href);
274 0           $self->set_auth_module($auth_module);
275              
276 0           1;
277             }
278              
279             sub start {
280 0     0 1   my $self = shift;
281              
282 0 0         $self->setup_listeners
283             unless $self->get_listeners_started;
284              
285 0           $self->setup_auth_module;
286              
287 0           my $loop = $self->get_loop;
288              
289 0           $self->log ("Enter main loop using ".ref($loop));
290              
291 0           $loop->enter;
292              
293 0           $self->log ("Server stopped");
294              
295 0           1;
296             }
297              
298             sub stop {
299 0     0 1   my $self = shift;
300              
301 0           $self->get_loop->leave;
302              
303 0           1;
304             }
305              
306             sub determine_singletons {
307 0     0 0   my $self = shift;
308              
309 0           my $classes = $self->get_classes;
310 0           my $singleton_classes = $self->get_singleton_classes;
311              
312 0           foreach my $class ( keys %{$classes} ) {
  0            
313 0           foreach my $method ( keys %{$classes->{$class}} ) {
  0            
314             # check for singleton returner
315 0 0         if ( $classes->{$class}->{$method} eq '_singleton' ) {
316             # change to constructor
317 0           $classes->{$class}->{$method} = '_constructor';
318             # track that this class is a singleton
319 0           $singleton_classes->{$class} = 1;
320 0           last;
321             }
322             }
323             }
324              
325 0           1;
326             }
327              
328             sub accept_new_client {
329 0     0 0   my $self = shift;
330 0           my ($rpc_socket) = @_;
331              
332 0 0         my $client_socket = $rpc_socket->accept or return;
333              
334 0           Event::RPC::Connection->new ($self, $client_socket);
335              
336 0           $self->set_clients_connected ( 1 + $self->get_clients_connected );
337              
338 0           1;
339             }
340              
341             sub accept_new_log_client {
342 0     0 0   my $self = shift;
343 0           my ($log_socket) = @_;
344              
345 0 0         my $client_socket = $log_socket->accept or return;
346              
347 0           my $log_client =
348             Event::RPC::LogConnection->new($self, $client_socket);
349              
350 0           $self->set_log_clients_connected ( 1 + $self->get_log_clients_connected );
351 0           $self->get_logging_clients->{$log_client->get_cid} = $log_client;
352 0 0         $self->get_logger->add_fh($client_socket)
353             if $self->get_logger;
354              
355 0           $self->log(2, "New log client connected");
356              
357 0           1;
358             }
359              
360             sub load_class {
361 0     0 0   my $self = shift;
362 0           my ($class) = @_;
363              
364 0           Event::RPC::Connection->new ($self)->load_class($class);
365              
366 0           return $class;
367             }
368              
369             sub log {
370 0     0 1   my $self = shift;
371 0           my $logger = $self->get_logger;
372 0 0         return unless $logger;
373 0           $logger->log(@_);
374 0           1;
375             }
376              
377             sub remove_object {
378 0     0 0   my $self = shift;
379 0           my ($object) = @_;
380              
381 0           my $objects = $self->get_objects;
382              
383 0 0         if ( not $objects->{"$object"} ) {
384 0           warn "Object $object not registered";
385 0           return;
386             }
387              
388 0           delete $objects->{"$object"};
389              
390 0           $self->log(5, "Object '$object' removed");
391              
392 0           1;
393             }
394              
395             sub register_object {
396 0     0 0   my $self = shift;
397 0           my ($object, $class) = @_;
398              
399 0           my $objects = $self->get_objects;
400              
401 0           my $refcount;
402 0 0         if ( $objects->{"$object"} ) {
403 0           $refcount = ++$objects->{"$object"}->{refcount};
404             } else {
405 0           $refcount = 1;
406 0           $objects->{"$object"} = {
407             object => $object,
408             class => $class,
409             refcount => 1,
410             };
411             }
412              
413 0           $self->log(5, "Object '$object' registered. Refcount=$refcount");
414              
415 0           1;
416             }
417              
418             sub deregister_object {
419 0     0 0   my $self = shift;
420 0           my ($object) = @_;
421              
422 0           my $objects = $self->get_objects;
423              
424 0 0         if ( not $objects->{"$object"} ) {
425 0           warn "Object $object not registered";
426 0           return;
427             }
428              
429 0           my $refcount = --$objects->{"$object"}->{refcount};
430              
431 0           my ($class) = split(/=/, $object);
432 0 0         if ( $self->get_singleton_classes->{$class} ) {
433             # never deregister singletons
434 0           $self->log(4, "Skip deregistration of singleton '$object'");
435 0           return;
436             }
437              
438 0           $self->log(5, "Object '$object' deregistered. Refcount=$refcount");
439              
440 0 0         $self->remove_object($object) if $refcount == 0;
441              
442 0           1;
443             }
444              
445             sub print_object_register {
446 0     0 0   my $self = shift;
447              
448 0           print "-"x70,"\n";
449              
450 0           my $objects = $self->get_objects;
451 0           foreach my $oid ( sort keys %{$objects} ) {
  0            
452 0           print "$oid\t$objects->{$oid}->{refcount}\n";
453             }
454              
455 0           1;
456             }
457              
458             1;
459              
460             __END__