File Coverage

blib/lib/Event/RPC/Server.pm
Criterion Covered Total %
statement 220 284 77.4
branch 37 68 54.4
condition 2 4 50.0
subroutine 60 93 64.5
pod 10 76 13.1
total 329 525 62.6


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