unit com485;
(*
   Delphi component for handling RS485 line.
   Purpose: To be used in modbus protocol master.

   Author:  Vesa Lappalainen
   Date:    28.12.1996
   Algorithm for sending:
     1) Set DTR on
     2) Send string
     3) Wait same string received
     4) Set DTR off

   Algorithm for reading:

*)

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,
  kErrors, ExtCtrls, kComp, KParam, kinicomp
  ;      // MessageDlg
{$ifndef VER120}
type LongWord = integer;
type cardinal = integer;
{$endif}

{ Class Definition ------------------------------}


{ ComPort class }

type
  TCom485 = class(TForm)
    Panel1: TPanel;
    ParamBaud: TkParam;
    ParamPort: TkParam;
    ButtonCancel: TButton;
    ButtonOK: TButton;
    GroupBox1: TGroupBox;
    CBSetDTR: TkCheckBox;
    CBClearDTR: TkCheckBox;
    CBSetPrio: TkCheckBox;
    CBWaitTXEmpty: TkCheckBox;
    CBWaitSame: TkCheckBox;
    CBSetRTS: TkCheckBox;
    CBClearRTS: TkCheckBox;
    procedure ButtonOKClick(Sender: TObject);
    procedure ButtonCancelClick(Sender: TObject);

  private  { Private declarations }
    hPort: LongWord; {handle from OpenComm }
    sInTerminator: ShortString; { response terminator string }
    boolExpired: Boolean; { set true when a timeout occurs }
    boolShowErrors: Boolean; { true to enable error boxes }
    boolInUse: Boolean; { true while port is blocked, waiting for response }
    writing : Boolean;
    writeover : TOverlapped;
    readover : TOverlapped;
    { Events (method pointers) user can assign code to these }
    pmOnTimeout: TNotifyEvent;	{ timeout event }

    { functions }
    procedure SetTimeout(lTimeout: LongInt);
    function GetTimeout: LongInt;
    procedure SetBaud(lBaudToSet: LongInt);
    function GetBaud: LongInt;
    function GetPort: Integer;
    procedure SetPort(nPortToSet: Integer);
    function GetInCount: LongInt;
    procedure ErrorShowMessage(const s:String);
    procedure ErrorShowDebug(const s:String);
//    procedure Close; override;

  protected

  public
    { Public declarations }
    IErrors:  LongWord;
    Stat : TComStat;
    Errors : TErrors;
    function IsOpen: Boolean;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function OpenPort: Boolean;
    function Write(const sData: ShortString): Boolean;
//    function Read: ShortString;
    function ReadN(n:Cardinal): ShortString;
    function ReadThis(const s:ShortString): ShortString;
    function WaitThis(const s:ShortString): ShortString;
    function ReadOne: ShortString;
    procedure Flush;
    procedure ClosePort;

  published { Published declarations }
    { timeout for waiting for a response, in mS }
    property ResponseTime: LongInt read GetTimeout write SetTimeout;
    { timeout event }
    property OnTimeout: TNotifyEvent read pmOnTimeout write pmOnTimeout;
    { flag set when a timeout occured }
    property TimedOut: Boolean read boolExpired;
    { baud rate }
    property Baud: LongInt read GetBaud write SetBaud;
    { COM port }
    property Port: Integer read GetPort write SetPort;
    { number of characters received }
    property InCount: LongInt read GetInCount;
    { string to signal end of input from external device }
    property EndOfResponse: ShortString read sInTerminator write sInTerminator;
    { flag to enable showing error message boxes }
    property ShowErrors: Boolean read boolShowErrors write boolShowErrors;
    { flag indicating if port is open }
    property Opened: Boolean read IsOpen;
    { flag indication if port is blocked }
    property InUse: Boolean read boolInUse;
end;

function StrToHexStr(const s:string):string;

procedure Register;

//var
//  TCom485: TTCom485;

implementation

// procedure TCom485.Close; begin inherited close; end;

{$R *.DFM}

{ Register the component with the Delphi IDE }
procedure Register;
begin
  RegisterComponents('Kave2000', [TCom485]);
end;

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

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


{------------------------------------------------------------------------------}
procedure TCom485.ErrorShowMessage(const s:String);
begin
  if ( Errors <> NIL )  and ( Errors.ShowComError )  then
    Errors.Add(ceCommError,format('Com485-%d:',[Port]) +s);
end;

{------------------------------------------------------------------------------}
procedure TCom485.ErrorShowDebug(const s:String);
begin
  if ( Errors <> NIL ) and ( Errors.ShowComDebug ) then
    Errors.Add(ceCommDebug,format('Com485-%d:',[Port]) +s);
