unit InterCOMs;

interface

uses
  SysUtils, Classes, Controls, Windows, Messages;

const
  AM_SYNC = WM_USER + $C0;

type
  TInterCOM = class;

  TReadCOMProc = procedure (Data: String) of object;

  TReadThread = class(TThread)
  private
    BytesRead: LongWord;
  protected
    Owner: TInterCOM;
    hStopEvent: THandle;

    osReader, osWriter: OVERLAPPED;
    InBuf: ShortString;
    InLin: String;
    hInLinMutex: THandle;
  protected
    procedure HandleRead;
  public
    procedure Terminate;
    procedure Execute; override;
    constructor Create;
    destructor Destroy; override;
  end;

  TInterCOM = class(TWinControl)
  protected
    FActive: Boolean;
    FCOMNum: LongWord;
    ReadThread: TReadThread;
    hCOM: THandle;
    ComDCB: TDCB;
    COMNum: LongWord;
    FOnReadCOM: TReadComProc;
    procedure AMSync(var Msg: TMessage); message AM_SYNC;
  public
    ReadAsLines: Boolean;
    EOLChar: Char;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Open(COMNum: LongWord): Boolean; overload;
    function Open(NewCOMNum: LongWord; Baud: LongWord): Boolean; overload;
    function SetBaud(Baud: LongWord): Boolean;
    function WriteCOM(Data: String): LongWord;
    function WriteCOMLine(Data: String): LongWord;

    procedure Close;
  published
    property OnReadCOM: TReadCOMProc read FOnReadCOM write FOnReadCOM;
  end;

implementation

function ErrorText(ErrorCode: LongWord): String;
var
  WindowsError: PChar;

begin
  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER + FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrorCode, 0, PChar(@WindowsError), 0, nil);
  Result := WindowsError;
  LocalFree(Cardinal(WindowsError));
end;

function LastErrorText: String;
begin
  Result := ErrorText(GetLastError);
end;

{ TInterCOM }

procedure TInterCOM.AMSync(var Msg: TMessage);
var
  I: Integer;
  EC: Char;
  pBuf: PString;
  Lin: String;

label
  GotLin;

begin
  if Msg.WParam = 0 then begin
    if ReadAsLines then begin
      repeat
        EC := EOLChar;
        pBuf := @ReadThread.InLin;
        WaitForSingleObject(ReadThread.hInLinMutex, INFINITE);
        try
          for I := 1 to Length(pBuf^) do
            if pBuf^[I] = EC then begin
              SetString(Lin, PChar(pBuf^), I - 1);
              pBuf^ := Copy(pBuf^, I + 1, MAXINT);
              goto GotLin;
            end
          ;
          Break;

          GotLin: ;
        finally
          ReleaseMutex(ReadThread.hInLinMutex);
        end;

        if Assigned(FOnReadCOM) then
          FOnReadCOM(Lin)
        ;
      until False;
    end
    else begin
      WaitForSingleObject(ReadThread.hInLinMutex, INFINITE);
      try
        Lin := ReadThread.InLin;
      finally
        ReleaseMutex(ReadThread.hInLinMutex);
      end;
      if Assigned(FOnReadCOM) then
        FOnReadCOM(Lin)
      ;
    end;
  end
  else
    raise EReadError.Create('Failed to read from COM' + IntToStr(COMNum) + ': ' + ErrorText(Msg.WParam))
  ;
end;

procedure TInterCOM.Close;
begin
  ReadThread.Terminate;
  ReadThread.WaitFor;
  ReadThread.Free;
  CloseHandle(hCOM);
  FActive := False;
end;

constructor TInterCOM.Create(AOwner: TComponent);
begin
  inherited;

  if (AOwner is TWinControl) then
    Parent := TWinControl(AOwner)
  ;
  ReadAsLines := True;
  EOLChar := #13;
end;

destructor TInterCOM.Destroy;
begin
  if FActive then Close;

  inherited;
end;

function TInterCOM.Open(COMNum: LongWord): Boolean;
begin
  Result := Open(COMNum, 9600);
end;

function TInterCOM.Open(NewCOMNum, Baud: LongWord): Boolean;
var
  Tim: COMMTIMEOUTS;

