unit KModbus;

interface
{
   Component to do modbus protocol.

   Author:  Vesa Lappalainen
   Date:    28.12.1996
   Changes: 14.01.1997
             +
   Changes: 22.03.1997
             + handling for multiple slaves
             + Critical section
   Changes: 30.09.1997
             + padding changes to use padding class and added Create2
               to initialize padding class
            23.8.2001
             + Write changes to use "global" attribute LastAnswer
               and to return true/false

   Problems: - sometimes dosen't get the whole send string back?
             - no automatic sending to keep line alive
             - no handling for error's

   Can only following functions for Yaskawa inverter:
      3  = Read Holding registers
     16  = Preset Multiple Registers, can set only one or two at the time


     TModBus        -


}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  com485,StdCtrls, kErrors, kParam, kPadBef, WDogS;

type
  TResetWatchDogEvent = procedure of object;

type
  TModbus = class(TComponent)
  private
    FWatchDog : TWatchDogS;
    LastAnswer : ShortString;
    LastReg : integer;
    LastMode : integer;
    LastSlave : integer;
    Cri:TRTLCriticalSection; //t:integer;
    InnSending : integer;

    procedure SetPort(nPortToSet: Integer);
    function GetPort:integer;

  public
    com:TCom485;
    ResetWatchDog : TResetWatchDogEvent;
    constructor Create2(AOwner: TComponent; ipad:TPadBefore);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ErrorShowMessage(const s:String);
    procedure ShowDebug(const s:String);
    function CheckLen(const s:ShortString; n:integer) : boolean;
    function CheckCrc(const s:ShortString) : boolean;
    function CheckModbusError(const s:ShortString; var err:string) : boolean;
    function CheckError(len:integer;var err:string) : boolean;
    function Open: Boolean;
    function Close: Boolean;
    function IsOpen : Boolean;
    function SetReg(slave,r,v:integer;var err:string):integer;
    function SetReg2(slave,r,v1,v2:integer;var err:string):integer;
    function ReadReg(slave,r:integer;var v1:integer;var err:string):boolean;
    function ReadReg2(slave,r:integer; var v1,v2:integer;var err:string):boolean;
    function Write(const s:ShortString;al:integer):boolean;
    function Read:String;  //Temp
    function WDogReset:boolean;
    function WDogPause:boolean;
    function WDogContinue:boolean;
    procedure WDogStartFrom(inv:TObject);
    property WatchDog : TWatchDogS read FWatchDog write FWatchDog;
  published
    property Port: Integer read GetPort write SetPort;
  private
    val1,val2 : integer;
    fpad : TPadBefore;
  public
    ParamNrOfResends : TkParam;
    property pad : TPadBefore read fpad;
  end;

type
  TModBusSlave = class(TObject)
  private
    fmodbus : TModbus;
    fslave : integer;
    FEnabled : boolean;
  protected
  public
    LastError : string;
    constructor Create; 
    function SetReg(r,v:integer):integer;
    function SetReg2(r,v1,v2:integer):integer;
    function ReadReg(r:integer;var v1:integer):boolean;
    function ReadReg2(r:integer; var v1,v2:integer):boolean;
    procedure ShowErrors;
    function Ok : boolean;
  published
    property modbus : TModbus read fmodbus write fmodbus;
    property slave : integer read fslave write fslave;
    property Enabled : boolean read FEnabled write FEnabled;
  end;


implementation
//uses wdog;


type TModbusMsg = record
       nr : integer;
       msg : String;
     end;

const KnownErrors = 4;
const ModbusErrors : Array[0..KnownErrors-1] of TModbusMsg = (
          ( nr:01 ; msg:'Illegal function'          ),
          ( nr:02 ; msg:'Illegal data address'      ),
          ( nr:33 ; msg:'Illegal value'             ),
          ( nr:34 ; msg:'Can not change during run' )
      );

