File Coverage

lib/Net/HL7/Connection.pm
Criterion Covered Total %
statement 49 60 81.6
branch 4 12 33.3
condition 2 4 50.0
subroutine 10 12 83.3
pod 3 3 100.0
total 68 91 74.7


line stmt bran cond sub pod time code
1             package Net::HL7::Connection;
2              
3 3     3   1448 use 5.004;
  3         7  
4 3     3   11 use strict;
  3         6  
  3         47  
5 3     3   693 use Net::HL7::Response;
  3         24  
  3         84  
6 3     3   782 use IO::Socket;
  3         30785  
  3         14  
7 3     3   1026 use Errno qw(:POSIX);
  3         4  
  3         1992  
8              
9             =head1 NAME
10              
11             Net::HL7::Connection - An HL7 connection
12              
13             =head1 SYNOPSIS
14              
15              
16             use Net::HL7::Connection;
17             use Net::HL7::Request;
18              
19             my $conn = new Net::HL7::Connection('localhost', 8089);
20              
21             my $req = new Net::HL7::Request();
22              
23             ... set some request attributes
24              
25             my $res = $conn->send($req);
26              
27             $conn->close();
28              
29              
30             =head1 DESCRIPTION
31              
32             The Net::HL7::Connection object represents the tcp connection to the
33             HL7 message broker. The Connection has only two useful methods (apart
34             from the constructor), send and close. The 'send' method takes a
35             L as argument, and returns a
36             L. The send method can be used
37             more than once, before the connection is closed.
38              
39             =head1 FIELDS
40              
41             The Connection object holds the following fields:
42              
43             =over 4
44              
45             =item MESSAGE_PREFIX
46              
47             The prefix to be sent to the HL7 server to initiate the
48             message. Defaults to \013.
49              
50             =item MESSAGE_SUFFIX
51              
52             End of message signal for HL7 server. Defaults to \034\015.
53              
54             =back
55              
56             =cut
57              
58             our $MESSAGE_PREFIX = "\013";
59             our $MESSAGE_SUFFIX = "\034\015";
60              
61              
62             =head1 METHODS
63              
64             The following methods are available:
65              
66             =over 4
67              
68             =item B<$c = new Net::HL7::Connection( $host, $port[, Timeout => timeout] )>
69             Creates a connection to a HL7 server, or returns undef when a
70             connection could not be established. timeout is optional, and will
71             default to 10 seconds.
72              
73             =cut
74              
75             sub new {
76            
77 1     1 1 1068 my $class = shift;
78 1         15 bless my $self = {}, $class;
79            
80 1 50       24 $self->_init(@_) || return undef;
81            
82 1         3 return $self;
83             }
84              
85              
86             sub _init {
87              
88 1     1   20 my ($self, $host, $port, %arg) = @_;
89            
90 1   50     40 $self->{Timeout} = $arg{Timeout} || 10;
91 1         11 $self->{HANDLE} = $self->_connect($host, $port);
92             }
93              
94              
95             sub _connect {
96              
97 1     1   2 my ($self, $host, $port) = @_;
98              
99             my $remote = IO::Socket::INET->new
100             (
101             Proto => "tcp",
102             PeerAddr => $host,
103             PeerPort => $port,
104             Timeout => $self->{Timeout}
105             )
106 1   50     12 ||
107             return undef;
108            
109 1         3293 return $remote;
110             }
111              
112              
113             =pod
114              
115             =item B
116              
117             Sends a L object over this
118             connection.
119              
120             =cut
121              
122             sub send {
123              
124 1     1 1 624 my ($self, $req) = @_;
125              
126 1         2 my $buff;
127 1         6 my $handle = $self->{HANDLE};
128 1         12 my $hl7Msg = $req->toString();
129              
130             # Setting separators to HL7 defaults, so print and read operations
131             # will do the whole message at once.
132             #
133             {
134 1         5 local $/;
  1         4  
135              
136 1         3 $/ = $MESSAGE_SUFFIX;
137              
138             # Send message, prefixed with HL7 message start symbol(s)
139             # Use an alarm in for the timeout.
140 1         2 eval {
141 1     0   23 local $SIG{ALRM} = sub { die "alarm\n" };
  0         0  
142 1         7 alarm $self->{Timeout};
143 1         49 print $handle $MESSAGE_PREFIX . $hl7Msg . $MESSAGE_SUFFIX;
144 1         9 alarm 0;
145             };
146 1 50       4 if ($@) {
147 0 0       0 if ($@ eq "alarm\n") {
148 0         0 $! = ETIMEDOUT();
149 0         0 return undef;
150             }
151 0         0 die $@;
152             }
153              
154             # Read response in slurp mode
155 1         2 eval {
156 1     0   14 local $SIG{ALRM} = sub { die "alarm\n" };
  0         0  
157 1         3 alarm $self->{Timeout};
158 1         2693 $buff = <$handle>;
159 1         14 alarm 0;
160             };
161 1 50       5 if ($@) {
162 0 0       0 if ($@ eq "alarm\n") {
163 0         0 $! = ETIMEDOUT();
164 0         0 return undef;
165             }
166 0         0 die $@;
167             }
168             }
169              
170             # Remove message prefix and suffix
171 1 50       4 if (defined($buff)) {
172 1         56 $buff =~ s/^$MESSAGE_PREFIX//;
173 1         10 $buff =~ s/$MESSAGE_SUFFIX$//;
174            
175 1         13 return new Net::HL7::Response($buff);
176             } else {
177 0         0 return $buff;
178             }
179             }
180              
181             =pod
182              
183             =item B
184              
185             Close the connection.
186              
187             =cut
188              
189             sub close {
190              
191 1     1 1 2 my $self = shift;
192              
193 1         10 $self->{HANDLE}->close();
194             }
195              
196             1;
197              
198              
199             =pod
200              
201             =back
202              
203             =head1 AUTHOR
204              
205             D.A.Dokter
206              
207             =head1 LICENSE
208              
209             Copyright (c) 2002 D.A.Dokter. All rights reserved. This program is
210             free software; you can redistribute it and/or modify it under the same
211             terms as Perl itself.
212              
213             =cut