begin
  if FActive then Close;

  COMNum := NewCOMNum;

  hCOM := CreateFile(PChar('\\.\COM' + IntToStr(COMNum)), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);

  Result := hCOM <> INVALID_HANDLE_VALUE;
  if not Result then Exit;

  SetupComm(hCOM, 1026, 255); //In buffer = 1026 bytes, out buffer = 255 bytes

  Tim.ReadIntervalTimeout := 5;
  Tim.ReadTotalTimeoutConstant := 0;    //No read total timeout, we want to get all the data that comes our way
  Tim.ReadTotalTimeoutMultiplier := 0;
  Tim.WriteTotalTimeoutConstant := 0;   //No write timeout.
  Tim.WriteTotalTimeoutMultiplier := 0;
  SetCommTimeouts(hCOM, Tim);

  GetCommState(hCOM, ComDCB); //Fill ComDCB with current data
  ComDCB.BaudRate := Baud;
  ComDCB.ByteSize := 7;
  ComDCB.Parity   := EVENPARITY;
  ComDCB.StopBits := ONESTOPBIT;
  ComDCB.Flags := ComDCB.Flags or $1010;
  SetCommState(hCOM, ComDCB);

  ReadThread := TReadThread.Create;
  ReadThread.Owner := Self;
  with ReadThread.osWriter do begin
    Internal := 0;
    InternalHigh := 0;
    Offset := 0;
    OffsetHigh := 0;
    hEvent := CreateEvent(nil, True, False, nil);
  end;
  with ReadThread.osReader do begin
    Internal := 0;
    InternalHigh := 0;
    Offset := 0;
    OffsetHigh := 0;
    hEvent := CreateEvent(nil, True, False, nil);
  end;
  FActive := Result;
  ReadThread.Resume;
end;

function TInterCOM.SetBaud(Baud: LongWord): Boolean;
begin
  Result := False;
  if hCOM = INVALID_HANDLE_VALUE then Exit;
  ComDCB.BaudRate := Baud;
  SetCommState(hCOM, ComDCB);
end;

function TInterCOM.WriteCOM(Data: String): LongWord;
var
  ILen: LongWord;

begin
  Result := 0;
//  if not FActive then Exit;    Debug

  ILen := Length(Data);
  WriteFile(hCOM, Data[1], ILen, ILen, @ReadThread.osWriter);
  GetOverlappedResult(hCOM, ReadThread.osWriter, Result, True);
end;

function TInterCOM.WriteCOMLine(Data: String): LongWord;
begin
  Result := WriteCOM(Data + #13);
end;

{ TReadThread }

constructor TReadThread.Create;
begin
  inherited Create(True);

  FreeOnTerminate := False;
  hStopEvent := CreateEvent(nil, True, False, nil);
  hInLinMutex := CreateMutex(nil, False, nil);
end;

destructor TReadThread.Destroy;
begin
  CloseHandle(hStopEvent);
  CloseHandle(hInLinMutex);

  inherited;
end;

procedure TReadThread.Execute;
var
  Handle: TWOHandleArray;

begin
  repeat
    repeat
      if ReadFile(Owner.hCOM, InBuf[1], 255, BytesRead, @osReader) then //if read completed immediately
        HandleRead
      else if GetLastError <> ERROR_IO_PENDING then begin
        ReturnValue := GetLastError;
        PostMessage(Owner.Handle, AM_SYNC, ReturnValue, 0);
        Exit;
      end
      else
        Break
      ;
    until False;
    Handle[0] := osReader.hEvent;
    Handle[1] := hStopEvent;
    WaitForMultipleObjects(2, @Handle, False, INFINITE);
    if Terminated then Exit;
    HandleRead;
  until False;
end;

procedure TReadThread.HandleRead;
begin
  //InBuf[0] := Char(BytesRead); //Note the length of the incoming string
  WaitForSingleObject(hInLinMutex, INFINITE);
  try
    InLin := InLin + PChar(@InBuf[1]);
  finally
    ReleaseMutex(hInLinMutex);
    ZeroMemory(@InBuf[0], 256);
  end;
  PostMessage(Owner.Handle, AM_SYNC, 0, 0);
end;

procedure TReadThread.Terminate;
begin
  inherited;
  SetEvent(hStopEvent);
end;

end.