end;

{ Component constructor }
constructor TCom485.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  { set default property values }
  hPort := INVALID_HANDLE_VALUE; { invalidate to start }
  Errors := nil;
  boolExpired := False;
  boolShowErrors := True;
  boolInUse := False;
  pmOnTimeout := NIL;
  writing := False;
  writeover.hEvent := 0; //CreateEvent(NIL,TRUE,FALSE,'WriteEvent');
  readover.hEvent := 0; //CreateEvent(NIL,TRUE,FALSE,'WriteEvent');
end;

{ Component destructor }
destructor TCom485.Destroy;
begin
  ClosePort;                { close the com port (if open) }
  inherited Destroy;        { destroy ancestor class }
end;


procedure TCom485.SetTimeout(lTimeout: LongInt);
begin
{ Tekemättä }
end;

{ Get the current timeout setting }
function TCom485.GetTimeout: LongInt;
begin
  Result := 0;
end;

{ Return True if port is open }
function TCom485.IsOpen: Boolean;
begin
  //if hPort <> INVALID_HANDLE_VALUE then Result := True else Result := False;
  Result := (hPort <> INVALID_HANDLE_VALUE);
end;

function TCom485.GetBaud: LongInt;
begin
  Result := ParamBaud.AsInteger;
end;

{ Set the baud rate property }
procedure TCom485.SetBaud(lBaudToSet: LongInt);
begin
  if lBaudToSet = ParamBaud.Value then exit;
  ParamBaud.Value := lBaudToSet;
  if IsOpen then begin ClosePort; OpenPort; end;
end;

{ Get the Port property }
function TCom485.GetPort: Integer;
begin
  Result := ParamPort.AsInteger;
end;

{ Set the Port property }
procedure TCom485.SetPort(nPortToSet: Integer);
begin
  if nPortToSet = ParamPort.AsInteger then exit;
  ParamPort.AsInteger := nPortToSet;
  if IsOpen then begin ClosePort; OpenPort; end;
end;

{ Opens the COM port, returns True if ok }
function TCom485.OpenPort: Boolean;
var
	sCom: String;
	dcbPort: TDCB; {device control block }
	boolAbort: Boolean;
	sErrMsg: ShortString;
        tmouts : TCommTimeouts;
begin
   { init }
   Result := False;
   boolAbort := True;
   sErrMsg := '';
   //boolInUse := True;

   if IsOpen then ClosePort;

   { try to open the port }
   repeat
     sCom := 'COM' + IntToStr(Port);
     hPort := CreateFile(PChar(sCom), GENERIC_READ or GENERIC_WRITE, 0, nil,
                             OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, LongInt(0));
//                             OPEN_EXISTING, FILE_FLAG_OVERLAPPED, LongInt(0));

     if ( Not IsOpen ) and boolShowErrors then begin
       if MessageDlg('Error opening COM' + IntToStr(Port) + ': ' + sErrMsg,
           mtWarning, [mbAbort, mbRetry], 0) = idAbort then
         boolAbort := True
       else
         boolAbort := False;
       end;
     if ( Not IsOpen ) then
       ErrorShowMessage('Can not open port ' + IntToStr(Port));

   until ( IsOpen ) or (boolAbort = True);

   { set the baud rate and other parameters }
   if ( Not IsOpen ) then exit;
   if ( Not GetCommState(hPort, dcbPort) ) then exit;
   { fill in the fields of the structure }
   dcbPort.BaudRate := Baud;
   dcbPort.ByteSize := 8;
   dcbPort.Parity := NOPARITY;
   dcbPort.StopBits := ONESTOPBIT;
   dcbPort.Flags := 1; // 0
   { flag bit fields:
   dcb_Binary, dcb_Parity, dcb_OutxCtsFlow, dcb_fOutxDsrFlow,
   dcb_fOutX, dcb_fInX, dcb_DtrFlow, dcb_RtsFlow
   }
   if not SetCommState(hPort, dcbPort) then begin
     MessageDlg('Error setting COM' + IntToStr(Port) + ': ' + sErrMsg,
         mtWarning, [mbAbort, mbRetry], 0);
     Exit;
   end;

   ClearCommError(hPort,IErrors,@Stat);

   GetCommTimeouts(hPort,tmouts);
    tmouts.ReadIntervalTimeout := 100;

    tmouts.ReadTotalTimeoutMultiplier := 20;

    tmouts.ReadTotalTimeoutConstant := 500;

    tmouts.WriteTotalTimeoutMultiplier := 20;
    tmouts.WriteTotalTimeoutConstant := 500;

   SetCommTimeouts(hPort,tmouts);
   GetCommTimeouts(hPort,tmouts);
   { return True if handle is valid }
   Result := IsOpen;
   //boolInUse := False;

