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

package Net::HL7::Daemon;

use IO::Socket qw(AF_INET INADDR_ANY inet_ntoa);
use base qw(IO::Socket::INET);
use strict;

=pod

=head1 NAME

Net::HL7::Daemon

=head1 SYNOPSIS

my $d = new Net::HL7::Daemon( LocalPort => 12002, Listen => 5 );

=head1 DESCRIPTION

The Net::HL7::Daemon class provides a Daemon, roughly based on the
well known HTTP::Daemon class. The daemon wraps
L so that incoming connections are
returned as Net::HL7::Daemon::Client objects. Other than that the
Daemon class doesn't do all that much. However, this allows you to use
the Daemon class as a base for more elaborate servers, like preforking
or multi-threaded servers. See the Perl Cookbook for examples on this,
and think Net::HL7::Daemon where you see IO::Socket.

=head1 METHODS

=over 4

=item B<$d = new Net::HL7::Daemon()>

Create a new instance of the Daemon class. Arguments are the same as
for the IO::Socket::INET. Default settings are: Listen = SOMAXCONN,
Proto = tcp, Reuse = 1.

=cut

sub new
{
    my($class, %args) = @_;
    $args{Listen} ||= 10;
    $args{Proto}  ||= 'tcp';
    $args{Reuse}  ||= 1;
    return $class->SUPER::new(%args);
}

=pod

=item B

This method is the same as I but returns an
I reference.  It returns undef if
you specify a timeout and no connection is made within that time.  In
a scalar context the returned value will be a reference to a object of
the I class which is another
I subclass.  In a list context a two-element array
is returned containing the new I reference
and the peer address; the list will be empty upon failure.

=cut

sub accept
{
    my $self = shift;

    my ($sock, $peer) = $self->SUPER::accept("Net::HL7::Daemon::Client");
    if ($sock) {
        ${*$sock}{'hl7d'} = $self;
        return wantarray ? ($sock, $peer) : $sock;
    } else {
        return;
    }
}

=pod

=item B

Returns the host where this daemon can be reached.

=cut

sub getHost
{
    my $self = shift;

    my $addr = $self->sockaddr;
    if (!$addr || $addr eq INADDR_ANY) {
 	require Sys::Hostname;
 	return lc(Sys::Hostname::hostname());
    }
    else {
	return gethostbyaddr($addr, AF_INET) || inet_ntoa($addr);
    }
}

=pod

=item B

Returns the port on which this daemon is listening.

=back

=cut

sub getPort {

    my $self = shift;

    return $self->sockport;
}


package Net::HL7::Daemon::Client;

use IO::Socket;
use IO::Socket::Timeout;
use base qw(IO::Socket::INET);
use Net::HL7::Request;
use Net::HL7::Messages::ACK;
use Net::HL7::Connection;
use strict;


=pod

=head1 NAME

Net::HL7::Daemon::Client

=head1 DESCRIPTION

The I is also a I
subclass. Instances of this class are returned by the accept() method
of I.

=head1 METHODS

=over 4

=item B<$d = new Net::HL7::Daemon::Client()>

Create a new instance of the Client class. Arguments are the same as
for the IO::Socket::INET. Normally, you shouldn't do this...

=cut

sub new
{
    my($class, %args) = @_;
    $args{Timeout} ||= 10;

    return $class->SUPER::new(%args);
}

=pod

=item B

Get the current request on this client. The current request is either
the request that has been read by the getNextRequest() method, or if
that hasn't been called yet, the request read from the socket. The
latter is implemented by calling getNextRequest. If both fail,
C is returned.
In case of failure, then the I
object ($c) should be discarded, and you should not call this method
again.

Potentially, a HL7 client can receive more than one
message. So discard the client only when there's no more requests
pending, or the delivering service might experience timeouts.

=cut

sub getRequest
{
    my $self = shift;

    ${*$self}{'REQ'} && return ${*$self}{'REQ'};

    return $self->getNextRequest();
}

=pod

=item B

Read data from the socket and turn it into an I
object which is then returned.  It returns C if reading of the
request fails.  If it fails, then the I
object ($c) should be discarded, and you should not call this method
again.  Potentially, a HL7 client can receive more than one
message. So discard the client only when there's no more requests
pending, or the delivering service might experience timeouts.

=cut

sub getNextRequest
{
    my $self = shift;

    IO::Socket::Timeout->enable_timeouts_on($self);

    $self->read_timeout(${*$self}{'io_socket_timeout'});
    $self->write_timeout(${*$self}{'io_socket_timeout'});

    {
        local $/ = $Net::HL7::Connection::MESSAGE_SUFFIX;

        use Errno qw(ETIMEDOUT EWOULDBLOCK);

        # slurrrp
        my $buff = <$self>;

        if (!$buff && ( 0+$! == ETIMEDOUT || 0+$! == EWOULDBLOCK )) {
            return undef;
        }

        if (not defined $buff) {
            return undef;
        }

        # Remove HL7 pre- and suffix
        #
        $buff =~ s/^$Net::HL7::Connection::MESSAGE_PREFIX//;
        $buff =~ s/$Net::HL7::Connection::MESSAGE_SUFFIX$//;

        ${*$self}{'REQ'} = new Net::HL7::Request($buff);
    }

    return ${*$self}{'REQ'};
}

=pod

=item B

Write a I message to the client as a
response, to signal success. You may provide your own
Net::HL7::Response, but it is better to rely on the ACK that is
generated internally.

=cut

sub sendAck {

    my ($self, $res) = @_;

    # If this is true, we didn't get the incoming message yet!
    if (! ${*$self}{'REQ'}) {
        $self->getRequest() || return undef;
    }

    if (! ref $res) {
        $res = new Net::HL7::Messages::ACK(${*$self}{'REQ'});
    }

    print $self $Net::HL7::Connection::MESSAGE_PREFIX . $res->toString() .
        $Net::HL7::Connection::MESSAGE_SUFFIX;
}

=pod

=item B

Write a I message to the client as a
response, with the Acknowledge Code (MSA(1)) set to CE or AE,
depending on the original request, to signal an error.

=cut

sub sendNack {

    my ($self, $errMsg, $res) = @_;

    # If this is true, we didn't get the incoming message yet!
    if (! ${*$self}{'REQ'}) {
        $self->getRequest() || return undef;
    }

    if (! ref $res) {
        $res = new Net::HL7::Messages::ACK(${*$self}{'REQ'});
    }

    $res->setAckCode("E", $errMsg);

    print $self $Net::HL7::Connection::MESSAGE_PREFIX . $res->toString() .
        $Net::HL7::Connection::MESSAGE_SUFFIX;
}

=pod

=item B

Write a I object to the client as a response. This
can hold an arbitrary HL7 message.

=back

=cut

sub sendResponse {

    my ($self, $res) = @_;

    print $self $Net::HL7::Connection::MESSAGE_PREFIX . $res->toString() .
        $Net::HL7::Connection::MESSAGE_SUFFIX;
}

=pod

=head1 SEE ALSO

RFC 2068

L

=head1 COPYRIGHT

Copyright 2003, D.A.Dokter

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1;