const KnownFunctions = 2;
const ModbusFunctions : Array[0..KnownFunctions-1] of TModbusMsg = (
          ( nr:03 ; msg:'Read register'        ),
          ( nr:16 ; msg:'Write register'       )
      );

type TStr10 = String[10];

var
  ceModbusError,
  ceModbusDebug : TCommError;


function ShowModbusError : boolean;
begin
  Result := ( ceModbusError.show or ceModbusError.log );
end;

function ShowModbusDebug : boolean;
begin
  Result := ( ceModbusDebug.show or ceModbusDebug.log );
end;


function ModBusMsg(n:integer; const Msgs : array of TModbusMsg):ShortString;
var i:integer;
begin
  for i:=0 to High(Msgs) do with Msgs[i] do
    if ( nr = n ) then begin Result := msg; Exit; end;
  Result := 'Unknown';
end;


function crc16_2(puchMsg:PChar;usDataLen:integer):word;
  stdcall; far; external;
{$l crc.obj}

function CountCRCInt(const s:Array of char; n:integer):integer;
var  crc : integer;
begin
  crc := crc16_2(s,n);
  Result := crc;
end;

{------------------------------------------------------------------------------}
function CharToHex(c:char):string;
begin
  Result := Format('%02x',[Ord(c)]);
  if ( Result[1] = ' ' ) then Result[1] := '0';
end;

function StrToHexStr(const s:ShortString):string;
var i:integer;
begin
  Result := '';
  for i:=1 to Length(s) do
    Result := Result + CharToHex(s[i]) + ' ';
end;



{------------------------------------------------------------------------------}
procedure TModbus.ErrorShowMessage(const s:String);
begin
  if ( ShowModbusError )  then
    ceModbusError.Add('Modbus: '
                 + IntToStr(LastSlave)
                 + ' ' + ModbusMsg(LastMode,ModbusFunctions)
                 + '[' + IntToStr(LastReg) + '] '
                 + s
                 + ' : ' + StrToHexStr(LastAnswer)
               );
end;

{------------------------------------------------------------------------------}
procedure TModbus.ShowDebug(const s:String);
begin
  if ( ShowModbusDebug )  then
    ceModbusDebug.Add('Modbus: '
                 + IntToStr(LastSlave)
                 + ' ' + ModbusMsg(LastMode,ModbusFunctions)
                 + '[' + IntToStr(LastReg) + '] '
                 + s
                 + ' : ' + StrToHexStr(LastAnswer)
               );
end;

{------------------------------------------------------------------------------}
function TModbus.CheckLen(const s:ShortString; n:integer) : boolean;
begin
  Result := True;
  if ( Length(s) = n ) then exit;
  if ( ShowModbusError )   then
    ErrorShowMessage('Did not get ' + IntToStr(n) + ' bytes got only: ' +
                IntToStr(Length(s)));
  Result := false;
end;

{------------------------------------------------------------------------------}
function CrcStr(const s:ShortString):TStr10;
var crc : Integer;
begin
  crc := CountCRCInt(s[1],Length(s));
  Result[0] := char(2); // SetLength(Result,2);
  Result[1] := char(crc); Result[2] := char(hi(crc));
end;

{------------------------------------------------------------------------------}
function TModbus.CheckCrc(const s:ShortString) : boolean;
var crc : integer; crcs : string[4];
begin
  Result := True;
  If ( CountCRCInt(s[1],Length(s)) = 0 ) then exit;
  if ( ShowModbusError ) then begin
    crc := CountCRCInt(s[1],Length(s)-2);
    crcs[0] := char(2); // SetLength(Result,2);
    crcs[1] := char(crc); crcs[2] := char(hi(crc));
    ErrorShowMessage('CRC error!'+ ' : ' + StrToHexStr(crcs));
  end;
  Result := false;
end;

