File Coverage

blib/lib/Ace/SocketServer.pm
Criterion Covered Total %
statement 135 162 83.3
branch 23 48 47.9
condition 11 23 47.8
subroutine 29 34 85.3
pod 0 8 0.0
total 198 275 72.0


line stmt bran cond sub pod time code
1             package Ace::SocketServer;
2              
3             require 5.004;
4 4     4   61 use strict;
  4         55  
  4         66  
5 4     4   102 use Carp 'croak','cluck';
  4         36  
  4         105  
6 4     4   103 use Ace qw(rearrange STATUS_WAITING STATUS_PENDING STATUS_ERROR);
  4         38  
  4         66  
7 4     4   168 use IO::Socket;
  4         41  
  4         55  
8 4     4   96 use Digest::MD5 'md5_hex';
  4         38  
  4         105  
9              
10 4     4   65 use vars '$VERSION';
  4         37  
  4         62  
11             $VERSION = '1.01';
12              
13 4     4   61 use constant DEFAULT_USER => 'anonymous'; # anonymous user
  4         38  
  4         59  
14 4     4   70 use constant DEFAULT_PASS => 'guest'; # anonymous password
  4         38  
  4         51  
15 4     4   62 use constant DEFAULT_TIMEOUT => 120; # two minute timeout on queries
  4         36  
  4         47  
16              
17             # header information
18 4     4   61 use constant HEADER => 'L5a30';
  4         36  
  4         78  
19 4     4   94 use constant HEADER_LEN => 5*4+30;
  4         37  
  4         48  
20 4     4   91 use constant ACESERV_MSGREQ => "ACESERV_MSGREQ";
  4         37  
  4         82  
21 4     4   125 use constant ACESERV_MSGDATA => "ACESERV_MSGDATA";
  4         39  
  4         85  
22 4     4   63 use constant WORDORDER_MAGIC => 0x12345678;
  4         35  
  4         50  
23              
24             # Server only, it may just be sending or a reply or it may be sending an
25             # instruction, such as "operation refused".
26 4     4   59 use constant ACESERV_MSGOK => "ACESERV_MSGOK";
  4         37  
  4         51  
27 4     4   91 use constant ACESERV_MSGENCORE => "ACESERV_MSGENCORE";
  4         67  
  4         52  
28 4     4   108 use constant ACESERV_MSGFAIL => "ACESERV_MSGFAIL";
  4         36  
  4         49  
29 4     4   61 use constant ACESERV_MSGKILL => "ACESERV_MSGKILL";
  4         203  
  4         94  
30              
31 4     4   66 use constant ACESERV_CLIENT_HELLO => "bonjour";
  4         70  
  4         94  
32 4     4   60 use constant ACESERV_SERVER_HELLO => "et bonjour a vous";
  4         35  
  4         50  
