File Coverage

blib/lib/Event/RPC/Client.pm
Criterion Covered Total %
statement 27 247 10.9
branch 0 72 0.0
condition 0 22 0.0
subroutine 9 64 14.0
pod 8 50 16.0
total 44 455 9.6


line stmt bran cond sub pod time code
1              
2             #-----------------------------------------------------------------------
3             # Copyright (C) 2002-2006 Jörn Reder .
4             # All Rights Reserved. See file COPYRIGHT for details.
5             #
6             # This module is part of Event::RPC, which is free software; you can
7             # redistribute it and/or modify it under the same terms as Perl itself.
8             #-----------------------------------------------------------------------
9              
10             package Event::RPC::Client;
11              
12 1     1   3205 use Event::RPC;
  1         4  
  1         49  
13 1     1   9 use Event::RPC::Message;
  1         3  
  1         35  
14              
15 1     1   8 use Carp;
  1         5  
  1         107  
16 1     1   11 use strict;
  1         4  
  1         57  
17 1     1   12 use IO::Socket::INET;
  1         4  
  1         55  
18              
19 0     0 1   sub get_client_version { $Event::RPC::VERSION }
20 0     0 1   sub get_client_protocol { $Event::RPC::PROTOCOL }
21              
22 0     0 0   sub get_host { shift->{host} }
23 0     0 0   sub get_port { shift->{port} }
24 0     0 0   sub get_sock { shift->{sock} }
25 0     0 0   sub get_timeout { shift->{timeout} }
26 0     0 0   sub get_classes { shift->{classes} }
27 0     0 0   sub get_class_map { shift->{class_map} }
28 0     0 0   sub get_loaded_classes { shift->{loaded_classes} }
29 0     0 0   sub get_error_cb { shift->{error_cb} }
30 0     0 0   sub get_ssl { shift->{ssl} }
31 0     0 0   sub get_ssl_ca_file { shift->{ssl_ca_file} }
32 0     0 0   sub get_ssl_ca_path { shift->{ssl_ca_path} }
33 0     0 0   sub get_ssl_opts { shift->{ssl_opts} }
34 0     0 0   sub get_auth_user { shift->{auth_user} }
35 0     0 0   sub get_auth_pass { shift->{auth_pass} }
36 0     0 0   sub get_connected { shift->{connected} }
37 0     0 0   sub get_server { shift->{server} }
38 0     0 1   sub get_server_version { shift->{server_version} }
39 0     0 1   sub get_server_protocol { shift->{server_protocol} }
40              
41 0     0 0   sub set_host { shift->{host} = $_[1] }
42 0     0 0   sub set_port { shift->{port} = $_[1] }
43 0     0 0   sub set_sock { shift->{sock} = $_[1] }
44 0     0 0   sub set_timeout { shift->{timeout} = $_[1] }
45 0     0 0   sub set_classes { shift->{classes} = $_[1] }
46 0     0 0   sub set_class_map { shift->{class_map} = $_[1] }
47 0     0 0   sub set_loaded_classes { shift->{loaded_classes} = $_[1] }
48 0     0 0   sub set_error_cb { shift->{error_cb} = $_[1] }
49 0     0 0   sub set_ssl { shift->{ssl} = $_[1] }
50 0     0 0   sub set_ssl_ca_file { shift->{ssl_ca_file} = $_[1] }
51 0     0 0   sub set_ssl_ca_path { shift->{ssl_ca_path} = $_[1] }
52 0     0 0   sub set_ssl_opts { shift->{ssl_opts} = $_[1] }
53 0     0 0   sub set_auth_user { shift->{auth_user} = $_[1] }
54 0     0 0   sub set_auth_pass { shift->{auth_pass} = $_[1] }
55 0     0 0   sub set_connected { shift->{connected} = $_[1] }
56 0     0 0   sub set_server { shift->{server} = $_[1] }
57 0     0 0   sub set_server_version { shift->{server_version} = $_[1] }
58 0     0 0   sub set_server_protocol { shift->{server_protocol} = $_[1] }
59              
60             sub get_max_packet_size {
61 0     0 1   return Event::RPC::Message->get_max_packet_size;
62             }
63              
64             sub set_max_packet_size {
65 0     0 1   my $class = shift;
66 0           my ($value) = @_;
67 0           Event::RPC::Message->set_max_packet_size($value);
68             }
69              
70             sub new {
71 0     0 0   my $class = shift;
72 0           my %par = @_;
73             my ($server, $host, $port, $classes, $class_map, $error_cb, $timeout) =
74 0           @par{'server','host','port','classes','class_map','error_cb','timeout'};
75             my ($ssl, $ssl_ca_file, $ssl_opts, $auth_user, $auth_pass) =
76 0           @par{'ssl','ssl_ca_file','ssl_opts','auth_user','auth_pass'};
77              
78 0   0       $server ||= '';
79 0   0       $host ||= '';
80              
81 0 0 0       if ( $server ne '' and $host eq '' ) {
82 0           warn "Option 'server' is deprecated. Use 'host' instead.";
83 0           $host = $server;
84             }
85              
86 0           my $self = bless {
87             host => $server,
88             server => $host,
89             port => $port,
90             timeout => $timeout,
91             classes => $classes,
92             class_map => $class_map,
93             ssl => $ssl,
94             ssl_ca_file => $ssl_ca_file,
95             ssl_opts => $ssl_opts,
96             auth_user => $auth_user,
97             auth_pass => $auth_pass,
98             error_cb => $error_cb,
99             loaded_classes => {},
100             connected => 0,
101             }, $class;
102              
103 0           return $self;
104             }
105              
106             sub connect {
107 0     0 1   my $self = shift;
108              
109 0 0         croak "Client is already connected" if $self->get_connected;
110              
111 0           my $ssl = $self->get_ssl;
112 0           my $server = $self->get_server;
113 0           my $port = $self->get_port;
114 0           my $timeout = $self->get_timeout;
115              
116 0 0         if ( $ssl ) {
117 0           eval { require IO::Socket::SSL };
  0            
118 0 0         croak "SSL requested, but IO::Socket::SSL not installed" if $@;
119             }
120              
121 0           my $sock;
122 0 0         if ( $ssl ) {
123 0           my @verify_opts;
124 0 0 0       if ( $self->get_ssl_ca_file or $self->get_ssl_ca_path ) {
125 0           push @verify_opts, (
126             SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
127             SSL_ca_file => $self->get_ssl_ca_file,
128             SSL_ca_path => $self->get_ssl_ca_path,
129             );
130             }
131             else {
132 0           push @verify_opts, (
133             SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(),
134             );
135             }
136              
137 0           my $ssl_opts = $self->get_ssl_opts;
138              
139             $sock = IO::Socket::SSL->new(
140             Proto => 'tcp',
141             PeerPort => $port,
142             PeerAddr => $server,
143             Type => SOCK_STREAM,
144             Timeout => $timeout,
145             @verify_opts,
146 0 0         ($ssl_opts?%{$ssl_opts}:()),
  0 0          
147             )
148             or croak "Can't open SSL connection to $server:$port: $IO::Socket::SSL::ERROR";
149             }
150             else {
151 0 0         $sock = IO::Socket::INET->new(
152             Proto => 'tcp',
153             PeerPort => $port,
154             PeerAddr => $server,
155             Type => SOCK_STREAM,
156             Timeout => $timeout,
157             )
158             or croak "Can't open connection to $server:$port - $!";
159             }
160              
161 0           $sock->autoflush(1);
162              
163 0           $self->set_sock($sock);
164              
165 0           $self->check_version;
166              
167 0           my $auth_user = $self->get_auth_user;
168 0           my $auth_pass = $self->get_auth_pass;
169              
170 0 0         if ( $auth_user ) {
171 0           my $rc = $self->send_request(
172             { cmd => 'auth',
173             user => $auth_user,
174             pass => $auth_pass,
175             }
176             );
177 0 0         if ( not $rc->{ok} ) {
178 0           $self->disconnect;
179 0           croak $rc->{msg};
180             }
181             }
182              
183 0 0         if ( not $self->get_classes ) {
184 0           $self->load_all_classes;
185             }
186             else {
187 0           $self->load_classes;
188             }
189              
190 0           $self->set_connected(1);
191              
192 0           1;
193             }
194              
195             sub log_connect {
196 0     0 0   my $class = shift;
197 0           my %par = @_;
198 0           my ( $server, $port ) = @par{ 'server', 'port' };
199              
200 0 0         my $sock = IO::Socket::INET->new(
201             Proto => 'tcp',
202             PeerPort => $port,
203             PeerAddr => $server,
204             Type => SOCK_STREAM
205             )
206             or croak "Can't open connection to $server:$port - $!";
207              
208 0           return $sock;
209             }
210              
211             sub disconnect {
212 0     0 1   my $self = shift;
213              
214 0 0         close( $self->get_sock ) if $self->get_sock;
215 0           $self->set_connected(0);
216              
217 0           1;
218             }
219              
220             sub DESTROY {
221 0     0     shift->disconnect;
222             }
223              
224             sub error {
225 0     0 0   my $self = shift;
226 0           my ($message) = @_;
227              
228 0           my $error_cb = $self->get_error_cb;
229              
230 0 0         if ($error_cb) {
231 0           &$error_cb( $self, $message );
232             }
233             else {
234 0           die "Unhandled error in client/server communication: $message";
235             }
236              
237 0           1;
238             }
239              
240             sub check_version {
241 0     0 0   my $self = shift;
242              
243 0           my $rc = $self->send_request( { cmd => 'version', } );
244              
245 0           $self->set_server_version( $rc->{version} );
246 0           $self->set_server_protocol( $rc->{protocol} );
247              
248 0 0         if ( $rc->{version} ne $self->get_client_version ) {
249 0           warn "Event::RPC warning: server version $rc->{version} != "
250             . "client version "
251             . $self->get_client_version;
252             }
253              
254 0 0         if ( $rc->{protocol} < $self->get_client_protocol ) {
255 0           die "FATAL: Server protocol version $rc->{protocol} < "
256             . "client protocol version "
257             . $self->get_client_protocol;
258             }
259              
260 0           1;
261             }
262              
263             sub load_all_classes {
264 0     0 0   my $self = shift;
265              
266 0           my $rc = $self->send_request( { cmd => 'class_info_all', } );
267              
268 0           my $class_info_all = $rc->{class_info_all};
269              
270 0           foreach my $class ( keys %{$class_info_all} ) {
  0            
271 0           $self->load_class( $class, $class_info_all->{$class} );
272             }
273              
274 0           1;
275             }
276              
277             sub load_classes {
278 0     0 0   my $self = shift;
279              
280 0           my $classes = $self->get_classes;
281 0           my %classes;
282 0           @classes{ @{$classes} } = (1) x @{$classes};
  0            
  0            
283              
284 0           my $rc = $self->send_request( { cmd => 'classes_list', } );
285              
286 0           foreach my $class ( @{ $rc->{classes} } ) {
  0            
287 0 0         next if not $classes{$class};
288 0           $classes{$class} = 0;
289              
290 0           my $rc = $self->send_request(
291             { cmd => 'class_info',
292             class => $class,
293             }
294             );
295              
296 0           $self->load_class( $class, $rc->{methods} );
297             }
298              
299 0           foreach my $class ( @{$classes} ) {
  0            
300             warn "WARNING: Class '$class' not exported by server"
301 0 0         if $classes{$class};
302             }
303              
304 0           1;
305             }
306              
307             sub load_class {
308 0     0 0   my $self = shift;
309 0           my ( $class, $methods ) = @_;
310              
311 0           my $loaded_classes = $self->get_loaded_classes;
312 0 0         return 1 if $loaded_classes->{$class};
313 0           $loaded_classes->{$class} = 1;
314              
315 0           my $local_method;
316 0           my $class_map = $self->get_class_map;
317 0   0       my $local_class = $class_map->{$class} || $class;
318              
319             # create local destructor for this class
320             {
321 1     1   4438 no strict 'refs';
  1         12  
  1         160  
  0            
322 0           my $local_method = $local_class . '::' . "DESTROY";
323             *$local_method = sub {
324 0 0   0     return if not $self->get_connected;
325 0           my $oid_ref = shift;
326             $self->send_request({
327             cmd => "client_destroy",
328 0           oid => ${$oid_ref},
  0            
329             });
330 0           };
331             }
332              
333             # create local methods for this class
334 0           foreach my $method ( keys %{$methods} ) {
  0            
335 0           $local_method = $local_class . '::' . $method;
336              
337 0           my $method_type = $methods->{$method};
338              
339 0 0         if ( $method_type eq '_constructor' ) {
    0          
340             # this is a constructor for this class
341 0           my $request_method = $class . '::' . $method;
342 1     1   4 no strict 'refs';
  1         2  
  1         95  
343             *$local_method = sub {
344 0     0     shift;
345 0           my $rc = $self->send_request({
346             cmd => 'new',
347             method => $request_method,
348             params => \@_,
349             });
350 0           my $oid = $rc->{oid};
351 0           return bless \$oid, $local_class;
352 0           };
353             }
354             elsif ( $method_type eq '1' ) {
355             # this is a simple method
356 0           my $request_method = $method;
357 1     1   4 no strict 'refs';
  1         2  
  1         112  
358             *$local_method = sub {
359 0     0     my $oid_ref = shift;
360             my $rc = $self->send_request({
361             cmd => 'exec',
362 0           oid => ${$oid_ref},
  0            
363             method => $request_method,
364             params => \@_,
365             });
366 0 0         return unless $rc;
367 0           $rc = $rc->{rc};
368 0 0         return @{$rc} if wantarray;
  0            
369 0           return $rc->[0];
370 0           };
371             }
372             else {
373             # this is a object returner
374 0           my $request_method = $method;
375 1     1   5 no strict 'refs';
  1         2  
  1         786  
376             *$local_method = sub {
377 0     0     my $oid_ref = shift;
378             my $rc = $self->send_request({
379             cmd => 'exec',
380 0           oid => ${$oid_ref},
  0            
381             method => $request_method,
382             params => \@_,
383             });
384 0 0         return unless $rc;
385 0           $rc = $rc->{rc};
386              
387 0           foreach my $val ( @{$rc} ) {
  0            
388 0 0         if ( ref $val eq 'ARRAY' ) {
    0          
    0          
389 0           foreach my $list_elem ( @{$val} ) {
  0            
390 0           my ($class) = split( "=", "$list_elem", 2 );
391             $self->load_class($class)
392 0 0         unless $loaded_classes->{$class};
393 0           my $list_elem_copy = $list_elem;
394 0           $list_elem = \$list_elem_copy;
395             bless $list_elem,
396 0   0       ( $class_map->{$class} || $class );
397             }
398             }
399             elsif ( ref $val eq 'HASH' ) {
400 0           foreach my $hash_elem ( values %{$val} ) {
  0            
401 0           my ($class) = split( "=", "$hash_elem", 2 );
402             $self->load_class($class)
403 0 0         unless $loaded_classes->{$class};
404 0           my $hash_elem_copy = $hash_elem;
405 0           $hash_elem = \$hash_elem_copy;
406             bless $hash_elem,
407 0   0       ( $class_map->{$class} || $class );
408             }
409             }
410             elsif ( defined $val ) {
411 0           my ($class) = split( "=", "$val", 2 );
412             $self->load_class($class)
413 0 0         unless $loaded_classes->{$class};
414 0           my $val_copy = $val;
415 0           $val = \$val_copy;
416 0   0       bless $val, ( $class_map->{$class} || $class );
417             }
418             }
419 0 0         return @{$rc} if wantarray;
  0            
420 0           return $rc->[0];
421 0           };
422             }
423             }
424              
425 0           return $local_class;
426             }
427              
428             sub send_request {
429 0     0 0   my $self = shift;
430 0           my ($request) = @_;
431              
432 0           my $message = Event::RPC::Message->new( $self->get_sock );
433              
434 0           $message->write_blocked($request);
435              
436 0           my $rc = eval { $message->read_blocked };
  0            
437              
438 0 0         if ($@) {
439 0           $self->error($@);
440 0           return;
441             }
442              
443 0 0         if ( not $rc->{ok} ) {
444 0 0         $rc->{msg} .= "\n" if not $rc->{msg} =~ /\n$/;
445 0           croak ("$rc->{msg} -- called via Event::RPC::Client");
446             }
447              
448 0           return $rc;
449             }
450              
451             1;
452              
453             __END__