{------------------------------------------------------------------------------}
function TModbus.CheckModbusError(const s:ShortString; var err:string) : boolean;
var func : integer;
begin
  Result := True;
  if ( ord(s[2]) and $80 ) = 0  then exit;
  Result := false;
  if ( Not CheckCrc(s) ) then begin err := 'Modbus answ crc error'; exit; end;
  func := ord(s[2]) and $7f;
  err := ModbusMsg(ord(s[3]),ModbusErrors);
  if ( ShowModbusError ) then
    ErrorShowMessage('Slave ' + IntToStr(ord(s[1]))
      + ' function ' + IntToStr(func)
      + ' (' + ModbusMsg(func,ModbusFunctions) + ')'
      + ' code: ' + IntToStr(ord(s[3]))
      + ' ('+ ModbusMsg(ord(s[3]),ModbusErrors) + ')'
      + ': ' + IntToStr(val1) + ',' +IntToStr(val2)
      );

end;

{------------------------------------------------------------------------------}
function TModbus.CheckError(len:integer;var err:string) : boolean;
begin
  Result := True;
  err := '';
  if ( not CheckModbusError(LastAnswer,err) ) then begin
    Result := False; Exit;
  end;
  if ( not CheckLen(LastAnswer,len) ) then begin
    err := 'Modbus len error';
    Result := False; Exit;
  end;
  if ( not CheckCrc(LastAnswer) ) then begin
    err := 'Modbus crc error';
    Result := False; Exit;
  end;
  if ( Ord(LastAnswer[1]) <> LastSlave ) then begin
    err := 'Modbus wrong slave';
    Result := False;
    ErrorShowMessage('wrong slave answer: '+IntToStr(Ord(LastAnswer[1])));
  end;
end;

{------------------------------------------------------------------------------}
{ Component constructor }
constructor TModbus.Create2(AOwner: TComponent; ipad:TPadBefore);
begin
  inherited Create(AOwner);
  com := TCom485.Create(self);
//  com.Port := 3;
  InitializeCriticalSection(Cri);
//  ResetWatchDog := NIL;
  WatchDog := NIL;
  InnSending := 0;
  fpad := ipad;
  if ( fpad = NIL ) then fpad := TPadBefore.Create;
end;

constructor TModbus.Create(AOwner: TComponent);
begin
  Create2(AOwner,TPadBefore.Create);
end;

{------------------------------------------------------------------------------}
{ Component destructor }
destructor TModbus.Destroy;
begin
  if ( Assigned(FWatchDog) ) then FWatchDog.Free;
  DeleteCriticalSection(Cri);
  fpad.free;
  com.Free;             { close the com port (if open) }
  inherited Destroy;	{ destroy ancestor class }
end;

procedure TModbus.WDogStartFrom(inv:TObject);
begin
  if ( Assigned(FWatchDog) ) then WatchDog.StartFrom(inv);
end;

function TModbus.WDogReset:boolean;
begin
  if ( Assigned(FWatchDog) ) then WatchDog.Reset;
  Result := true;
end;

function TModbus.WDogContinue:boolean;
begin
  if ( Assigned(FWatchDog) ) then WatchDog.Continue;
  Result := true;
end;

function TModbus.WDogPause:boolean;
begin
  if ( Assigned(FWatchDog) ) then WatchDog.Pause;
  Result := true;
end;

{------------------------------------------------------------------------------}
function TModbus.IsOpen: Boolean;
begin
  Result := com.IsOpen;
end;

{------------------------------------------------------------------------------}
function TModbus.Open: Boolean;
begin
  Result := com.OpenPort;
end;

{------------------------------------------------------------------------------}
function TModbus.Close: Boolean;
begin
  com.ClosePort;
  Result := true;
end;

{------------------------------------------------------------------------------}
procedure TModbus.SetPort(nPortToSet: Integer);
begin
  com.Port := nPortToSet;
end;

{------------------------------------------------------------------------------}
function TModbus.GetPort:integer;
begin
  Result := com.Port;
end;

function ShortStr(i:integer):TStr10; asm
  mov byte ptr [edx],2
  mov [edx+1],ah
  mov [edx+2],al
