File Coverage

lib/Net/HL7/Daemon.pm
Criterion Covered Total %
statement 82 99 82.8
branch 7 24 29.1
condition 6 20 30.0
subroutine 19 21 90.4
pod 4 4 100.0
total 118 168 70.2


line stmt bran cond sub pod time code
1             package Net::HL7::Daemon;
2              
3 3     3   3699 use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
  3         20632  
  3         15  
4 3     3   735 use base qw(IO::Socket::INET);
  3         4  
  3         257  
5 3     3   14 use strict;
  3         3  
  3         667  
6              
7             =pod
8              
9             =head1 NAME
10              
11             Net::HL7::Daemon
12              
13             =head1 SYNOPSIS
14              
15             my $d = new Net::HL7::Daemon( LocalPort => 12002, Listen => 5 );
16              
17             =head1 DESCRIPTION
18              
19             The Net::HL7::Daemon class provides a Daemon, roughly based on the
20             well known HTTP::Daemon class. The daemon wraps
21             L so that incoming connections are
22             returned as Net::HL7::Daemon::Client objects. Other than that the
23             Daemon class doesn't do all that much. However, this allows you to use
24             the Daemon class as a base for more elaborate servers, like preforking
25             or multi-threaded servers. See the Perl Cookbook for examples on this,
26             and think Net::HL7::Daemon where you see IO::Socket.
27              
28             =head1 METHODS
29              
30             =over 4
31              
32             =item B<$d = new Net::HL7::Daemon()>
33              
34             Create a new instance of the Daemon class. Arguments are the same as
35             for the IO::Socket::INET. Default settings are: Listen = SOMAXCONN,
36             Proto = tcp, Reuse = 1.
37              
38             =cut
39              
40             sub new
41             {
42 3     3 1 3366 my($class, %args) = @_;
43 3   50     25 $args{Listen} ||= 10;
44 3   50     18 $args{Proto} ||= 'tcp';
45 3   50     18 $args{Reuse} ||= 1;
46 3         46 return $class->SUPER::new(%args);
47             }
48              
49             =pod
50              
51             =item B
52              
53             This method is the same as I but returns an
54             I reference. It returns undef if
55             you specify a timeout and no connection is made within that time. In
56             a scalar context the returned value will be a reference to a object of
57             the I class which is another
58             I subclass. In a list context a two-element array
59             is returned containing the new I reference
60             and the peer address; the list will be empty upon failure.
61              
62             =cut
63              
64             sub accept
65             {
66 1     1 1 1058 my $self = shift;
67            
68 1         125 my ($sock, $peer) = $self->SUPER::accept("Net::HL7::Daemon::Client");
69 1 50       1071 if ($sock) {
70 1         9 ${*$sock}{'hl7d'} = $self;
  1         22  
71 1 50       15 return wantarray ? ($sock, $peer) : $sock;
72             } else {
73 0         0 return;
74             }
75             }
76              
77             =pod
78              
79             =item B
80              
81             Returns the host where this daemon can be reached.
82              
83             =cut
84              
85             sub getHost
86             {
87 1     1 1 303 my $self = shift;
88            
89 1         6 my $addr = $self->sockaddr;
90 1 50 33     36 if (!$addr || $addr eq INADDR_ANY) {
91 1         469 require Sys::Hostname;
92 1         862 return lc(Sys::Hostname::hostname());
93             }
94             else {
95 0   0     0 return gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
96             }
97             }
98              
99             =pod
100              
101             =item B
102              
103             Returns the port on which this daemon is listening.
104              
105             =back
106              
107             =cut
108              
109             sub getPort {
110              
111 1     1 1 257 my $self = shift;
112              
113 1         10 return $self->sockport;
114             }
115              
116              
117             package Net::HL7::Daemon::Client;
118              
119 3     3   19 use IO::Socket;
  3         2  
  3         18  
120 3     3   2765 use IO::Socket::Timeout;
  3         9687  
  3         15  
121 3     3   73 use base qw(IO::Socket::INET);
  3         4  
  3         210  
122 3     3   926 use Net::HL7::Request;
  3         6  
  3         62  
123 3     3   847 use Net::HL7::Messages::ACK;
  3         8  
  3         72  
124 3     3   255 use Net::HL7::Connection;
  3         3  
  3         50  
125 3     3   13 use strict;
  3         2  
  3         407  