end;

{ Close the COM port }
procedure TCom485.ClosePort;
begin
  if IsOpen then CloseHandle(hPort);
  hPort := INVALID_HANDLE_VALUE;
  //boolInUse := False;
end;

(*
function CChar(const s:ShortString):PChar;
begin
  Result := @s[1];
end;
*)

{ Write a string out the COM port, return true if all chars written }
function TCom485.Write(const sData: ShortString): Boolean;
var
  dwCharsWritten: DWord;
  event : cardinal;
  handle : integer;
  oldprio : integer;
  send : string;
//  oldprio : TThreadPriority;
begin
  { init }
  //boolInUse := True;
  dwCharsWritten := 0;
  Result := False; { default to error return }

  if Not IsOpen then exit;
  if writing then begin
    ErrorShowMessage('Already writing! -- operation aborted');
    Exit;
  end;
  writing := true;
  handle := 0;
  oldprio := 0;
  ErrorShowDebug('Write: '+StrToHexStr(sData));
  if ( CBSetDTR.Checked )      then EscapeCommFunction(hPort,SETDTR);
  if ( CBSetRTS.Checked )      then EscapeCommFunction(hPort,SETRTS);
  if ( CBWaitTXEmpty.Checked ) then SetCommMask(hPort,EV_TXEMPTY);
  if ( CBSetPrio.Checked )     then begin
    handle := GetCurrentThread;
    oldprio := GetThreadPriority(handle);
    Flush;
    SetThreadPriority(handle,THREAD_PRIORITY_TIME_CRITICAL);
  end
  else Flush;
  send := sData;// + #$00 + #$00 + #$00 ;
  WriteFile(hPort, send[1], Length(send), dwCharsWritten, nil);
//  WriteFile(hPort, sData[1], Length(sData), dwCharsWritten, @writeover);
//  WaitForSingleObject(hPort,2000);
  if dwCharsWritten = Length(sData) then Result := True
  else begin
    ErrorShowMessage(Format('Tried to write %d, could write %d:',[Length(sData),dwCharsWritten]));
    ClearCommError(hPort,IErrors,@Stat);
    IErrors := GetLastError;
  end;


//    Sleep(1);
//  WaitCommEvent(hPort,event,@writeover);
//  WaitForSingleObject(hPort,2000);
  if ( CBWaitTXEmpty.Checked ) then begin
    WaitCommEvent(hPort,event,NIL);
    SetCommMask(hPort,0);
  end;
  if ( CBWaitSame.Checked ) then ReadThis(sData);
//    PurgeComm(hPort, PURGE_RXCLEAR); // ???
  if ( CBClearDTR.Checked ) then     EscapeCommFunction(hPort,CLRDTR);
  if ( CBClearRTS.Checked ) then     EscapeCommFunction(hPort,CLRRTS);
  if ( CBSetPrio.Checked )  then SetThreadPriority(handle,oldprio);
  writing := false;
end;

{ Return the number of bytes waiting in the queue }
function TCom485.GetInCount: LongInt;
var
  statPort: TCOMSTAT;
  dwErrorCode: DWord;
begin
  Result := 0;
  if Not IsOpen then exit;

  ClearCommError(hPort, dwErrorCode, @statPort);
  Result := statPort.cbInQue;
end;

//-----------------------------------------------------------------------------
// Reads a string from the port, puts it into pchBuffer, returns the
// number of characters read
//-----------------------------------------------------------------------------
{$ifdef READ}
function TCom485.Read: ShortString;
var cbCharsAvailable, cbCharsRead: DWord;
    boolExit: Boolean;
    sBuffer: ShortString;
begin
  { init }
  Result := '';

{ check boolInUse in case of rentrancy }
  if boolInUse then begin
    if boolShowErrors then ErrorShowMessage('Port is in use -- operation aborted');
    Exit;
  end;

  if Not IsOpen then exit;
  boolInUse := True;

{ if no terminator is defined, simply read any available data and return }
  if Length(sInTerminator) = 0 then begin
