File Coverage

blib/lib/Protocol/Modbus/RTU.pm

Criterion	Covered	Total	%
statement	21	90	23.3
branch	0	20	0.0
condition	0	3	0.0
subroutine	7	14	50.0
pod	0	7	0.0
total	28	134	20.9

package Protocol::Modbus::RTU;
$VERSION = 1.00;

use strict;
use warnings;
use Carp;

use Protocol::Modbus;
use Protocol::Modbus::Request;

# Derive from Protocol::Modbus
@Protocol::Modbus::RTU::ISA = 'Protocol::Modbus';

# Table of CRC values for high order byte
use constant CRC_HI => [
    0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1,
    0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1, 0x81, 0x40,
    0x01, 0xC0, 0x80, 0x41, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1,
    0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41,
    0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1,
    0x81, 0x40, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40,
    0x01, 0xC0, 0x80, 0x41, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1,
    0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40,
    0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0,
    0x80, 0x41, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1, 0x81, 0x40,
    0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x01, 0xC0,
    0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41,
    0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1,
    0x81, 0x40, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40,
    0x01, 0xC0, 0x80, 0x41, 0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0,
    0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41,
    0x01, 0xC0, 0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0,
    0x80, 0x41, 0x00, 0xC1, 0x81, 0x40, 0x01, 0xC0, 0x80, 0x41, 0x01, 0xC0, 0x80, 0x41,
    0x00, 0xC1, 0x81, 0x40
];

# Table of CRC values for low order byte
use constant CRC_LO => [
    0x00, 0xC0, 0xC1, 0x01, 0xC3, 0x03, 0x02, 0xC2, 0xC6, 0x06, 0x07, 0xC7, 0x05, 0xC5,
    0xC4, 0x04, 0xCC, 0x0C, 0x0D, 0xCD, 0x0F, 0xCF, 0xCE, 0x0E, 0x0A, 0xCA, 0xCB, 0x0B,
    0xC9, 0x09, 0x08, 0xC8, 0xD8, 0x18, 0x19, 0xD9, 0x1B, 0xDB, 0xDA, 0x1A, 0x1E, 0xDE,
    0xDF, 0x1F, 0xDD, 0x1D, 0x1C, 0xDC, 0x14, 0xD4, 0xD5, 0x15, 0xD7, 0x17, 0x16, 0xD6,
    0xD2, 0x12, 0x13, 0xD3, 0x11, 0xD1, 0xD0, 0x10, 0xF0, 0x30, 0x31, 0xF1, 0x33, 0xF3,
    0xF2, 0x32, 0x36, 0xF6, 0xF7, 0x37, 0xF5, 0x35, 0x34, 0xF4, 0x3C, 0xFC, 0xFD, 0x3D,
    0xFF, 0x3F, 0x3E, 0xFE, 0xFA, 0x3A, 0x3B, 0xFB, 0x39, 0xF9, 0xF8, 0x38, 0x28, 0xE8,
    0xE9, 0x29, 0xEB, 0x2B, 0x2A, 0xEA, 0xEE, 0x2E, 0x2F, 0xEF, 0x2D, 0xED, 0xEC, 0x2C,
    0xE4, 0x24, 0x25, 0xE5, 0x27, 0xE7, 0xE6, 0x26, 0x22, 0xE2, 0xE3, 0x23, 0xE1, 0x21,
    0x20, 0xE0, 0xA0, 0x60, 0x61, 0xA1, 0x63, 0xA3, 0xA2, 0x62, 0x66, 0xA6, 0xA7, 0x67,
    0xA5, 0x65, 0x64, 0xA4, 0x6C, 0xAC, 0xAD, 0x6D, 0xAF, 0x6F, 0x6E, 0xAE, 0xAA, 0x6A,
    0x6B, 0xAB, 0x69, 0xA9, 0xA8, 0x68, 0x78, 0xB8, 0xB9, 0x79, 0xBB, 0x7B, 0x7A, 0xBA,
    0xBE, 0x7E, 0x7F, 0xBF, 0x7D, 0xBD, 0xBC, 0x7C, 0xB4, 0x74, 0x75, 0xB5, 0x77, 0xB7,
    0xB6, 0x76, 0x72, 0xB2, 0xB3, 0x73, 0xB1, 0x71, 0x70, 0xB0, 0x50, 0x90, 0x91, 0x51,
    0x93, 0x53, 0x52, 0x92, 0x96, 0x56, 0x57, 0x97, 0x55, 0x95, 0x94, 0x54, 0x9C, 0x5C,
    0x5D, 0x9D, 0x5F, 0x9F, 0x9E, 0x5E, 0x5A, 0x9A, 0x9B, 0x5B, 0x99, 0x59, 0x58, 0x98,
    0x88, 0x48, 0x49, 0x89, 0x4B, 0x8B, 0x8A, 0x4A, 0x4E, 0x8E, 0x8F, 0x4F, 0x8D, 0x4D,
    0x4C, 0x8C, 0x44, 0x84, 0x85, 0x45, 0x87, 0x47, 0x46, 0x86, 0x82, 0x42, 0x43, 0x83,
    0x41, 0x81, 0x80, 0x40
];

