File Coverage

blib/lib/RPC/pClient.pm
Criterion Covered Total %
statement 100 153 65.3
branch 32 72 44.4
condition 5 12 41.6
subroutine 15 16 93.7
pod 4 5 80.0
total 156 258 60.4


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             #
4             # pRPC - Perl RPC, package for writing simple, RPC like clients and
5             # servers
6             #
7             # RPC::pClient.pm is the module for writing the pRPC client.
8             #
9             #
10             # Copyright (c) 1997 Jochen Wiedmann
11             #
12             # You may distribute under the terms of either the GNU General Public
13             # License or the Artistic License, as specified in the Perl README file.
14             #
15             # Author: Jochen Wiedmann
16             # Am Eisteich 9
17             # 72555 Metzingen
18             # Germany
19             #
20             # Email: wiedmann@neckar-alb.de
21             # Phone: +49 7123 14881
22             #
23             #
24             # $Id: pClient.pm,v 0.1001 1997/09/14 22:53:27 joe Exp $
25             #
26             package RPC::pClient;
27              
28 7     7   6983 use strict;
  7         13  
  7         197  
29 7     7   35 use Carp;
  7         10  
  7         420  
30 7     7   27 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
  7         17  
  7         1590  
31              
32             require Exporter;
33             require DynaLoader;
34              
35             @ISA = qw(Exporter DynaLoader);
36             # Items to export into callers namespace by default. Note: do not export
37             # names by default without a very good reason. Use EXPORT_OK instead.
38             # Do not simply export all your public functions/methods/constants.
39             @EXPORT = qw(
40            
41             );
42             $VERSION = '0.1002';
43              
44 7     7   9966 use POSIX();
  7         82983  
  7         188  
45 7     7   8905 use Sys::Syslog();
  7         122217  
  7         179  
46 7     7   6384 use IO::Socket();
  7         139382  
  7         159  
47 7     7   10124 use Storable();
  7         31398  
  7         183  
48 7     7   63 use Socket();
  7         18  
  7         10807  
49              
50              
51 52     52 0 135 sub error ($) { my $self = shift; $self->{'error'}; }
  52         173  