//      cbCharsAvailable := GetInCount;
    cbCharsAvailable := 200;
    if cbCharsAvailable > 0 then begin
      SetLength(Result, cbCharsAvailable + 1); { allocate space }
      ReadFile(hPort, sBuffer[1], cbCharsAvailable, cbCharsRead, nil);
      SetLength(sBuffer, cbCharsRead); { adjust length }
      Result := sBuffer;
    end;
  end
  else { a terminator is defined, so read port until terminator found or timed out }
  begin
    boolExit := False;
    repeat
      boolExpired := False;

      { loop until timeout or terminator recieved }
      repeat
        cbCharsAvailable := GetInCount;
        if cbCharsAvailable > 0 then begin
          if cbCharsAvailable >= Length(sBuffer) then
                  SetLength(sBuffer, cbCharsAvailable + 1); { allocate space }

          ReadFile(hPort, sBuffer[1], cbCharsAvailable, cbCharsRead, nil);

          { append chars read to end of result buffer }
          Result := Result + Copy(sBuffer, 0, cbCharsRead);
        end;

      until (boolExpired) or (boolExit);


      { If timed out, then give user a chance to retry }
      if boolExpired and boolShowErrors then
      begin
        if MessageDlg('Timeout waiting for response.', mtWarning,
           [mbAbort, mbRetry], 0) = idAbort then boolExit := True;
      end;

    until boolExit = True;
  end;
  boolInUse := False;
end;
{$endif}

function TCom485.ReadN(n:Cardinal): ShortString;
var sBuffer: ShortString;
    cbCharsRead: Cardinal;
begin
  Result := '';
  if boolInUse then begin
    if boolShowErrors then ErrorShowMessage('Port is in use -- operation aborted');
    Exit;
  end;

  if not IsOpen then exit;

  boolInUse := True;
  ReadFile(hPort, sBuffer[1], n, cbCharsRead, NIL);
//  ReadFile(hPort, sBuffer[1], n, cbCharsRead, @readover);
//  WaitForSingleObject(hPort,200);
  SetLength(sBuffer, cbCharsRead); { adjust length }
  Result := sBuffer;
  if ( cbCharsRead <> n ) then begin
    if boolShowErrors then
      ErrorShowMessage(Format('Wait %d got %d:',[n,cbCharsRead])+StrToHexStr(Result));
  end;
  ErrorShowDebug('Read : '+StrToHexStr(Result));

  boolInUse := False;
end;

function TCom485.ReadThis(const s:ShortString): ShortString;
var sr,se : ShortString; i : integer;
begin
  Result := ReadN(Length(s));
  if ( Result = s ) then exit;
  sr := Result;
  for i:=1 to Length(s) div 2 do begin
    delete(sr,1,1);
    if Pos(sr,s) = 1 then begin
      se := ReadN(i);
      Result := sr + se;
      if ( Result = s ) then exit;
      break;
    end;
  end;
  if boolShowErrors then
    ErrorShowMessage('Send waiting: '+StrToHexStr(s)+' got: '+StrToHexStr(Result));
end;

function TCom485.WaitThis(const s:ShortString): ShortString;
var sr,se,old : ShortString;
begin
  Result := s;
  sr := '';
  old := '';
  se := ReadN(Length(s));
  while ( se <> '' ) do begin
    sr := sr + se;
    old := old + se;
    if ( sr = s ) then Exit;
    Delete(sr,1,1);
    se := ReadN(1);
  end;

  Result := copy(old,1,10);
  if boolShowErrors then
    ErrorShowMessage('Waiting this: '+StrToHexStr(s)+' got: '+StrToHexStr(Result));
end;


function TCom485.ReadOne: ShortString;
var cbCharsAvailable, cbCharsRead: DWord;
begin
  { init }
  Result := '';

{ check boolInUse in case of rentrancy }
  if boolInUse then begin
    if boolShowErrors then ErrorShowMessage('Port is in use -- operation aborted');
    Exit;
  end;

  if not IsOpen then exit;

  boolInUse := True;
  cbCharsAvailable := 1;
  ReadFile(hPort, Result[1], cbCharsAvailable, cbCharsRead, nil);
  SetLength(Result, cbCharsRead); { adjust length }
  boolInUse := False;
end;


{ Flush the port by reading any characters in the queue }
procedure TCom485.Flush;
begin
  if Not IsOpen then exit;
  PurgeComm(hPort, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
end;


procedure TCom485.ButtonOKClick(Sender: TObject);
begin
//  if ( IsOpen ) then begin ClosePort; OpenPort; end;
  OpenPort;
  Close;
end;

procedure TCom485.ButtonCancelClick(Sender: TObject);
begin
  Close;
end;




end.