end;
{
function ShortStr(i:integer):TStr10;
begin
  Result[0] := char(2); // SetLength(Result,2);
  Result[1] := char(hi(i)); Result[2] := char(i);
end;
}

{------------------------------------------------------------------------------}
function TModbus.Write(const s:ShortString;al:integer):boolean;
var s1,s2 : ShortString; maxt,trials, slave : integer;
begin
  maxt := 0;
  if ( assigned(ParamNrOfResends) ) then
    maxt := trunc(ParamNrOfResends.value);
  trials := 0;
  inc(InnSending);
  if ( InnSending > 2 ) then begin
    InnSending := 2;
  end;
  slave := Ord(s[1]);
 repeat
    pad.CheckPad(slave);
//    ceModbusError.Add('Pad: '+pad.Str);
    Result := false;
    LastAnswer := '';
    if not ( com.Write(s+CrcStr(s)) ) then begin
      inc(trials);
      pad.StartNew(slave);
      continue;
    end;
//    if ( assigned(ResetWatchDog) ) then ResetWatchDog;
    if ( assigned(WatchDog) ) then TWatchDogS(WatchDog).Reset;
    s1 := com.WaitThis(s[1]);
    if ( s1 = s[1] ) then begin  // Pitää olla sama tunnus
      s2[1] := #0;
      s2 := com.ReadN(1);
      if s2 = s[2] then begin    // Joko sama komento tai 1 bitti päällä = virhe
        LastAnswer := s1 + s2 + com.ReadN(al-2);
        Result := Length(LastAnswer) = al;
      end
      else if ( (ord(s2[1]) and $7f) = ord(s[2]) ) then begin
        LastAnswer := s1 + s2 + com.ReadN(3);
        Result := true;
      end
      else LastAnswer := s1 + s2;
    end
    else LastAnswer := s1;
    pad.StartNew(slave);
    inc(trials);
  until ( Result ) or ( trials > maxt  );
  dec(InnSending);
end;

{------------------------------------------------------------------------------}
{
             id fkt 102H lkm=1 tav data  crc
   lähetä :  01 10 01 02 00 01 02  00 06 37 70
             id fk osoite lkm   crc
   vastaus:  01 10 01 02 00 01 A1 F5
}
function TModbus.SetReg(slave,r,v:integer;var err:string):integer;
var s:ShortString;
begin
  EnterCriticalSection(Cri);
  LastMode := 16;
  LastSlave := slave;
  LastReg := r;
  Result := 1;
  val1 := v; val2 := 0;

  s := char(slave) + char(16) + ShortStr(r) + ShortStr(1) + char(2) + ShortStr(v);
  Write(s,8);
  if ( not CheckError(8,err) ) then Result := 0;
  if ( ShowModbusDebug )  then
    ShowDebug('SetReg: ' + IntToStr(v));
  LeaveCriticalSection(Cri);
end;

{------------------------------------------------------------------------------}
function TModbus.SetReg2(slave,r,v1,v2:integer;var err:string):integer;
var s:ShortString;
begin
  EnterCriticalSection(Cri);
  LastMode := 16;
  LastSlave := slave;
  LastReg := r;
  val1 := v1; val2 := v2;
  Result := 0;
  s := char(slave) + char(16) + ShortStr(r) + ShortStr(2) + char(4) +
       ShortStr(v1) + ShortStr(v2);
  Write(s,8);
  if ( not CheckError(8,err) ) then Result := 0;
  if ( ShowModbusDebug )  then
    ShowDebug('SetReg2: ' + IntToStr(v1) + ' ' + IntToStr(v2));
  LeaveCriticalSection(Cri);
end;