33              
34             sub connect {
35 4     4 0 83   my $class = shift;
36 4         70   my ($host,$port,$timeout,$user,$pass) = rearrange(['HOST','PORT','TIMEOUT','USER','PASS'],@_);
37 4   50     108   $user ||= DEFAULT_USER;
38 4   50     55   $pass ||= DEFAULT_PASS;
39 4   50     45   $timeout ||= DEFAULT_TIMEOUT;
40 4   33     74   my $s = IO::Socket::INET->new("$host:$port") ||
41                 return _error("Couldn't establish connection");
42 4         159826   my $self = bless { socket => $s,
43             client_id => 0, # client ID provided by server
44             timeout   => $timeout,
45             },$class;
46 4 50       65   return unless $self->_handshake($user,$pass);
47 4         54   $self->{status} = STATUS_WAITING;
48 4         43   $self->{encoring} = 0;
49 4         64   return $self;
50             }
51              
52             sub DESTROY {
53 1     1   21   my $self = shift;
54 1 50       16   return if $self->{last_msg} eq ACESERV_MSGKILL;
55 1         14   $self->_send_msg('quit');
56             # Is _recv_msg() bringing things down in flames? Maybe!
57 1         15   my ($msg,$body) = $self->_recv_msg('strip');
58 1 50 33     25   warn "Did not get expected ACESERV_MSGKILL message, got $msg instead"
59                 if defined($msg) and $msg ne ACESERV_MSGKILL;
60             }
61              
62 79     79 0 931 sub encore { return shift->{encoring} }
63              
64 240     240 0 4816 sub status { shift->{status} }
65              
66 0     0 0 0 sub error { $Ace::Error; }
67              
68             sub query {
69 79     79 0 1055   my $self = shift;
70 79         751   my ($request,$parse) = @_;
71 79 50       1206   warn "query($request)" if Ace->debug;
72 79 50       935   unless ($self->_send_msg($request,$parse)) {
73 0         0     $self->{status} = STATUS_ERROR;
74 0         0     return _error("Write to socket server failed: $!");
75               }
76 79         821   $self->{status} = STATUS_PENDING;
77 79         718   $self->{encoring} = 0;
78 79         859   return 1;
79             }
80              
81             sub read {
82 79     79 0 1251   my $self = shift;
83 79 50       4809   return _error("No pending query") unless $self->status == STATUS_PENDING;
84 79 50 0     881   $self->_do_encore || return if $self->encore;
85             # call select() here to time out
86              
87 79 50       887   if ($self->{timeout}) {
88 79         1432       my $rdr = '';
89 79         1031       vec($rdr,fileno($self->{socket}),1) = 1;
90 79         9857080       my $result = select($rdr,undef,undef,$self->{timeout});
91 79 50       1361       return _error("Query timed out") unless $result;
92               }
93              
94 79         1834   my ($msg,$body) = $self->_recv_msg;
95 79 50       1068   return unless defined $msg;
96 79         877   $msg =~ s/\0.+$//; # socketserver bug workaround: get rid of junk in message
97 79 50 66     2375   if ($msg eq ACESERV_MSGOK or $msg eq ACESERV_MSGFAIL) {
    0          
98 79         1243     $self->{status} = STATUS_WAITING;
99 79         839     $self->{encoring} = 0;
100               } elsif ($msg eq ACESERV_MSGENCORE) {
101 0         0     $self->{status} = STATUS_PENDING; # not strictly necessary, but helpful to document
102 0         0     $self->{encoring} = 1;
103               } else {
104 0         0     $self->{status} = STATUS_ERROR;
105 0         0     return _error($body);
106               }
107 79         1415   return $body;
108             }
109              
110             sub write {
111 0     0 0 0   my $self = shift;
112 0         0   my $data = shift;
113 0 0       0   unless ($self->_send_msg($data,1)) {
114 0         0     $self->{status} = STATUS_ERROR;
115 0         0     return _error("Write to socket server failed: $!");
116               }
117 0         0   $self->{status} = STATUS_PENDING;
118 0         0   $self->{encoring} = 0;
119 0         0   return 1;
120             }
121              
122             sub _error {
123 0     0   0   $Ace::Error = shift;
124 0         0   return;
125             }
126              
127             # return socket (read only)
128 0     0 0 0 sub socket { $_[0]->{socket} }
129              
130             # ----------------------------- low level -------------------------------
131             sub _do_encore {
132 0     0   0   my $self = shift;
133 0 0       0   unless ($self->_send_msg('encore')) {
134 0         0     $self->{status} = STATUS_ERROR;
135 0         0     return _error("Write to socket server failed: $!");
136               }
137 0         0   $self->{status} = STATUS_PENDING;
138 0         0   return 1;
139             }
140             sub _handshake {
141 4     4   45   my $self = shift;
142 4         49   my ($user,$pass) = @_;
143 4         52   $self->_send_msg(ACESERV_CLIENT_HELLO);
144 4         52   my ($msg,$nonce) = $self->_recv_msg('strip');
145 4 50       56   return unless $msg eq ACESERV_MSGOK;
146             # hash username and password
147 4         130   my $authdigest = md5_hex(md5_hex($user . $pass).$nonce);
148 4         68   $self->_send_msg("$user $authdigest");
149 4         36   my $body;
150 4         52   ($msg,$body) = $self->_recv_msg('strip');
151 4 50       116   return _error("server: $body") unless $body eq ACESERV_SERVER_HELLO;
152 4         115   return 1;
153             }
154              
155             sub _send_msg {
156 88     88   1254   my ($self,$msg,$parse) = @_;
157 88 50       1112   return unless my $sock = $self->{socket};
158 88         7950   local $SIG{'PIPE'} = 'IGNORE';
159 88         817   $msg .= "\0"; # add terminating null
160 88         3914   my $request;
161 88 100       886   if ($parse) {
162 2         20     $request = ACESERV_MSGDATA;
163               } else {
164 86 50       963     $request = $msg eq "encore\0" ? ACESERV_MSGENCORE : ACESERV_MSGREQ;
165               }
166 88         1430   my $header = pack HEADER,WORDORDER_MAGIC,length($msg),0,$self->{client_id},0,$request;
167 88         18657   print $sock $header,$msg;
168             }
169              
170             sub _recv_msg {
171 88     88   942   my $self = shift;
172 88         5120   my $strip_null = shift;
173 88 50       3519   return unless my $sock = $self->{socket};
174 88         789   my ($header,$body);
175 88         1232112   my $bytes = CORE::read($sock,$header,HEADER_LEN);
176 88 50       1251   unless ($bytes > 0) {
177 0         0     $self->{status} = STATUS_ERROR;
178 0         0     return _error("Connection closed by remote server: $!");
179               }
180 88         3505   my ($magic,$length,$junk1,$clientID,$junk2,$msg) = unpack HEADER,$header;
181 88   100     4264   $self->{client_id} ||= $clientID;
182 88         1962   $msg =~ s/\0*$//;
183 88         1018   $self->{last_msg} = $msg;
184 88 50       3055   if ($length > 0) {
185 88 50       1538254     return _error("read of body failed: $!" )
186                   unless CORE::read($sock,$body,$length);
187 88 100 66     3091     $body =~ s/\0*$// if defined($strip_null) && $strip_null;
188 88         5685     return ($msg,$body);
189               } else {
190 0               return $msg;
191               }
192             }
193              
194             1;
195              
196             __END__
197