File Coverage

blib/lib/Event/RPC/Client.pm
Criterion Covered Total %
statement 236 293 80.5
branch 61 94 64.8
condition 10 25 40.0
subroutine 50 71 70.4
pod 8 55 14.5
total 365 538 67.8


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::Client;
10              
11 58     58   378503 use Event::RPC;
  58         336  
  58         2524  
12 24     24   6767 use Event::RPC::Message::Negotiate;
  24         49  
  24         622  
13              
14 24     24   131 use Carp;
  24         40  
  24         2230  
15 24     24   118 use strict;
  24         49  
  24         570  
16 24     24   125 use utf8;
  24         41  
  24         143  
17              
18 24     24   9923 use IO::Socket::INET;
  24         224913  
  24         265  
19              
20             #-- This can be changed for testing purposes e.g. to simulate
21             #-- old clients connecting straight with Storable format.
22             $Event::RPC::Client::DEFAULT_MESSAGE_FORMAT = "Event::RPC::Message::Negotiate";
23              
24 74     74 1 698 sub get_client_version { $Event::RPC::VERSION }
25 74     74 1 1001 sub get_client_protocol { $Event::RPC::PROTOCOL }
26              
27 0     0 0 0 sub get_host { shift->{host} }
28 84     84 0 411 sub get_port { shift->{port} }
29 957     957 0 56698 sub get_sock { shift->{sock} }
30 84     84 0 334 sub get_timeout { shift->{timeout} }
31 73     73 0 350 sub get_classes { shift->{classes} }
32 146     146 0 423 sub get_class_map { shift->{class_map} }
33 146     146 0 473 sub get_loaded_classes { shift->{loaded_classes} }
34 7     7 0 63 sub get_error_cb { shift->{error_cb} }
35 84     84 0 282 sub get_ssl { shift->{ssl} }
36 0     0 0 0 sub get_ssl_ca_file { shift->{ssl_ca_file} }
37 0     0 0 0 sub get_ssl_ca_path { shift->{ssl_ca_path} }
38 0     0 0 0 sub get_ssl_opts { shift->{ssl_opts} }
39 74     74 0 292 sub get_auth_user { shift->{auth_user} }
40 74     74 0 242 sub get_auth_pass { shift->{auth_pass} }
41 292     292 0 68975 sub get_connected { shift->{connected} }
42 84     84 0 350 sub get_server { shift->{server} }
43 0     0 1 0 sub get_server_version { shift->{server_version} }
44 0     0 1 0 sub get_server_protocol { shift->{server_protocol} }
45 925     925 0 36829 sub get_message_format { shift->{message_format} }
46 69     69 0 1833 sub get_insecure_msg_fmt_ok { shift->{insecure_msg_fmt_ok} }
47              
48 0     0 0 0 sub set_host { shift->{host} = $_[1] }
49 0     0 0 0 sub set_port { shift->{port} = $_[1] }
50 84     84 0 839 sub set_sock { shift->{sock} = $_[1] }
51 0     0 0 0 sub set_timeout { shift->{timeout} = $_[1] }
52 0     0 0 0 sub set_classes { shift->{classes} = $_[1] }
53 0     0 0 0 sub set_class_map { shift->{class_map} = $_[1] }
54 0     0 0 0 sub set_loaded_classes { shift->{loaded_classes} = $_[1] }
55 0     0 0 0 sub set_error_cb { shift->{error_cb} = $_[1] }
56 0     0 0 0 sub set_ssl { shift->{ssl} = $_[1] }
57 0     0 0 0 sub set_ssl_ca_file { shift->{ssl_ca_file} = $_[1] }
58 0     0 0 0 sub set_ssl_ca_path { shift->{ssl_ca_path} = $_[1] }
59 0     0 0 0 sub set_ssl_opts { shift->{ssl_opts} = $_[1] }
60 0     0 0 0 sub set_auth_user { shift->{auth_user} = $_[1] }
61 1     1 0 4 sub set_auth_pass { shift->{auth_pass} = $_[1] }
62 222     222 0 922 sub set_connected { shift->{connected} = $_[1] }
63 0     0 0 0 sub set_server { shift->{server} = $_[1] }
64 74     74 0 949 sub set_server_version { shift->{server_version} = $_[1] }
65 74     74 0 851 sub set_server_protocol { shift->{server_protocol} = $_[1] }
66 141     141 0 667 sub set_message_format { shift->{message_format} = $_[1] }
67 0     0 0 0 sub set_insecure_msg_fmt_ok { shift->{insecure_msg_fmt_ok} = $_[1] }
68              
69             sub get_max_packet_size {
70 1     1 1 15 return Event::RPC::Message->get_max_packet_size;
71             }
72              
73             sub set_max_packet_size {
74 1     1 1 1017 my $class = shift;
75 1         2 my ($value) = @_;
76 1         5 Event::RPC::Message->set_max_packet_size($value);
77             }
78              
79             sub new {
80 83     83 0 67002 my $class = shift;
81 83         1239 my %par = @_;
82             my ($server, $host, $port, $classes, $class_map, $error_cb, $timeout) =
83 83         642 @par{'server','host','port','classes','class_map','error_cb','timeout'};
84             my ($ssl, $ssl_ca_file, $ssl_opts, $auth_user, $auth_pass, $insecure_msg_fmt_ok) =
85 83         705 @par{'ssl','ssl_ca_file','ssl_opts','auth_user','auth_pass','insecure_msg_fmt_ok'};
86              
87 83   50     2916 $server ||= '';
88 83   50     427 $host ||= '';
89 83 100       472 $insecure_msg_fmt_ok = 1 unless defined $insecure_msg_fmt_ok;
90              
91 83 50 33     586 if ( $server ne '' and $host eq '' ) {
92 0         0 warn "Option 'server' is deprecated. Use 'host' instead.";
93 0         0 $host = $server;
94             }
95              
96 83         7612 my $self = bless {
97             host => $server,
98             server => $host,
99             port => $port,
100             timeout => $timeout,
101             classes => $classes,
102             class_map => $class_map,
103             ssl => $ssl,
104             ssl_ca_file => $ssl_ca_file,
105             ssl_opts => $ssl_opts,
106             auth_user => $auth_user,
107             auth_pass => $auth_pass,
108             error_cb => $error_cb,
109             message_format => $Event::RPC::Client::DEFAULT_MESSAGE_FORMAT,
110             insecure_msg_fmt_ok => $insecure_msg_fmt_ok,
111             loaded_classes => {},
112             connected => 0,
113             }, $class;
114              
115 83         861 return $self;
116             }
117              
118             sub connect {
119 84     84 1 692 my $self = shift;
120              
121 84 50       1669 croak "Client is already connected" if $self->get_connected;
122              
123 84         392 my $ssl = $self->get_ssl;
124 84         371 my $server = $self->get_server;
125 84         1391 my $port = $self->get_port;
126 84         588 my $timeout = $self->get_timeout;
127              
128 84         1240 $self->set_message_format($Event::RPC::Client::DEFAULT_MESSAGE_FORMAT);
129              
130             #-- Client may try to fallback to Storable
131 84 100 100     429 Event::RPC::Message::Negotiate->set_storable_fallback_ok(1)
132             if $self->get_message_format eq 'Event::RPC::Message::Negotiate' and
133             $self->get_insecure_msg_fmt_ok;
134              
135 84 50       373 if ( $ssl ) {
136 0         0 eval { require IO::Socket::SSL };
  0         0  
137 0 0       0 croak "SSL requested, but IO::Socket::SSL not installed" if $@;
138             }
139              
140 84         181 my $sock;
141 84 50       503 if ( $ssl ) {
142 0         0 my @verify_opts;
143 0 0 0     0 if ( $self->get_ssl_ca_file or $self->get_ssl_ca_path ) {
144 0         0 push @verify_opts, (
145             SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
146             SSL_ca_file => $self->get_ssl_ca_file,
147             SSL_ca_path => $self->get_ssl_ca_path,
148             );
149             }
150             else {
151 0         0 push @verify_opts, (
152             SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(),
153             );
154             }
155              
156 0         0 my $ssl_opts = $self->get_ssl_opts;
157              
158             $sock = IO::Socket::SSL->new(
159             Proto => 'tcp',
160             PeerPort => $port,
161             PeerAddr => $server,
162             Type => SOCK_STREAM,
163             Timeout => $timeout,
164             @verify_opts,
165 0 0       0 ($ssl_opts?%{$ssl_opts}:()),
  0 0       0  
166             )
167             or croak "Can't open SSL connection to $server:$port: $IO::Socket::SSL::ERROR";
168             }
169             else {
170 84 50       908 $sock = IO::Socket::INET->new(
171             Proto => 'tcp',
172             PeerPort => $port,
173             PeerAddr => $server,
174             Type => SOCK_STREAM,
175             Timeout => $timeout,
176             )
177             or croak "Can't open connection to $server:$port - $!";
178             }
179              
180 84         65852 $sock->autoflush(1);
181              
182 84         4829 $self->set_sock($sock);
183              
184 84         759 eval {
185             #-- Perform message format negotitation if we are not
186             #-- configured to a specific format already.
187 84 100       314 $self->negotiate_message_format
188             if $self->get_message_format eq 'Event::RPC::Message::Negotiate';
189              
190 81         1105 $self->check_version;
191             };
192              
193 84 100       399 if ( $@ ) {
194 10         105 $self->disconnect;
195 10         114 die $@;
196             }
197              
198 74         660 my $auth_user = $self->get_auth_user;
199 74         463 my $auth_pass = $self->get_auth_pass;
200              
201 74 100       338 if ( $auth_user ) {
202 2         16 my $rc = $self->send_request(
203             { cmd => 'auth',
204             user => $auth_user,
205             pass => $auth_pass,
206             }
207             );
208 1 50       8 if ( not $rc->{ok} ) {
209 0         0 $self->disconnect;
210 0         0 croak $rc->{msg};
211             }
212             }
213              
214 73 50       340 if ( not $self->get_classes ) {
215 73         461 $self->load_all_classes;
216             }
217             else {
218 0         0 $self->load_classes;
219             }
220              
221 73         345 $self->set_connected(1);
222              
223 73         450 1;
224             }
225              
226             sub log_connect {
227 166     166 0 56540857 my $class = shift;
228 166         5957 my %par = @_;
229 166         2321 my ( $server, $port ) = @par{ 'server', 'port' };
230              
231 166 100       7047 my $sock = IO::Socket::INET->new(
232             Proto => 'tcp',
233             PeerPort => $port,
234             PeerAddr => $server,
235             Type => SOCK_STREAM
236             )
237             or croak "Can't open connection to $server:$port - $!";
238              
239 83         117970 return $sock;
240             }
241              
242             sub disconnect {
243 149     149 1 17803 my $self = shift;
244              
245 149 50       634 close( $self->get_sock ) if $self->get_sock;
246 149         1189 $self->set_connected(0);
247              
248 149         2458 1;
249             }
250              
251             sub DESTROY {
252 66     66   15392934 shift->disconnect;
253             }
254              
255             sub error {
256 7     7 0 35 my $self = shift;
257 7         42 my ($message) = @_;
258              
259 7         105 my $error_cb = $self->get_error_cb;
260              
261 7 50       63 if ($error_cb) {
262 0         0 &$error_cb( $self, $message );
263             }
264             else {
265 7         77 die "Unhandled error in client/server communication: $message";
266             }
267              
268 0         0 1;
269             }
270              
271             sub negotiate_message_format {
272 60     60 0 188 my $self = shift;
273              
274 60         147 my $rc = eval {
275 60         1125 $self->send_request({
276             cmd => "neg_formats_avail"
277             })
278             };
279              
280 60 100       911 if ( $@ ) {
281             #-- On error we probably may fall back to Storable
282             #-- (we connected to an old server)
283 9 100       60 if ( $self->get_insecure_msg_fmt_ok ) {
284 6         48 require Event::RPC::Message::Storable;
285 6         30 $self->set_message_format("Event::RPC::Message::Storable");
286 6         12 return;
287             }
288              
289             #-- die if Storable is not allowed
290 3         60 die "Error on message format negotiation and client is not ".
291             "allowed to fall back to Storable\n";
292             }
293              
294 51         556 my $modules_by_format_name =
295             Event::RPC::Message::Negotiate->known_message_formats;
296              
297 51         633 my @formats = split(/,/, $rc->{msg});
298              
299 51         303 my $format_chosen = '';
300 51         209 my $module_chosen = '';
301 51         4250 foreach my $format ( @formats ) {
302 51 50       617 my $module = $modules_by_format_name->{$format}
303             or die "Unknown message format '$format";
304              
305 51     17   13509 eval "use $module";
  17         7516  
  17         40  
  17         456  
306              
307 51 50       300 if ( not $@ ) {
308 51         149 $format_chosen = $format;
309 51         176 $module_chosen = $module;
310 51         232 last;
311             };
312             }
313              
314 51 50       208 die "Can't negotiate message format\n" unless $format_chosen;
315              
316 51         131 eval {
317 51         871 $self->send_request({
318             cmd => "neg_format_set",
319             msg => $format_chosen,
320             })
321             };
322              
323 51 50       285 die "Error on neg_format_set: $@" if $@;
324              
325 51         329 $self->set_message_format($module_chosen);
326              
327 51         272 1;
328             }
329              
330             sub check_version {
331 81     81 0 230 my $self = shift;
332              
333 81         274 my $rc = eval { $self->send_request( { cmd => 'version', } ) };
  81         852  
334 81 100       533 die "CATCHED $@" if $@;
335              
336 74         559 $self->set_server_version( $rc->{version} );
337 74         450 $self->set_server_protocol( $rc->{protocol} );
338              
339 74 50       527 if ( $rc->{version} ne $self->get_client_version ) {
340 0         0 warn "Event::RPC warning: server version $rc->{version} != "
341             . "client version "
342             . $self->get_client_version;
343             }
344              
345 74 50       979 if ( $rc->{protocol} < $self->get_client_protocol ) {
346 0         0 die "FATAL: Server protocol version $rc->{protocol} < "
347             . "client protocol version "
348             . $self->get_client_protocol;
349             }
350              
351 74         384 1;
352             }
353              
354             sub load_all_classes {
355 73     73 0 195 my $self = shift;
356              
357 73         1007 my $rc = $self->send_request( { cmd => 'class_info_all', } );
358              
359 73         330 my $class_info_all = $rc->{class_info_all};
360              
361 73         203 foreach my $class ( keys %{$class_info_all} ) {
  73         1192  
362 146         911 $self->load_class( $class, $class_info_all->{$class} );
363             }
364              
365 73         635 1;
366             }
367              
368             sub load_classes {
369 0     0 0 0 my $self = shift;
370              
371 0         0 my $classes = $self->get_classes;
372 0         0 my %classes;
373 0         0 @classes{ @{$classes} } = (1) x @{$classes};
  0         0  
  0         0  
374              
375 0         0 my $rc = $self->send_request( { cmd => 'classes_list', } );
376              
377 0         0 foreach my $class ( @{ $rc->{classes} } ) {
  0         0  
378 0 0       0 next if not $classes{$class};
379 0         0 $classes{$class} = 0;
380              
381 0         0 my $rc = $self->send_request(
382             { cmd => 'class_info',
383             class => $class,
384             }
385             );
386              
387 0         0 $self->load_class( $class, $rc->{methods} );
388             }
389              
390 0         0 foreach my $class ( @{$classes} ) {
  0         0  
391             warn "WARNING: Class '$class' not exported by server"
392 0 0       0 if $classes{$class};
393             }
394              
395 0         0 1;
396             }
397              
398             sub load_class {
399 146     146 0 310 my $self = shift;
400 146         357 my ( $class, $methods ) = @_;
401              
402 146         611 my $loaded_classes = $self->get_loaded_classes;
403 146 50       535 return 1 if $loaded_classes->{$class};
404 146         371 $loaded_classes->{$class} = 1;
405              
406 146         255 my $local_method;
407 146         494 my $class_map = $self->get_class_map;
408 146   33     1491 my $local_class = $class_map->{$class} || $class;
409              
410             # create local destructor for this class
411             {
412 24     24   82805 no strict 'refs';
  24         68  
  24         3588  
  146         276  
413 146         423 my $local_method = $local_class . '::' . "DESTROY";
414             *$local_method = sub {
415 163 100   163   42993 return if not $self->get_connected;
416 34         68 my $oid_ref = shift;
417             $self->send_request({
418             cmd => "client_destroy",
419 34         68 oid => ${$oid_ref},
  34         150  
420             });
421 146         3775 };
422             }
423              
424             # create local methods for this class
425 146         314 foreach my $method ( keys %{$methods} ) {
  146         995  
426 1460         3718 $local_method = $local_class . '::' . $method;
427              
428 1460         3051 my $method_type = $methods->{$method};
429              
430 1460 100       4943 if ( $method_type eq '_constructor' ) {
    100          
431             # this is a constructor for this class
432 219         739 my $request_method = $class . '::' . $method;
433 24     24   462 no strict 'refs';
  24         47  
  24         2854  
434             *$local_method = sub {
435 38     38   4053 shift;
436 38         687 my $rc = $self->send_request({
437             cmd => 'new',
438             method => $request_method,
439             params => \@_,
440             });
441 38         144 my $oid = $rc->{oid};
442 38         187 return bless \$oid, $local_class;
443 219         2572 };
444             }
445             elsif ( $method_type eq '1' ) {
446             # this is a simple method
447 803         1457 my $request_method = $method;
448 24     24   123 no strict 'refs';
  24         46  
  24         3050  
449             *$local_method = sub {
450 249     249   31158 my $oid_ref = shift;
451             my $rc = $self->send_request({
452             cmd => 'exec',
453 249         362 oid => ${$oid_ref},
  249         2096  
454             method => $request_method,
455             params => \@_,
456             });
457 248 50       1016 return unless $rc;
458 248         370 $rc = $rc->{rc};
459 248 100       638 return @{$rc} if wantarray;
  1         5  
460 247         3450 return $rc->[0];
461 803         9862 };
462             }
463             else {
464             # this is a object returner
465 438         836 my $request_method = $method;
466 24     24   118 no strict 'refs';
  24         31  
  24         13980  
467             *$local_method = sub {
468 71     71   956 my $oid_ref = shift;
469             my $rc = $self->send_request({
470             cmd => 'exec',
471 71         134 oid => ${$oid_ref},
  71         540  
472             method => $request_method,
473             params => \@_,
474             });
475 71 50       290 return unless $rc;
476 71         131 $rc = $rc->{rc};
477              
478 71         143 foreach my $val ( @{$rc} ) {
  71         146  
479 72 100       369 if ( ref $val eq 'ARRAY' ) {
    100          
    100          
480 1         2 foreach my $list_elem ( @{$val} ) {
  1         3  
481 10         21 my ($class) = split( "=", "$list_elem", 2 );
482             $self->load_class($class)
483 10 50       23 unless $loaded_classes->{$class};
484 10         9 my $list_elem_copy = $list_elem;
485 10         18 $list_elem = \$list_elem_copy;
486             bless $list_elem,
487 10   33     40 ( $class_map->{$class} || $class );
488             }
489             }
490             elsif ( ref $val eq 'HASH' ) {
491 1         2 foreach my $hash_elem ( values %{$val} ) {
  1         4  
492 10         16 my ($class) = split( "=", "$hash_elem", 2 );
493             $self->load_class($class)
494 10 50       23 unless $loaded_classes->{$class};
495 10         11 my $hash_elem_copy = $hash_elem;
496 10         15 $hash_elem = \$hash_elem_copy;
497             bless $hash_elem,
498 10   33     50 ( $class_map->{$class} || $class );
499             }
500             }
501             elsif ( defined $val ) {
502 69         294 my ($class) = split( "=", "$val", 2 );
503             $self->load_class($class)
504 69 50       234 unless $loaded_classes->{$class};
505 69         128 my $val_copy = $val;
506 69         83 $val = \$val_copy;
507 69   33     699 bless $val, ( $class_map->{$class} || $class );
508             }
509             }
510 71 100       192 return @{$rc} if wantarray;
  1         4  
511 70         279 return $rc->[0];
512 438         8644 };
513             }
514             }
515              
516 146         678 return $local_class;
517             }
518              
519             sub send_request {
520 659     659 0 1127 my $self = shift;
521 659         1299 my ($request) = @_;
522              
523 659         1966 my $message = $self->get_message_format->new( $self->get_sock );
524              
525 659         3233 $message->write_blocked($request);
526              
527 659         1090 my $rc = eval { $message->read_blocked };
  659         3080  
528              
529 659 100       5244 if ($@) {
530 7         182 $self->error($@);
531 0         0 return;
532             }
533              
534 652 100       1741 if ( not $rc->{ok} ) {
535 11 100       152 $rc->{msg} .= "\n" if not $rc->{msg} =~ /\n$/;
536 11         3998 croak ("$rc->{msg} -- called via Event::RPC::Client");
537             }
538              
539 641         3892 return $rc;
540             }
541              
542             1;
543              
544             __END__