File Coverage

blib/lib/Device/Modbus/TCP/Server.pm

Criterion	Covered	Total	%
statement	59	67	88.0
branch	3	8	37.5
condition			n/a
subroutine	17	19	89.4
pod	4	7	57.1
total	83	101	82.1

package Device::Modbus::TCP::Server;

use Device::Modbus;
use Device::Modbus::TCP::ADU;
use Device::Modbus::Exception;
use Data::Dumper;
use Try::Tiny;
use Role::Tiny::With;
use Carp;
use strict;
use warnings;

use parent qw(Device::Modbus::Server Net::Server::MultiType);
with  'Device::Modbus::TCP';

sub new {
    my ($class, %args) = @_;
    return bless { server => \%args, %{ $class->proto() }}, $class;
}

sub default_values {
    return {
        log_level   => 2,
        log_file    => undef,
        port        => 502,
        host        => '*',
        ipv         => 4,
        proto       => 'tcp',
    };
}

sub post_accept_hook {
    my $self = shift;
    $self->{socket} = $self->{server}->{client};
}

sub socket {
    my $self = shift;
    croak "Connection is unavailable" unless defined $self->{socket};
    return $self->{socket};
}

# Return exception if unit is not supported by server
sub request_for_others {
    my ($self, $adu) = @_;
    return Device::Modbus::Exception->new(
            function       => $Device::Modbus::function_for{$adu->code},
            exception_code => 2,
            unit           => $adu->unit
    );
}

sub process_request {
    my $self = shift;

    while ($self->socket->connected) {
        my $req_adu;
        try {
            $req_adu = $self->receive_request;
        }
        catch {
            unless (/Time out/) {
                $self->log(2, "Error while waiting for request: $_");
            }
        };
        next unless $req_adu;


        $self->log(4, 'Received message from ' . $self->socket->peerhost);
        $self->log(4, 'Request: ' . Dumper $req_adu);

        # If it is an exception object, we're done
        if ($req_adu->message->isa('Device::Modbus::Exception')) {
            $self->log(3, "Exception while waiting for requests: $_");
            $self->write_port($req_adu);
            next;
        }

        # Process request
        my $resp = $self->modbus_server($req_adu);
        my $resp_adu = $self->new_adu;
        $resp_adu->message($resp);
        $resp_adu->id($req_adu->id);
        $resp_adu->unit($req_adu->unit);

        # And send the response!
        $self->write_port($resp_adu);
        $self->log(4, "Response: " . Dumper $resp_adu);
        $self->log(4, "Binary response: " . join '-', unpack 'C*', $resp_adu->binary_message);
    }
    $self->log(3, 'Client disconnected');
}

sub start {
    my ($self, %args) = @_;
    $self->log(2, 'Starting server');
    $self->run(%args);
}

1;

__END__