{------------------------------------------------------------------------------}
{
                  id fk  rek  lkm    crc
        lähetä :  01 03 01 0B 00 01 F4 34

                        rek  011
                        mem  10BH
                  id fkt #  230V  crc
        takaisin: 01 03 02 08 FC BF C5
                   1  2  3  4  5  6  7

    Jos funktio on väärä, tulee takasin vastaus, jossa on
    id, 7-bit päällä +fkt nro,  virhekoodi + crc

}
function TModbus.ReadReg(slave,r:integer;var v1:integer;var err:string):boolean;
var s:ShortString;
begin
  EnterCriticalSection(Cri);
  LastMode := 3;
  LastSlave := slave;
  LastReg := r;
  Result := false;

  s := char(slave) + char(3) + ShortStr(r) + ShortStr(1);
  if ( Write(s,7) ) then begin
    v1 := 256*Ord(LastAnswer[4]) + Ord(LastAnswer[5]);
    Result := true;
  end
    else v1 := 0;

  if ( not CheckError(7,err) ) then v1 := 0;
  if ( ShowModbusDebug )  then
    ShowDebug('ReadReg: ' + IntToStr(v1));

  LeaveCriticalSection(Cri);
end;

{------------------------------------------------------------------------------}
{
                  id fk  rek  lkm    crc
        lähetä :  01 03 01 0B 00 02 ?? ??

                        rek  011   012
                        mem  10BH  10CH
                  id fkt #  230V  60 Hz,  crc
        takaisin: 01 03 04 08 FC  02 58  ?? ??
                   1  2  3  4  5  6  7   8   9

    Jos funktio on väärä, tulee takasin vastaus, jossa on
    id, 7-bit päällä +fkt nro,  virhekoodi + crc

}
function TModbus.ReadReg2(slave,r:integer; var v1,v2:integer;var err:string):boolean;
var s:ShortString;
begin
  EnterCriticalSection(Cri);
  LastMode := 3;
  LastSlave := slave;
  LastReg := r;

  Result := false;
  s := char(slave) + char(3) + ShortStr(r) + ShortStr(2);
  if ( Write(s,9) ) then begin
    v1 := 256*Ord(LastAnswer[4]) + Ord(LastAnswer[5]);
    v2 := 256*Ord(LastAnswer[6]) + Ord(LastAnswer[7]);
    Result := true;
  end
  else begin
    v1 := 0;
    v2 := 0;
  end;

  if ( not CheckError(9,err) ) then begin
    v1 := 0;
    v2 := 0;
  end;

  if ( ShowModbusDebug )  then
    ShowDebug('ReadReg2: ' + IntToStr(v1) + ' ' + IntToStr(v2));
  LeaveCriticalSection(Cri);
end;

function TModbus.Read:String;  //Temp
begin
  Result := StrToHexStr(LastAnswer); //com.Read;
end;

{------------------------------------------------------------------------------}
{ TModbusSlave ================================================================}
{------------------------------------------------------------------------------}

function TModbusSlave.SetReg(r,v:integer):integer;
begin
  Result := modbus.SetReg(slave,r,v,LastError);
end;

{------------------------------------------------------------------------------}
function TModbusSlave.SetReg2(r,v1,v2:integer):integer;
begin
  Result := modbus.SetReg2(slave,r,v1,v2,LastError);
end;

{------------------------------------------------------------------------------}
function TModbusSlave.ReadReg(r:integer;var v1:integer):boolean;
begin
  Result := modbus.ReadReg(slave,r,v1,LastError);
end;

{------------------------------------------------------------------------------}
function TModbusSlave.ReadReg2(r:integer; var v1,v2:integer):boolean;
begin
  Result := modbus.ReadReg2(slave,r,v1,v2,LastError);
end;

{------------------------------------------------------------------------------}
function TModbusSlave.Ok : boolean;
begin
  Result := ( modbus <> nil ) and ( modbus.IsOpen ) and ( slave >= 0 ) and Enabled;
end;

constructor TModBusSlave.Create;
begin
  FEnabled := true;
end;

procedure TModBusSlave.ShowErrors;
begin
  ceModbusError.ShowErrors;
end;

initialization begin
  RegisterError(ceModbusError ,'me', 'Modbus error'           ,True);
  RegisterError(ceModbusDebug ,'md', 'Modbus debug'           ,True);
end;

end.