File Coverage

blib/lib/Device/Modbus/RTU/ADU.pm
Criterion Covered Total %
statement 39 39 100.0
branch 8 8 100.0
condition n/a
subroutine 9 9 100.0
pod 0 5 0.0
total 56 61 91.8


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