126              
127              
128             =pod
129              
130             =head1 NAME
131              
132             Net::HL7::Daemon::Client
133              
134             =head1 DESCRIPTION
135              
136             The I is also a I
137             subclass. Instances of this class are returned by the accept() method
138             of I.
139              
140             =head1 METHODS
141              
142             =over 4
143              
144             =item B<$d = new Net::HL7::Daemon::Client()>
145              
146             Create a new instance of the Client class. Arguments are the same as
147             for the IO::Socket::INET. Normally, you shouldn't do this...
148              
149             =cut
150              
151             sub new
152             {
153 1     1   112 my($class, %args) = @_;
154 1   50     30 $args{Timeout} ||= 10;
155              
156 1         35 return $class->SUPER::new(%args);
157             }
158              
159             =pod
160              
161             =item B
162              
163             Get the current request on this client. The current request is either
164             the request that has been read by the getNextRequest() method, or if
165             that hasn't been called yet, the request read from the socket. The
166             latter is implemented by calling getNextRequest. If both fail,
167             C is returned.
168             In case of failure, then the I
169             object ($c) should be discarded, and you should not call this method
170             again.
171              
172             Potentially, a HL7 client can receive more than one
173             message. So discard the client only when there's no more requests
174             pending, or the delivering service might experience timeouts.
175              
176             =cut
177              
178             sub getRequest
179             {
180 1     1   11 my $self = shift;
181              
182 1 50       1 ${*$self}{'REQ'} && return ${*$self}{'REQ'};
  0         0  
  1         9  
183              
184 1         10 return $self->getNextRequest();
185             }
186              
187             =pod
188              
189             =item B
190              
191             Read data from the socket and turn it into an I
192             object which is then returned. It returns C if reading of the
193             request fails. If it fails, then the I
194             object ($c) should be discarded, and you should not call this method
195             again. Potentially, a HL7 client can receive more than one
196             message. So discard the client only when there's no more requests
197             pending, or the delivering service might experience timeouts.
198              
199             =cut
200              
201             sub getNextRequest
202             {
203 1     1   2 my $self = shift;
204              
205 1         20 IO::Socket::Timeout->enable_timeouts_on($self);
206              
207 1         389 $self->read_timeout(${*$self}{'io_socket_timeout'});
  1         18  
208 1         57 $self->write_timeout(${*$self}{'io_socket_timeout'});
  1         23  
209              
210             {
211 1         97 local $/ = $Net::HL7::Connection::MESSAGE_SUFFIX;
  1         32  
212              
213 3     3   11 use Errno qw(ETIMEDOUT EWOULDBLOCK);
  3         5  
  3         984  
214              
215             # slurrrp
216 1         3303 my $buff = <$self>;
217            
218 1 0 0     6 if (!$buff && ( 0+$! == ETIMEDOUT || 0+$! == EWOULDBLOCK )) {
      33        
219 0         0 return undef;
220             }
221              
222 1 50       4 if (not defined $buff) {
223 0         0 return undef;
224             }
225            
226             # Remove HL7 pre- and suffix
227             #
228 1         50 $buff =~ s/^$Net::HL7::Connection::MESSAGE_PREFIX//;
229 1         12 $buff =~ s/$Net::HL7::Connection::MESSAGE_SUFFIX$//;
230            
231 1         46 ${*$self}{'REQ'} = new Net::HL7::Request($buff);
  1         8  
232             }
233            
234 1         2 return ${*$self}{'REQ'};
  1         5  
235             }
236              
237             =pod
238              
239             =item B
240              
241             Write a I message to the client as a
242             response, to signal success. You may provide your own
243             Net::HL7::Response, but it is better to rely on the ACK that is
244             generated internally.
245              
246             =cut
247              
248             sub sendAck {
249              
250 1     1   10 my ($self, $res) = @_;
251              
252             # If this is true, we didn't get the incoming message yet!
253 1 50       2 if (! ${*$self}{'REQ'}) {
  1         25  
254 0 0       0 $self->getRequest() || return undef;
255             }
256              
257 1 50       9 if (! ref $res) {
258 1         2 $res = new Net::HL7::Messages::ACK(${*$self}{'REQ'});
  1         22  
259             }
260              
261 1         13 print $self $Net::HL7::Connection::MESSAGE_PREFIX . $res->toString() .
262             $Net::HL7::Connection::MESSAGE_SUFFIX;
263             }
264              
265             =pod
266              
267             =item B
268              
269             Write a I message to the client as a
270             response, with the Acknowledge Code (MSA(1)) set to CE or AE,
271             depending on the original request, to signal an error.
272              
273             =cut
274              
275             sub sendNack {
276              
277 0     0     my ($self, $errMsg, $res) = @_;
278              
279             # If this is true, we didn't get the incoming message yet!
280 0 0         if (! ${*$self}{'REQ'}) {
  0            
281 0 0         $self->getRequest() || return undef;
282             }
283            
284 0 0         if (! ref $res) {
285 0           $res = new Net::HL7::Messages::ACK(${*$self}{'REQ'});
  0            
286             }
287            
288 0           $res->setAckCode("E", $errMsg);
289            
290 0           print $self $Net::HL7::Connection::MESSAGE_PREFIX . $res->toString() .
291             $Net::HL7::Connection::MESSAGE_SUFFIX;
292             }
293              
294             =pod
295              
296             =item B
297              
298             Write a I object to the client as a response. This
299             can hold an arbitrary HL7 message.
300              
301             =back
302              
303             =cut
304              
305             sub sendResponse {
306              
307 0     0     my ($self, $res) = @_;
308              
309 0           print $self $Net::HL7::Connection::MESSAGE_PREFIX . $res->toString() .
310             $Net::HL7::Connection::MESSAGE_SUFFIX;
311             }
312              
313             =pod
314              
315             =head1 SEE ALSO
316              
317             RFC 2068
318              
319             L
320              
321             =head1 COPYRIGHT
322              
323             Copyright 2003, D.A.Dokter
324              
325             This library is free software; you can redistribute it and/or
326             modify it under the same terms as Perl itself.
327              
328             =cut
329              
330             1;