unit uModbusRTU;

{
  Libreria Modbus RTU su RS485 per Delphi
  Compatibile con: moduli relè Waveshare Modbus RTU 32-Ch,
                    moduli I/O digitali 8-Ch, moduli acquisizione analogica 8-Ch
  Usa API Win32 pura (nessuna dipendenza esterna)
}

interface

uses
  Winapi.Windows, system.SysUtils, system.Classes;

type
  TModbusException = class(Exception);

  TModbusRTU = class
  private
    FHandle: THandle;
    FPortName: string;
    FBaudRate: Cardinal;
    FTimeoutMs: Cardinal;
    /// Quando e' finito l'ultimo scambio: fra un frame e l'altro il Modbus RTU
    /// vuole almeno 3,5 caratteri di silenzio.
    FLastFrame: UInt64;
    procedure WaitInterFrame;
    function CalcCRC16(const ABuf: array of Byte; ALen: Integer): Word;
    function SendReceive(const ARequest: array of Byte; AExpectedLen: Integer): TBytes;
  public
    constructor Create(const APortName: string; ABaudRate: Cardinal = 9600; ATimeoutMs: Cardinal = 500);
    destructor Destroy; override;

    procedure Connect;
    procedure Disconnect;
    function IsConnected: Boolean;

    // Function 01 - Read Coils (uscite relè)
    function ReadCoils(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Boolean>;
    // Function 02 - Read Discrete Inputs (ingressi digitali)
    function ReadDiscreteInputs(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Boolean>;
    // Function 03 - Read Holding Registers (es. ingressi analogici)
    function ReadHoldingRegisters(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Word>;
    // Function 04 - Read Input Registers
    function ReadInputRegisters(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Word>;
    // Function 05 - Write Single Coil (accende/spegne un relè)
    procedure WriteSingleCoil(ASlaveAddr: Byte; AAddr: Word; AValue: Boolean);
    // Function 06 - Write Single Register
    procedure WriteSingleRegister(ASlaveAddr: Byte; AAddr, AValue: Word);
    // Function 15 - Write Multiple Coils
    procedure WriteMultipleCoils(ASlaveAddr: Byte; AStartAddr: Word; const AValues: array of Boolean);

    property PortName: string read FPortName;
    property BaudRate: Cardinal read FBaudRate;
    property TimeoutMs: Cardinal read FTimeoutMs write FTimeoutMs;
  end;

implementation

const
  INVALID_HANDLE = THandle(-1);

{ TModbusRTU }

constructor TModbusRTU.Create(const APortName: string; ABaudRate: Cardinal; ATimeoutMs: Cardinal);
begin
  inherited Create;
  FPortName := APortName;
  FBaudRate := ABaudRate;
  FTimeoutMs := ATimeoutMs;
  FHandle := INVALID_HANDLE;
end;

destructor TModbusRTU.Destroy;
begin
  Disconnect;
  inherited;
end;

function TModbusRTU.IsConnected: Boolean;
begin
  Result := FHandle <> INVALID_HANDLE;
end;

procedure TModbusRTU.Connect;
var
  DCB: TDCB;
  Timeouts: TCommTimeouts;
  FullName: string;
begin
  if IsConnected then Exit;

  // Prefisso \\.\ necessario per COM10+
  FullName := '\\.\' + FPortName;

  FHandle := CreateFile(PChar(FullName), GENERIC_READ or GENERIC_WRITE,
    0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);

  if FHandle = INVALID_HANDLE then
    raise TModbusException.CreateFmt('Impossibile aprire %s (errore %d)', [FPortName, GetLastError]);

  FillChar(DCB, SizeOf(DCB), 0);
  DCB.DCBlength := SizeOf(DCB);
  if not GetCommState(FHandle, DCB) then
    raise TModbusException.Create('GetCommState fallita');

  DCB.BaudRate := FBaudRate;
  DCB.ByteSize := 8;
  DCB.Parity := NOPARITY;
  DCB.StopBits := ONESTOPBIT;
  DCB.Flags := 0; // no flow control

  if not SetCommState(FHandle, DCB) then
    raise TModbusException.Create('SetCommState fallita: parametri seriali non validi');

  Timeouts.ReadIntervalTimeout := 50;
  Timeouts.ReadTotalTimeoutMultiplier := 10;
  Timeouts.ReadTotalTimeoutConstant := FTimeoutMs;
  Timeouts.WriteTotalTimeoutMultiplier := 10;
  Timeouts.WriteTotalTimeoutConstant := FTimeoutMs;
  SetCommTimeouts(FHandle, Timeouts);

  PurgeComm(FHandle, PURGE_RXCLEAR or PURGE_TXCLEAR);
end;

procedure TModbusRTU.Disconnect;
begin
  if IsConnected then
  begin
    CloseHandle(FHandle);
    FHandle := INVALID_HANDLE;
  end;
end;

function TModbusRTU.CalcCRC16(const ABuf: array of Byte; ALen: Integer): Word;
var
  I, J: Integer;
  CRC: Word;
begin
  CRC := $FFFF;
  for I := 0 to ALen - 1 do
  begin
    CRC := CRC xor ABuf[I];
    for J := 0 to 7 do
    begin
      if (CRC and $0001) <> 0 then
        CRC := (CRC shr 1) xor $A001
      else
        CRC := CRC shr 1;
    end;
  end;
  Result := CRC;
end;

procedure TModbusRTU.WaitInterFrame;
var
  Silenzio, Passato: UInt64;
begin
  // 3,5 caratteri da 11 bit al baud in uso, mai meno di 2 ms: a 9600 sono
  // circa 4 ms. Senza questa pausa le richieste partono attaccate alla
  // risposta precedente, e il modulo ogni tanto non le sente: la lettura
  // salta, la spia si spegne e l'allarme riparte. Costa pochi millisecondi
  // per richiesta.
  if FBaudRate = 0 then
    Exit;
  Silenzio := (35 * 11 * 1000) div (FBaudRate * 10);
  if Silenzio < 2 then
    Silenzio := 2;
  if FLastFrame = 0 then
    Exit;
  Passato := GetTickCount64 - FLastFrame;
  if Passato < Silenzio then
    Sleep(Silenzio - Passato);
end;

function TModbusRTU.SendReceive(const ARequest: array of Byte; AExpectedLen: Integer): TBytes;
var
  BytesWritten, BytesRead: DWORD;
  RecvCRC: Word;
  RecvBuf: TBytes;
begin
  if not IsConnected then
    raise TModbusException.Create('Porta non connessa: chiamare Connect prima');

  WaitInterFrame;
  PurgeComm(FHandle, PURGE_RXCLEAR or PURGE_TXCLEAR);

  if not WriteFile(FHandle, ARequest[0], Length(ARequest), BytesWritten, nil) then
    raise TModbusException.CreateFmt('Errore scrittura seriale (%d)', [GetLastError]);
  if Integer(BytesWritten) <> Length(ARequest) then
    raise TModbusException.Create('Scrittura seriale incompleta');

  SetLength(RecvBuf, AExpectedLen);
  if not ReadFile(FHandle, RecvBuf[0], AExpectedLen, BytesRead, nil) then
    raise TModbusException.CreateFmt('Errore lettura seriale (%d)', [GetLastError]);

  FLastFrame := GetTickCount64;

  if BytesRead = 0 then
    raise TModbusException.Create('Timeout: nessuna risposta dallo slave (verificare indirizzo/cablaggio)');

  SetLength(RecvBuf, BytesRead);

  // Il frame piu' corto possibile e' l'eccezione: indirizzo, funzione, codice, CRC.
  if BytesRead < 5 then
    raise TModbusException.CreateFmt('Risposta troncata: %d byte', [BytesRead]);

  // La CRC ricevuta va confrontata, non solo calcolata in trasmissione. Se due
  // nodi hanno lo stesso indirizzo rispondono insieme e i frame si sovrappongono:
  // senza questo controllo il risultato corrotto passerebbe per un dato buono.
  RecvCRC := CalcCRC16(RecvBuf, BytesRead - 2);
  if (Lo(RecvCRC) <> RecvBuf[BytesRead - 2]) or (Hi(RecvCRC) <> RecvBuf[BytesRead - 1]) then
    raise TModbusException.Create('CRC errata: risposta corrotta. Possibile collisione ' +
      'fra due slave con lo stesso indirizzo, o disturbi sulla linea');

  // Deve rispondere lo slave interrogato, non un altro.
  if RecvBuf[0] <> ARequest[0] then
    raise TModbusException.CreateFmt('Ha risposto lo slave %d invece del %d',
      [RecvBuf[0], ARequest[0]]);

  // Eccezione Modbus: function code con bit 0x80 settato.
  if (RecvBuf[1] and $80) <> 0 then
    raise TModbusException.CreateFmt('Eccezione Modbus dallo slave %d, codice %d',
      [RecvBuf[0], RecvBuf[2]]);

  Result := RecvBuf;
end;

function TModbusRTU.ReadCoils(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Boolean>;
var
  Req: array[0..7] of Byte;
  CRC: Word;
  Resp: TBytes;
  I: Integer;
  ByteCount: Integer;
begin
  Req[0] := ASlaveAddr;
  Req[1] := $01;
  Req[2] := Hi(AStartAddr); Req[3] := Lo(AStartAddr);
  Req[4] := Hi(AQuantity);  Req[5] := Lo(AQuantity);
  CRC := CalcCRC16(Req, 6);
  Req[6] := Lo(CRC); Req[7] := Hi(CRC);

  ByteCount := (AQuantity + 7) div 8;
  Resp := SendReceive(Req, 5 + ByteCount);

  SetLength(Result, AQuantity);
  for I := 0 to AQuantity - 1 do
    Result[I] := (Resp[3 + (I div 8)] and (1 shl (I mod 8))) <> 0;
end;

function TModbusRTU.ReadDiscreteInputs(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Boolean>;
var
  Req: array[0..7] of Byte;
  CRC: Word;
  Resp: TBytes;
  I: Integer;
  ByteCount: Integer;
begin
  Req[0] := ASlaveAddr;
  Req[1] := $02;
  Req[2] := Hi(AStartAddr); Req[3] := Lo(AStartAddr);
  Req[4] := Hi(AQuantity);  Req[5] := Lo(AQuantity);
  CRC := CalcCRC16(Req, 6);
  Req[6] := Lo(CRC); Req[7] := Hi(CRC);

  ByteCount := (AQuantity + 7) div 8;
  Resp := SendReceive(Req, 5 + ByteCount);

  SetLength(Result, AQuantity);
  for I := 0 to AQuantity - 1 do
    Result[I] := (Resp[3 + (I div 8)] and (1 shl (I mod 8))) <> 0;
end;

function TModbusRTU.ReadHoldingRegisters(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Word>;
var
  Req: array[0..7] of Byte;
  CRC: Word;
  Resp: TBytes;
  I: Integer;
begin
  Req[0] := ASlaveAddr;
  Req[1] := $03;
  Req[2] := Hi(AStartAddr); Req[3] := Lo(AStartAddr);
  Req[4] := Hi(AQuantity);  Req[5] := Lo(AQuantity);
  CRC := CalcCRC16(Req, 6);
  Req[6] := Lo(CRC); Req[7] := Hi(CRC);

  Resp := SendReceive(Req, 5 + AQuantity * 2);

  SetLength(Result, AQuantity);
  for I := 0 to AQuantity - 1 do
    Result[I] := (Resp[3 + I * 2] shl 8) or Resp[4 + I * 2];
end;

function TModbusRTU.ReadInputRegisters(ASlaveAddr: Byte; AStartAddr, AQuantity: Word): TArray<Word>;
var
  Req: array[0..7] of Byte;
  CRC: Word;
  Resp: TBytes;
  I: Integer;
begin
  Req[0] := ASlaveAddr;
  Req[1] := $04;
  Req[2] := Hi(AStartAddr); Req[3] := Lo(AStartAddr);
  Req[4] := Hi(AQuantity);  Req[5] := Lo(AQuantity);
  CRC := CalcCRC16(Req, 6);
  Req[6] := Lo(CRC); Req[7] := Hi(CRC);

  Resp := SendReceive(Req, 5 + AQuantity * 2);

  SetLength(Result, AQuantity);
  for I := 0 to AQuantity - 1 do
    Result[I] := (Resp[3 + I * 2] shl 8) or Resp[4 + I * 2];
end;

procedure TModbusRTU.WriteSingleCoil(ASlaveAddr: Byte; AAddr: Word; AValue: Boolean);
var
  Req: array[0..7] of Byte;
  CRC: Word;
  ValWord: Word;
begin
  if AValue then ValWord := $FF00 else ValWord := $0000;

  Req[0] := ASlaveAddr;
  Req[1] := $05;
  Req[2] := Hi(AAddr); Req[3] := Lo(AAddr);
  Req[4] := Hi(ValWord); Req[5] := Lo(ValWord);
  CRC := CalcCRC16(Req, 6);
  Req[6] := Lo(CRC); Req[7] := Hi(CRC);

  SendReceive(Req, 8); // risposta = eco della richiesta
end;

procedure TModbusRTU.WriteSingleRegister(ASlaveAddr: Byte; AAddr, AValue: Word);
var
  Req: array[0..7] of Byte;
  CRC: Word;
begin
  Req[0] := ASlaveAddr;
  Req[1] := $06;
  Req[2] := Hi(AAddr);  Req[3] := Lo(AAddr);
  Req[4] := Hi(AValue); Req[5] := Lo(AValue);
  CRC := CalcCRC16(Req, 6);
  Req[6] := Lo(CRC); Req[7] := Hi(CRC);

  SendReceive(Req, 8);
end;

procedure TModbusRTU.WriteMultipleCoils(ASlaveAddr: Byte; AStartAddr: Word; const AValues: array of Boolean);
var
  Req: TBytes;
  ByteCount, Quantity, I: Integer;
  CRC: Word;
begin
  Quantity := Length(AValues);
  ByteCount := (Quantity + 7) div 8;
  SetLength(Req, 7 + ByteCount + 2);

  Req[0] := ASlaveAddr;
  Req[1] := $0F;
  Req[2] := Hi(AStartAddr); Req[3] := Lo(AStartAddr);
  Req[4] := Hi(Word(Quantity)); Req[5] := Lo(Word(Quantity));
  Req[6] := ByteCount;

  FillChar(Req[7], ByteCount, 0);
  for I := 0 to Quantity - 1 do
    if AValues[I] then
      Req[7 + (I div 8)] := Req[7 + (I div 8)] or (1 shl (I mod 8));

  CRC := CalcCRC16(Req, 7 + ByteCount);
  Req[7 + ByteCount] := Lo(CRC);
  Req[8 + ByteCount] := Hi(CRC);

  SendReceive(Req, 8); // risposta fissa a 8 byte
end;

end.