File Coverage

blib/lib/Device/Modbus/RTU/ADU.pm
Criterion Covered Total %
statement 41 41 100.0
branch 8 8 100.0
condition n/a
subroutine 10 10 100.0
pod 0 5 0.0
total 59 64 92.1


line stmt bran cond sub pod time code
1             package Device::Modbus::RTU::ADU;
2              
3 4     4   21688 use parent 'Device::Modbus::ADU';
  4         292  
  4         26  
4 4     4   5008 use Carp;
  4         14  
  4         199  
5 4     4   18 use strict;
  4         12  
  4         107  
6 4     4   20 use warnings;
  4         7  
  4         83  
7 4     4   36 use v5.10;
  4         11  
8              
9             sub crc {
10 6     6 0 2091 my ($self, $crc) = @_;
11 6 100       20 if (defined $crc) {
12 3         17 $self->{crc} = $crc;
13             }
14             croak "CRC has not been declared"
15 6 100       117 unless exists $self->{crc};
16 5         17 return $self->{crc};
17             }
18              
19             sub binary_message {
20 5     5 0 565 my $self = shift;
21             croak "Please include a unit number in the ADU."
22 5 100       194 unless $self->{unit};
23 4         11 my $header = $self->build_header;
24 4         15 my $pdu = $self->message->pdu();
25 4         90 my $footer = $self->build_footer($header, $pdu);
26 4         24 return $header . $pdu . $footer;
27             }
28              
29             sub build_header {
30 5     5 0 14 my $self = shift;
31 5         23 my $header = pack 'C', $self->{unit};
32 5         13 return $header;
33             }
34              
35             sub build_footer {
36 6     6 0 756 my ($self, $header, $pdu) = @_;
37 6         20 return $self->crc_for($header . $pdu);
38             }
39              
40             # Taken from MBClient (and verified against Modbus docs)
41             sub crc_for {
42 7     7 0 334 my ($self, $str) = @_;
43 7         9 my $crc = 0xFFFF;
44 7         9 my ($chr, $lsb);
45 7         24 for my $i (0..length($str)-1) {
46 36         54 $chr = ord(substr($str, $i, 1));
47 36         44 $crc ^= $chr;
48 36         56 for (1..8) {
49 288         312 $lsb = $crc & 1;
50 288         304 $crc >>= 1;
51 288 100       589 $crc ^= 0xA001 if $lsb;
52             }
53             }
54 7         28 return pack 'v', $crc;
55             }
56              
57             1;