52              
53              
54             ############################################################################
55             #
56             # Name: new
57             #
58             # Purpose: Constructor of the pRPC::Client module
59             #
60             # Inputs: Hash list of attributes; see pRPC::Client(3)
61             #
62             # Returns: connection object or error message
63             #
64             ############################################################################
65              
66             sub new ($@) {
67 2     2 1 10019059 my ($proto) = shift;
68 2   33     78 my ($class) = ref($proto) || $proto;
69 2         220 my ($self) = {@_};
70              
71 2         16 bless($self, $class);
72              
73 2 50 33     155 if (!defined($self->{'application'}) || !defined($self->{'version'})) {
74 0         0 return "Required attributes 'application' or 'version' missing.";
75             }
76              
77             #
78             # Create Storable objects and send the login message.
79             #
80 2 50       227 if ($self->_HaveOoStorable) {
81 0         0 $self->{'io'} = Storable->new('file' => *{$self->{'sock'}}{IO},
  0         0  
82             'crypt' => $self->{'cipher'},
83             'netorder' => 1,
84             'forgive_me' => 1);
85 0 0       0 if (!defined($self->{'io'})) {
86 0         0 return "Cannot create Storable object: $!";
87             }
88             } else {
89 2         20 $self->{'file'} = $self->{'sock'};
90             }
91              
92 2 50       16 if ($self->{'debug'}) {
93 2         50 Sys::Syslog::syslog('debug', "Sending login message: %s %s %s",
94             $self->{'application'}, $self->{'version'},
95             $self->{'user'});
96             }
97 2 50       1266 if (!$self->_Store([$self->{'application'},
98             $self->{'version'},
99             $self->{'user'},
100             $self->{'password'}])) {
101 0         0 return "Cannot send login message: " . $self->{'error'};
102             }
103            
104 2 50       21 if ($self->{'debug'}) {
105 2         13 Sys::Syslog::syslog('debug', "Waiting for server's response ...");
106             }
107 2         292 my ($msg) = $self->_Retrieve();
108 2 50       10 if (!$msg) {
109 0         0 $msg = "Error while reading server reply: " . $self->{'error'};
110 0         0 Sys::Syslog::syslog('debug', $msg);
111 0         0 return $msg;
112             }
113 2 50       10 if (ref($msg) ne 'ARRAY') {
114 0         0 $msg = "Error while reading server reply: Expected array";
115 0         0 Sys::Syslog::syslog('debug', $msg);
116 0         0 return $msg;
117             }
118              
119 2 50       15 if (!$$msg[0]) {
120 0 0       0 $msg = "Refused by server: "
121             . (defined($$msg[1]) ? $$msg[1] : "No cause");
122 0         0 Sys::Syslog::syslog('debug', $msg);
123 0         0 return $msg;
124             }
125              
126 2 50       17 Sys::Syslog::syslog('debug', "Logged in, server replies %s",
127             defined($$msg[1]) ? $$msg[1] : "undef");
128 2         344 $self->{'error'} = '';
129 2         19 $self;
130             }
131              
132              
133             ############################################################################
134             #
135             # Name: Call, CallInt
136             #
137             # Purpose: coerce method located on the server
138             #
139             # Inputs: $con - connection attributes
140             # $method - method name
141             # @args - method attributes
142             #
143             # Returns: method results; you *must* check $con->error for potential
144             # error conditions
145             #
146             ############################################################################
147              
148             sub CallInt ($@) {
149 24     24 1 35 my($self) = shift;
150 24         31 my($error, $msg, @result);
151              
152 24 50       324 if (!$self->_Store([@_])) {
153 0         0 $error = $self->{'error'};
154             } else {
155 24         60 $msg = $self->_Retrieve();
156 24 50 66     235 if (!$msg) {
    50          
    100          
157 0         0 $error = $self->{'error'};
158             } elsif (ref($msg) ne 'ARRAY') {
159 0         0 $error = "Error while reading server reply: Expected array";
160             } elsif (!defined($$msg[0]) || !$$msg[0]) {
161 4 50 33     43 if (defined($$msg[1]) && $$msg[1] ne '') {
162 4         12 $error = $$msg[1];
163             } else {
164 0         0 $error = "No error message";
165             }
166             } else {
167 20         33 $error = '';
168 20         61 @result = @$msg;
169             }
170             }
171              
172 24 100       99 if ($self->{'error'} = $error) {
173 4         14 @result = (0, $error);
174             }
175              
176 24 50       62 if ($self->{'debug'}) {
177 24 100       72 if ($self->error) {
178 4         13 Sys::Syslog::syslog('err', "Calling method %s -> error %s",
179             $_[0], $self->error);
180             } else {
181 20         95 Sys::Syslog::syslog('debug', "Calling method %s -> ok",
182             $_[0]);
183             }
184             }
185              
186 24         4907 @result;
187             }
188              
189             sub Call ($@) {
190 24     24 1 6363 my($self) = shift;
191 24         70 my(@result) = $self->CallInt(@_);
192              
193 24 100       99 if (!shift @result) {
194 4         9 @result = ();
195             }
196              
197 24         88 @result;
198             }
199              
200              
201             ############################################################################
202             #
203             # Name: Encrypt
204             #
205             # Purpose: Get or set the current encryption mode
206             #
207             # Inputs: $self - client object
208             # $crypt - encryption object
209             #
210             # Returns: current encryption object; 'undef' for no encryption
211             #
212             ############################################################################
213              
214             sub Encrypt ($;$) {
215 0     0 1 0 my ($self, $crypt) = @_;
216 0 0       0 if (@_ == 2) {
217 0 0       0 if ($self->_HaveOoStorable) {
218 0         0 $self->{'io'}->{'crypt'} = $crypt;
219             } else {
220 0         0 $self->{'cipher'} = $crypt;
221             }
222             }
223 0 0       0 $self->_HaveOoStorable ? $self->{'io'}->{'crypt'} : $self->{'cipher'};
224             }
225              
226              
227             ############################################################################
228             #
229             # Name: _Store, _Retrieve
230             #
231             # Purpose: Preliminary replacements for Storable->Store and
232             # Storable->Retrieve as long as Raphael hasn't integrated
233             # my suggestion for an OO API.
234             #
235             # Inputs: $self - server object
236             # $msg - message being sent (_Store only)
237             #
238             # Returns: _Retrieve returns a message in case of success. Both
239             # methods return FALSE in case of error, $self->{'error'}
240             # will be set in that case.
241             #
242             ############################################################################
243              
244             $RPC::pClient::haveOoStorable = undef;
245             sub _HaveOoStorable () {
246 108 100   108   263 if (!defined($RPC::pClient::haveOoStorable)) {
247 2         12 $@ = '';
248 2         729 eval "Storable->new()";
249 2 50       34 $RPC::pClient::haveOoStorable = $@ ? 0 : 1;
250             }
251 108         285 $RPC::pClient::haveOoStorable;
252             }
253              
254             sub _Retrieve($) {
255 52     52   83 my($self) = @_;
256 52         73 my($result);
257              
258 52 50       108 if ($self->_HaveOoStorable) {
259 0 0       0 if (!($result = $self->{'io'}->Retrieve())) {
260 0         0 $self->{'error'} = $self->{'io'}->errstr;
261             }
262 0         0 return $result;
263             }
264              
265 52         87 my($encodedSize, $readSize, $blockSize);
266 52         72 $readSize = 4;
267 52         92 $encodedSize = '';
268 52         127 while ($readSize > 0) {
269 52         276 my $result = $self->{'file'}->read($encodedSize, $readSize,
270             length($encodedSize));
271 52 50       33094 if ($result < 0) {
272 0         0 $self->{'error'} = "Error while reading: $!";
273 0         0 return undef;
274             }
275 52         168 $readSize -= $result;
276             }
277 52         197 $encodedSize = unpack("N", $encodedSize);
278 52         68 $readSize = $encodedSize;
279 52 50       151 if ($self->{'cipher'}) {
280 0         0 $blockSize = $self->{'cipher'}->blocksize;
281 0 0       0 if (my $addSize = ($encodedSize % $blockSize)) {
282 0         0 $readSize += ($blockSize - $addSize);
283             }
284             }
285 52         90 my $msg = '';
286 52         68 my $rs = $readSize;
287 52         291 while ($rs > 0) {
288 52         418 my $result = read($self->{'file'}, $msg, $rs, length($msg));
289 52 50       259 if ($result < 0) {
290 0         0 $self->{'error'} = "Error while reading: $!";
291 0         0 return undef;
292             }
293 52         132 $rs -= $result;
294             }
295 52 50       121 if ($self->{'cipher'}) {
296 0         0 my $cipher = $self->{'cipher'};
297 0         0 my $encodedMsg = $msg;
298 0         0 $msg = '';
299 0         0 for (my $i = 0; $i < $readSize; $i += $blockSize) {
300 0         0 $msg .= $cipher->decrypt(substr($encodedMsg, $i, $blockSize));
301             }
302 0         0 $msg = substr($msg, 0, $encodedSize);
303             }
304 52         212 my $ref = Storable::thaw($msg);
305 52         2336 $ref;
306             }
307             sub _Store($$) {
308 52     52   85 my($self, $msg) = @_;
309              
310 52 50       193 if ($self->_HaveOoStorable) {
311 0 0       0 if (!$self->{'io'}->Store($msg)) {
312 0         0 $self->{'error'} = $self->{'io'}->errstr;
313 0         0 return undef;
314             }
315 0         0 return 1;
316             }
317              
318 52         364 my($encodedMsg) = Storable::nfreeze($msg);
319 52         4304 my($encodedSize) = length($encodedMsg);
320 52 50       148 if ($self->{'cipher'}) {
321 0         0 my $cipher = $self->{'cipher'};
322 0         0 my $size = $cipher->blocksize;
323 0 0       0 if (my $addSize = length($encodedMsg) % $size) {
324 0         0 $encodedMsg .= chr(0) x ($size - $addSize);
325             }
326 0         0 $msg = $encodedMsg;
327 0         0 $encodedMsg = '';
328 0         0 for (my $i = 0; $i < length($msg); $i += $size) {
329 0         0 $encodedMsg .= $cipher->encrypt(substr($msg, $i, $size));
330             }
331             }
332 52         690 $self->{'file'}->print(pack("N", $encodedSize) . $encodedMsg);
333 52         3482 $self->{'file'}->flush();
334             }
335              
336              
337             # Autoload methods go after =cut, and are processed by the autosplit program.
338              
339             1;
340             __END__