sub request {
    my ($self, %args) = @_;

    # Pass control to super class
    return $self->SUPER::request(%args);
}

sub response {
    my ($self, %args) = @_;

    # Pass control to super class
    return $self->SUPER::response(%args);
}

# Needed to encapsulate modbus request with the unit header
# to be transmitted via serial link
sub requestHeader {
    my ($self, $req) = @_;

    my $pdu  = $req->pdu();             # builds the request message PDU first
    my $unit = $req->options->{unit};

    # Pack the header
    my $hdr = pack('C', $unit);

    #print 'Computed HDR [', uc( unpack('H*', $hdr) ), "]\n";
    return ($hdr);
}

# Needed to append the CRC in the trailer
# to be transmitted via serial link
sub requestTrailer {
    my ($self, $req) = @_;

    my $hdr = $req->header();
    my $pdu = $req->pdu();
    my $msg;
    $msg = $hdr if defined($hdr);
    $msg .= $pdu if defined($pdu);

    #print 'Calculating CRC for ['.uc( unpack('H*', $msg ) )."]\n";

    my $crcl  = 0xFF;
    my $crch  = 0xFF;
    my @bytes = split(//, $msg);
    for (@bytes) {
        my $data = unpack('C*', $_);
        my $crcIdx = $crcl ^ $data;
        $crcl = $crch ^ &CRC_HI->[$crcIdx];
        $crch = &CRC_LO->[$crcIdx];
    }

    # Pack the trailer - CRC has low byte first
    my $trlr = pack('CC', $crcl, $crch);

    #print 'Computed CRC ['.uc( unpack('H*', $trlr) )."]\n";
    return ($trlr);
}

sub extractPdu {
    my ($self, $raw_data) = @_;

    if (!defined($raw_data) or length($raw_data) == 0) {
        return;
    }

    # split hdr(length 1)-pdu(length count+3)-crc(length 2)
    # pdu is func(length 1)-count(length 2)-value(length count)
    my $hdr = substr($raw_data, 0, 1);

    #print 'hdr   = ['.uc( unpack('H*', $hdr))."]\n";

    my $pdu = substr($raw_data, 1, -2);

    #print 'pdu   = ['.uc( unpack('H*', $pdu))."]\n";

    my $crc = substr($raw_data, -2);

    #print 'crc   = ['.uc( unpack('H*', $crc))."]\n";

    return ($hdr, $pdu, $crc);
}

# Process a request before sending on the wire
# Add header
sub processBeforeSend {
    my ($self, $req) = @_;

    # add optional header/trailer for (for Modbus/TCP, Modbus/RTU protocol flavours)
    my $hdr = $self->requestHeader($req);    # calls pdu()
    $req->header($hdr);
    my $trlr = $self->requestTrailer($req);
    $req->trailer($trlr);

    # now that header and footer created set the frame
    my $frame = $hdr . $req->pdu() . $trlr;

    #print "Set frame to [", uc( unpack('H*', $frame) ), "]\n";
    $req->frame($frame);

    return ($req);
}

# Process binary data after receiving
# Protocol should be responsible for processing binary
# packets to obtain a single Modbus PDU frame
#
# Modbus/TCP packets are composed of [MBAP + PDU]
#
sub processAfterReceive {
    my ($self, $res) = @_;
    my $raw_data = $res->frame();

    #print "RTU processAfterReceive [".uc( unpack('H*', $raw_data) )."] \n";
    my ($hdr, $pdu, $crc, $value);

    eval { ($hdr, $pdu, $crc) = $self->extractPdu($raw_data); };
    if ($@) {
        warn('Exception generated (', $@, ')');
        return ($@);
    }

    warn("\tHDR   = [", uc(unpack('H*', $hdr)), "] \n") if defined $hdr;
    warn("\tPDU   = [", uc(unpack('H*', $pdu)), "] \n") if defined $pdu;
    warn("\tCRC   = [", uc(unpack('H*', $crc)), "] \n") if defined $crc;

    # Set response PDU field
    $res->unit($hdr);
    $res->pdu($pdu);
    $res->crc($crc);

    # Validate the received CRC
    my $msg;
    $msg = $hdr if defined($hdr);
    $msg .= $pdu if defined($pdu);

    #print 'Calculating CRC for ['.uc( unpack('H*', $msg ) )."]\n";

    my $crcl  = 0xFF;
    my $crch  = 0xFF;
    my @bytes = split(//, $msg);
    for (@bytes) {
        my $data = unpack('C*', $_);
        my $crcIdx = $crcl ^ $data;
        $crcl = $crch ^ &CRC_HI->[$crcIdx];
        $crch = &CRC_LO->[$crcIdx];
    }

    # Pack the trailer - CRC has low byte first
    my $crcCalc = pack('CC', $crcl, $crch);

    #print 'Computed CRC ['.uc( unpack('H*', $crcCalc) )."]\n";
    #print 'Received CRC ['.uc( unpack('H*', $crc) )."]\n";
    if ($crcCalc ne $crc) {
        warn(
            'Invalid CRC received [',
            uc(unpack('H*', $crc)),
            '] expecting [',
            uc(unpack('H*', $crcCalc)), "]\n"
        );
    }

    return ($res);
}

1;