—package
Device::Modbus::TCP;
use
IO::Socket::INET;
use
Try::Tiny;
use
Role::Tiny;
use
Carp;
use
strict;
use
warnings;
our
$VERSION
=
'0.22'
;
####
sub
read_port {
my
(
$self
,
$bytes
) =
@_
;
return
unless
$bytes
;
my
$sock
=
$self
->
socket
;
croak
"Disconnected"
unless
$sock
->connected;
local
$SIG
{
'ALRM'
} =
sub
{ croak
"Connection timed out\n"
};
my
$msg
;
RECEIVE : {
alarm
$self
->{timeout};
my
$rc
=
$self
->
socket
->
recv
(
$msg
,
$bytes
);
alarm
0;
if
(
exists
$!{EINTR} && $!{EINTR} ||
length
(
$msg
) == 0) {
redo
RECEIVE;
}
if
(!
defined
$rc
) {
croak
"Communication error while reading request: $!"
;
}
}
# say STDERR "Bytes: " . length($msg) . " MSG: " . unpack 'H*', $msg;
$self
->{buffer} =
$msg
;
return
$msg
;
}
sub
write_port {
my
(
$self
,
$adu
) =
@_
;
local
$SIG
{
'ALRM'
} =
sub
{
die
"Connection timed out\n"
};
my
$attempts
= 0;
my
$rc
;
SEND: {
my
$sock
=
$self
->
socket
;
try
{
alarm
$self
->{timeout};
$rc
=
$sock
->
send
(
$adu
->binary_message);
alarm
0;
if
(!
defined
$rc
) {
die
"Communication error while sending request: $!"
;
}
}
catch
{
if
(
$_
=~ /timed out/) {
$sock
->
close
;
$self
->_build_socket;
$attempts
++;
}
else
{
croak
$_
;
}
};
last
SEND
if
$attempts
>= 5 ||
$rc
==
length
(
$adu
->binary_message);
redo
SEND;
}
return
$rc
;
}
sub
disconnect {
my
$self
=
shift
;
$self
->
socket
->
close
;
}
sub
parse_buffer {
my
(
$self
,
$bytes
,
$pattern
) =
@_
;
$self
->read_port(
$bytes
);
croak
"Time out error"
unless
defined
$self
->{buffer} &&
length
(
$self
->{buffer}) >=
$bytes
;
return
unpack
$pattern
,
substr
$self
->{buffer},0,
$bytes
,
''
;
}
sub
new_adu {
my
(
$self
,
$msg
) =
@_
;
my
$adu
= Device::Modbus::TCP::ADU->new;
if
(
defined
$msg
) {
$adu
->message(
$msg
);
$adu
->unit(
$msg
->{unit})
if
defined
$msg
->{unit};
$adu
->id(
$self
->next_trn_id );
}
return
$adu
;
}
### Parsing a message
sub
parse_header {
my
(
$self
,
$adu
) =
@_
;
my
(
$id
,
$proto
,
$length
,
$unit
) =
$self
->parse_buffer(7,
'nnnC'
);
$adu
->id(
$id
);
$adu
->
length
(
$length
);
$adu
->unit(
$unit
);
return
$adu
;
}
sub
parse_footer {
my
(
$self
,
$adu
) =
@_
;
return
$adu
;
}
1;
__END__
=head1 NAME
Device::Modbus::TCP - Distribution for Modbus TCP communications
=head1 SYNOPSIS
#! /usr/bin/perl
use Device::Modbus::TCP::Client;
use Data::Dumper;
use strict;
use warnings;
use v5.10;
my $client = Device::Modbus::TCP::Client->new(
host => '192.168.1.34',
);
my $req = $client->read_holding_registers(
unit => 3,
address => 2,
quantity => 1
);
say Dumper $req;
$client->send_request($req) || die "Send error: $!";
my $response = $client->receive_response;
say Dumper $response;
$client->disconnect;
=head1 DESCRIPTION
Device::Modbus::TCP is a distribution which implements the Modbus TCP protocol on top of L<Device::Modbus>; it adds the capability of communicating via TCP sockets. Please see Device::Modbus to learn about its functionality, and L<Device::Modbus::TCP::Client> or L<Device::Modbus::TCP::Server> to see the particularities of the Modbus TCP implementation.
=head1 GITHUB REPOSITORY
You can find the repository of this distribution in L<GitHub|https://github.com/jfraire/Device-Modbus-TCP>.
=head1 AUTHOR
Julio Fraire, E<lt>julio.fraire@gmail.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2015 by Julio Fraire
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.14.2 or,
at your option, any later version of Perl 5 you may have available.
=cut