commconnect.pas

boomerang library 5.11 internet ed

  fDtrControlDisable   = $00000000;
  fDtrControlEnable    = $00000010;
  fDtrControlHandshake = $00000020;
  fDsrSensitivity      = $00000040;
  fTXContinueOnXoff    = $00000080;
  fOutX                = $00000100;
  fInX                 = $00000200;
  fErrorChar           = $00000400;
  fNull                = $00000800;
  fRtsControl          = $00003000;
  fRtsControlDisable   = $00000000;
  fRtsControlEnable    = $00001000;
  fRtsControlHandshake = $00002000;
  fRtsControlToggle    = $00003000;
  fAbortOnError        = $00004000;
  fDummy2              = $FFFF8000;

constructor TCommHandle.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FhCommDev:= INVALID_HANDLE_VALUE;
  FReadTimeout := 1000;
  FWriteTimeout := 1000;
  FReadBufSize := 4096;
  FWriteBufSize := 2048;
  FMonitorEvents := [evBreak, evCts, evDsr, evError, evRing,
    evRlsd, evRxChar, evRxFlag, evTxEmpty];
  FBaudRate := br9600;
  FParity := paNone;
  FStopbits := sb10;
  FDatabits := da8;
  FOptions := [];
  FFlowControl := fcDefault;
  XonChar := TChar(#17);
  XoffChar := TChar(#19);
  FEvent := TSimpleEvent.Create;
  FCriticalSection := TCriticalSection.Create;
end;

destructor TCommHandle.Destroy;
begin
  inherited Destroy;
  FEvent.Free;
  FCriticalSection.Free;
end;

procedure TCommHandle.SethCommDev(Value: THandle);
begin
  CheckInactive;
  FhCommDev:= Value;
end;

procedure TCommHandle.SetBaudRate(Value: TBaudRate);
begin
  if FBaudRate <> Value then
  begin
    FBaudRate := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetParity(Value: TParity);
begin
  if FParity <> Value then
  begin
    FParity := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetStopbits(Value: TStopbits);
begin
  if FStopBits <> Value then
  begin
    FStopbits := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetDataBits(Value: TDatabits);
begin
  if FDataBits <> Value then
  begin
    FDataBits:=Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetOptions(Value: TCommOptions);
begin
  if FOptions <> Value then
  begin
    FOptions := Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetFlowControl(Value: TFlowControl);
begin
  if FFlowControl <> Value then
  begin
    FFlowControl := Value;
    UpdateDataControlBlock;
  end;
end;

function TCommHandle.GetEventChar;
begin
  Result:= FEventChars[Index];
end;

procedure TCommHandle.SetEventChar;
begin
  if FEventChars[Index] <> Value then
  begin
    FEventChars[Index]:= Value;
    UpdateDataControlBlock;
  end;
end;

procedure TCommHandle.SetReadBufSize(Value: Integer);
begin
  CheckInactive;
  FReadBufSize:= Value;
end;

procedure TCommHandle.SetWriteBufSize(Value: Integer);
begin
  CheckInactive;
  FWriteBufSize:= Value;
end;

procedure TCommHandle.SetMonitorEvents(Value: TCommEventTypes);
begin
  CheckInactive;
  FMonitorEvents := Value;
end;

procedure TCommHandle.Lock;
begin
  FCriticalSection.Enter;
end;

procedure TCommHandle.Unlock;
begin
  FCriticalSection.Leave;
end;

procedure TCommHandle.OpenConn;
{$IFNDEF LINUX}
var
  filetype: DWORD;
{$ENDIF}
begin
  if csDesigning in ComponentState then
    Exit;
  if FhCommDev = INVALID_HANDLE_VALUE then
    ComError2('CreateFile');

  {$IFNDEF LINUX}
  filetype:= GetFileType(FhCommDev);

  { Obviously, a Com connection over Bluetooth is of file type unknown instead of char, may be dependent on the Bluetooth interface in the PC }
  if (filetype <> FILE_TYPE_UNKNOWN) and (filetype <> FILE_TYPE_CHAR) then
  begin
    CloseHandle(FhCommDev);
    FhCommDev:= INVALID_HANDLE_VALUE;
    ComError2('GetFileType');
  end;
  {$ENDIF}
  FEventThread:= TCommEventThread.Create(Self, FhCommDev, FMonitorEvents);
  UpdateCommTimeouts;
  UpdateDCB;
  { allow the process to receive SIGIO }
//  fcntl(FhCommDev, F_SETOWN, getpid());
  { Make the file descriptor asynchronous (the manual page says only O_APPEND and O_NONBLOCK, will work with F_SETFL...) }
//  opts:= fcntl(FhCommDev, F_GETFL);
//  if opts < 0 then
//    ComError2('fcntl F_GETFL');
//  opts:= opts or FASYNC;
//  fcntl(FhCommDev, F_SETFL, opts);

  {$IFNDEF LINUX}
  if not SetupComm(FhCommDev, FReadBufSize, FWriteBufSize) then
    ComError2('SetupComm');
  {$ENDIF}
end;

procedure TCommHandle.CloseConn;
begin
  if FhCommDev <> INVALID_HANDLE_VALUE then
  begin
    with FEventThread do
    begin
      Terminate;
      WaitFor;  // set fFinished:= True;
      Free;     // no WaitFor
    end;
    {$IFDEF LINUX}
    FileClose(Integer(FhCommDev));
    {$ELSE}
    CloseHandle(FhCommDev);
    {$ENDIF}
    FhCommDev:= INVALID_HANDLE_VALUE;
  end;
end;

function TCommHandle.Write({$IFNDEF CLR}{const}var {$ENDIF}Buf{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer): Integer;
var
{$IFNDEF LINUX}
  Overlapped: TOverlapped;
  N: DWORD;
{$ELSE}
  Tick: LongWord;
  P: PChar;
{$ENDIF}
begin
  Lock;
  try
    {$IFDEF LINUX}
    FEventThread.FWriteFlag:= True;
    Tick:= GetTickCount();
    P:= @Buf;
    repeat
      Result:= FileWrite(integer(FhCommDev), P^, Count);
      if Result > 0 then
      begin
        Inc(P, Result);
        Dec(Count, Result);
      end;
    until (Result < 0) or (Count <= 0) or (FWriteTimeout = 0) or (Abs(GetTickCount-Tick) >= FWriteTimeout);
    if THandle(Result) = INVALID_HANDLE_VALUE then
      ComError2('FileWrite');
    {$ELSE}
    {$IFNDEF CLR}
    FillChar(Overlapped, Sizeof(Overlapped), 0);
    {$ENDIF}
    Overlapped.hEvent := FEvent.Handle;
    if not WriteFile(FhCommDev, Buf, Count, N, {$IFNDEF CLR}@{$ENDIF}Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
      ComError2('WriteFile');
    Result:= N;
    if FEvent.WaitFor(FWriteTimeout) <> wrSignaled then
      Result:= 0
    else
     begin
       GetOverlappedResult(FhCommDev, Overlapped, N, False);
       Result:= N;
       FEvent.ResetEvent;
     end;
    {$ENDIF}
  finally
    Unlock;
  end;
end;

function TCommHandle.Read({$IFNDEF CLR}{const}var {$ENDIF}Buf{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer): Integer;
var
{$IFNDEF LINUX}
  Overlapped: TOverlapped;
  N: DWORD;
{$ELSE}
  Tick: LongWord;
  P: PChar;
{$ENDIF}
begin
  Lock;
  try
    {$IFDEF LINUX}
    Tick:= GetTickCount;
    P:= @Buf;
    repeat
      Result:= FileRead(integer(FhCommDev), P^, Count);
      if Result > 0 then
      begin
        Inc(P, Result);
        Dec(Count, Result);
      end;
    until (Result < 0) or (Count <= 0) or (FReadTimeout = 0) or (Abs(GetTickCount-Tick) >= FReadTimeout);

    if THandle(Result) = INVALID_HANDLE_VALUE then
      ComError2('FileRead');
    {$ELSE}
    {$IFNDEF CLR}
    FillChar(Overlapped, Sizeof(Overlapped), 0);
    {$ENDIF}
    Overlapped.hEvent := FEvent.Handle;
    if not ReadFile(FhCommDev, Buf, Count, N, {$IFNDEF CLR}@{$ENDIF}Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
      ComError2('ReadFile');
    Result:= N;
    if FEvent.WaitFor(FReadTimeout) <> wrSignaled then
      Result:= 0
    else
     begin
       GetOverlappedResult(FhCommDev, Overlapped, N, False);
       Result:= N;
       FEvent.ResetEvent;
     end;
    {$ENDIF}
  finally
    Unlock;
  end;
end;

function TCommHandle.InQueCount: Integer;
{$IFNDEF LINUX}
var
  ComStat: TComStat;
  Errors: dword;
{$ENDIF}
begin
  if Active then
  begin
    {$IFDEF LINUX}
    ioctl(integer(FhCommDev), TIOCINQ, @result);
    {$ELSE}
    ClearCommError(FhCommDev, Errors, {$IFNDEF CLR}@{$ENDIF}ComStat);
    Result:= ComStat.cbInQue;
    {$ENDIF}
  end else Result:= -1;
end;

function TCommHandle.OutQueCount: Integer;
{$IFNDEF LINUX}
var
  ComStat: TComStat;
  Errors: dword;
{$ENDIF}
begin
  if Active then
  begin
    {$IFDEF LINUX}
    ioctl(integer(FhCommDev), TIOCOUTQ, @result);
    {$ELSE}
    ClearCommError(FhCommDev, Errors, {$IFNDEF CLR}@{$ENDIF}ComStat);
    Result:= ComStat.cbOutQue;
    {$ENDIF}
  end else Result:= -1;
end;

procedure TCommHandle.HandleCommEvent;
var
  Errors: dword;
{$IFNDEF LINUX}
  ComStat: TComStat;
{$ELSE}
  N: Integer;
{$ENDIF}
begin
{$IFNDEF LINUX}
  ClearCommError(FhCommDev, Errors, {$IFNDEF CLR}@{$ENDIF}ComStat);
{$ENDIF}
  if Status and EV_BREAK > 0 then
    if Assigned(FOnBreak) then FOnBreak(self);
  if Status and EV_CTS > 0 then
    if Assigned(FOnCts) then FOnCts(self);
  if Status and EV_DSR > 0 then
    if Assigned(FOnDsr) then FOnDsr(self);
  if Status and EV_ERR > 0 then
    if Assigned(FOnError) then FOnError(self, Errors); // ???
  if Status and EV_RING > 0 then
    if Assigned(FOnRing) then FOnRing(self);
  if Status and EV_RLSD > 0 then
    if Assigned(FOnRlsd) then FOnRlsd(self);
  if Status and EV_RXCHAR > 0 then
  {$IFDEF LINUX}
  begin
    ioctl(integer(FhCommDev), TIOCINQ, @N);  // safe InQueCount
    if N > 0 then
      DoOnRxChar(N);
  end;
  {$ELSE}
    if ComStat.cbInQue > 0 then
      DoOnRxChar(ComStat.cbInQue);
  {$ENDIF}
  if Status and EV_RXFLAG > 0 then
    if Assigned(FOnRxFlag) then FOnRxFlag(self);
  if Status and EV_TXEMPTY > 0 then
    if Assigned(FOnTxEmpty) then FOnTxEmpty(self);
end;

{$IFNDEF LINUX}
procedure TCommHandle.EscapeComm(Flag: Integer);
begin
  CheckActive;
  if not EscapeCommFunction(FhCommDev, Flag) then
    ComError2('EscapeCommFunction');
end;
{$ENDIF}

{$IFDEF LINUX}
procedure TCommHandle.SetEscBreak;
begin
  if Value then
    tcsendbreak(FhCommDev, 0);
end;
{$ENDIF}

procedure TCommHandle.SetEsc;
{$IFDEF LINUX}
var
  Flags: dword;
const
  Esc: array[1..2] of DWORD = (TIOCM_DTR, TIOCM_RTS);
{$ELSE}
const
  Esc: array[1..4, Boolean] of Integer = ((CLRDTR, SETDTR),(CLRRTS, SETRTS),(CLRBREAK, SETBREAK),(SETXOFF, SETXON));
{$ENDIF}
begin
{$IFDEF LINUX}

  if ioctl(FhCommDev, TIOCMGET, @Flags) = 0 then
  begin
    if Value then
      Flags:= Flags or Esc[Index]
    else
      Flags:= Flags and not Esc[Index];
    ioctl(integer(FhCommDev), TIOCMSET, @Flags);
    if Active and (Index = 3) then
      ioctl(integer(FhCommDev), TCFLSH, TCIOFLUSH);
  end;

{$ELSE}
  EscapeComm(Esc[Index, Value]);
  if Active and (Index = 3) then
    PurgeComm(FhCommDev, PURGE_RXABORT+PURGE_RXCLEAR+PURGE_TXABORT+PURGE_TXCLEAR);
{$ENDIF}
end;

{$IFNDEF LINUX}
function TCommHandle.GetComState(Index: Integer): Boolean;
var
  ComStat: TComStat;
  Errors: DWord;
begin
  Result := false;
  if Active then
  begin
{$IFDEF LINUX}
    ComError(sCommNotSupported);
{$ELSE}
    if not ClearCommError(FhCommDev, Errors, {$IFNDEF CLR}@{$ENDIF}ComStat) then
      ComError2('ClearCommError');
    Result:= TComStateFlag(Index) in ComStat.Flags;
{$ENDIF}
  end;
end;
{$ENDIF}

function TCommHandle.GetModemState(Index: Integer): Boolean;
var
  Flag: dword;
begin
  Result:= False;
  if Active then
  begin
    {$IFDEF LINUX}
    if ioctl(FhCommDev, TIOCMGET, @Flag) < 0 then
      ComError2('ioctl TIOCMGET');
    {$ELSE}
    if not GetCommModemStatus(FhCommDev, Flag) then
      ComError2('GetCommModemStatus');
    {$ENDIF}
    Result:= (Flag and Index) <> 0;
  end;
end;

procedure TCommHandle.UpdateDataControlBlock;
begin
  if Active then
    UpdateDCB;
end;

procedure TCommHandle.UpdateDCB;
{$IFDEF LINUX}
var
  Term: termios;
const
  CommBaudRates: array[TBaudRate] of Integer = (B110, B300, B600, B1200, B2400, B4800, B9600, -1,
      B19200, B38400, -1, B57600, B115200, -1, B230400);
  CommDataBits: array[TDatabits] of Integer = (-1, CS5, CS6, CS7, CS8);
{$ELSE}
const
  CommBaudRates: array[TBaudRate] of Integer = ( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, CBR_14400,
      CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200, CBR_128000, CBR_256000);
  CommOptions: array[TCommOption] of Integer = ({$IFDEF CLR}MandySoft.Vcl.{$ENDIF}CommConnect.fParity, fDsrSensitivity, fTXContinueOnXoff, fErrorChar, fNull);
  CommDataBits: array[TDatabits] of Integer = (4, 5, 6, 7, 8);
  CommParity: array[TParity] of Integer = (NOPARITY, ODDPARITY, EVENPARITY, MARKPARITY, SPACEPARITY);
  CommStopBits: array[TStopbits] of Integer = (ONESTOPBIT, ONE5STOPBITS, TWOSTOPBITS);
var
  OptIndex: TCommOption;
  DCB: TDCB;
{$ENDIF}
begin
  {$IFDEF LINUX}
  tcgetattr(Integer(FhCommDev), term);
  cfmakeraw(term);

  // input flags
//  if evBreak in fMonitorEvents then
//    term.c_iflag:= term.c_iflag or BRKINT and not IGNBRK  // generate global interrupt (signal)
//  else
    term.c_iflag:= term.c_iflag or IGNBRK;  // ignore BREAK

  if evError in fMonitorEvents then