commconnect.pas

boomerang library 5.11 internet ed

(* CommConnect - comm connection components
 * Copyright (C) 2003 Tomas Mandys-MandySoft
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA  02111-1307  USA
 *)

{ URL: http://www.2p.cz }

unit {$IFDEF CLR}MandySoft.Vcl.{$ENDIF}CommConnect;

{ CommConnect.htx }

interface
uses
  Classes, SysUtils, Connect {$IFDEF LINUX}, Libc, Types, KernelIoctl{$ELSE}, Windows{$ENDIF}, SyncObjs;

{$IFDEF LINUX}
const
  INFINITE = $FFFFFFFF;
  INVALID_HANDLE_VALUE = THandle(-1);
{$IF NOT DECLARED(_PATH_LOCK)}
  _PATH_LOCK = '/var/lock';
{$IFEND}
{$ENDIF}

type
  TCommEvent = procedure(Sender: TObject; Status: dword) of object;
  TCommEventType = (evBreak, evCts, evDsr, evError, evRing, evRlsd, evRxChar, evRxFlag, evTxEmpty);
  TCommEventTypes = set of TCommEventType;

  TBaudrate =(br110, br300, br600, br1200, br2400, br4800, br9600, br14400,
    br19200, br38400, br56000, br57600, br115200, br128000, br256000);
  TParity = (paNone, paOdd, paEven, paMark, paSpace);
  TStopbits = (sb10, sb15, sb20);
  TDatabits=(da4, da5, da6, da7, da8);
  TFlowControl = (fcNone, fcCTS, fcDTR, fcSoftware, fcDefault);

  TCommOption = (coParityCheck, coDsrSensitivity, coIgnoreXOff,
    coErrorChar, coNullStrip);
  TCommOptions = set of TCommOption;

  TCommErrorEvent = procedure(Sender: TObject; Errors: Integer) of object;

  TCommHandle = class;

  TCommEventThread = class(TThread)
  private
    FCommHandle: THandle;
    FEventMask: dWord;
    FComm: TCommHandle;
  {$IFDEF LINUX}
    FEvents: TCommEventTypes;
    FCriticalSection: TCriticalSection;
    FWriteFlag: Boolean;
    FModemFlags: Integer;
  {$ELSE}
    FEvent: TSimpleEvent;
  {$ENDIF}
  protected
    procedure Execute; override;
    procedure Terminate;
    procedure DoOnSignal;
  public
    constructor Create(aComm: TCommHandle; Handle: THandle; Events: TCommEventTypes);
    destructor Destroy; override;
  end;

  TCommHandle = class(TCommunicationConnection)
  private
    FhCommDev: THandle;
    FBaudrate: TBaudrate;
    FParity: TParity;
    FStopBits: TStopBits;
    FDataBits: TDataBits;
    FFlowControl: TFlowControl;
    FOptions: TCommOptions;
    FReadTimeout: Integer;
    FWriteTimeout: Integer;
    FReadBufSize: Integer;
    FWriteBufSize: Integer;
    FMonitorEvents: TCommEventTypes;
    FEventChars: array[1..5] of Char;  // in .NET is in TDCB declared as CHAR
    FEvent: TSimpleEvent;
    FCriticalSection: TCriticalSection;
    FEventThread: TCommEventThread;
    FOnBreak: TNotifyEvent;
    FOnCts: TNotifyEvent;
    FOnDsr: TNotifyEvent;
    FOnError: TCommErrorEvent;
    FOnRing: TNotifyEvent;
    FOnRlsd: TNotifyEvent;
    FOnRxFlag: TNotifyEvent;
    FOnTxEmpty: TNotifyEvent;
    procedure SethCommDev(Value: THandle);
    procedure SetBaudRate(Value: TBaudRate);
    procedure SetParity(Value: TParity);
    procedure SetStopbits(Value: TStopBits);
    procedure SetDatabits(Value: TDatabits);
    procedure SetOptions(Value: TCommOptions);
    procedure SetFlowControl(Value: TFlowControl);
    function GetEventChar(Index: Integer): Char;
    procedure SetEventChar(Index: Integer; Value: Char);
    procedure SetReadBufSize(Value: Integer);
    procedure SetWriteBufSize(Value: Integer);
    procedure SetMonitorEvents(Value: TCommEventTypes);
{$IFNDEF LINUX}
    function GetComState(Index: Integer): Boolean;
{$ENDIF}
    function GetModemState(Index: Integer): Boolean;
    procedure SetEsc(Index: Integer; Value: Boolean);
{$IFDEF LINUX}
    procedure SetEscBreak(Value: Boolean);
{$ENDIF}
    procedure UpdateCommTimeouts;
    procedure UpdateDataControlBlock;
  protected
    procedure OpenConn; override;
    procedure CloseConn; override;
    procedure UpdateDCB; virtual;
{$IFNDEF LINUX}
    procedure EscapeComm(Flag: Integer);
{$ENDIF}
    procedure HandleCommEvent(Status: dword); virtual;
    function Write({$IFNDEF CLR}{const}var {$ENDIF}Buf{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer): Integer; override;
    function Read({$IFNDEF CLR}{const}var {$ENDIF}Buf{$IFDEF CLR}: TBytes{$ENDIF}; Count: Integer): Integer; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ComError2(const aFunc: string);
    property hCommDev: THandle read FhCommDev write SethCommDev;
    function InQueCount: Integer; override;
    function OutQueCount: Integer;
    procedure Lock;
    procedure Unlock;
    procedure PurgeIn; override;
    procedure PurgeOut; override;
{$IFNDEF LINUX}
    property CtsHold: Boolean index Integer(fCtlHold) read GetComState;
    property DsrHold: Boolean index Integer(fDsrHold) read GetComState;
    property RlsdHold: Boolean index Integer(fRlsHold) read GetComState;
    property XoffHold: Boolean index Integer(fXoffHold) read GetComState;
    property XOffSent: Boolean index Integer(fXoffSent) read GetComState;
    property Eof: Boolean index Integer(fEof) read GetComState;
{$ENDIF}
    {Comm escape functions}
    property DTRState: Boolean index 1 write SetEsc;
    property RTSState: Boolean index 2 write SetEsc;
{$IFDEF LINUX}
    property BreakState: Boolean write SetEscBreak;
{$ELSE}
    property BreakState: Boolean index 3 write SetEsc;
{$ENDIF}
    property XONState: Boolean index 4 write SetEsc;
    {Comm status flags}
    property CTS: Boolean index Integer({$IFDEF LINUX}TIOCM_CTS{$ELSE}MS_CTS_ON{$ENDIF}) read GetModemState;
    property DSR: Boolean index Integer({$IFDEF LINUX}TIOCM_DSR{$ELSE}MS_DSR_ON{$ENDIF}) read GetModemState;
    property RING: Boolean index Integer({$IFDEF LINUX}TIOCM_RNG{$ELSE}MS_RING_ON{$ENDIF}) read GetModemState;
    property RLSD: Boolean index Integer({$IFDEF LINUX}TIOCM_CAR{$ELSE}MS_RLSD_ON{$ENDIF}) read GetModemState;
  published
    property Baudrate: TBaudrate read FBaudrate write SetBaudrate default br9600;
    property Parity: TParity read FParity write SetParity default paNone;
    property Stopbits: TStopbits read FStopbits write SetStopbits default sb10;
    property Databits: TDatabits read FDatabits write SetDatabits default da8;
    property Options: TCommOptions read FOptions write SetOptions;
    property DontSynchronize;
    property FlowControl: TFlowControl read FFlowControl write SetFlowControl default fcDefault;
    property XonChar: Char index 1 read GetEventChar write SetEventChar default TChar(#17);
    property XoffChar: Char index 2 read GetEventChar write SetEventChar default TChar(#19);
    property ErrorChar: Char index 3 read GetEventChar write SetEventChar default TChar(#0);
    property EofChar: Char index 4 read GetEventChar write SetEventChar default TChar(#0);
    property EvtChar: Char index 5 read GetEventChar write SetEventChar default TChar(#0);
    property ReadTimeout: Integer read FReadTimeout write FReadTimeout default 1000;
    property WriteTimeout: Integer read FWriteTimeout write FWriteTimeout default 1000;
    property ReadBufSize: Integer read FReadBufSize write SetReadBufSize default 4096;
    property WriteBufSize: Integer read FWriteBufSize write SetWriteBufSize default 2048;
    property MonitorEvents: TCommEventTypes read FMonitorEvents write SetMonitorEvents;
    property OnBreak: TNotifyEvent read FOnBreak write FOnBreak;
    property OnCts: TNotifyEvent read FOnCts write FOnCts;
    property OnDsr: TNotifyEvent read FOnDsr write FOnDsr;
    property OnRing: TNotifyEvent read FOnRing write FOnRing;
    property OnRlsd: TNotifyEvent read FOnRlsd write FOnRlsd;
    property OnError: TCommErrorEvent read FOnError write FOnError;
    property OnRxChar;
    property OnRxFlag: TNotifyEvent read FOnRxFlag write FOnRxFlag;
    property OnTxEmpty: TNotifyEvent read FOnTxEmpty write FOnTxEmpty;
  end;

  TComm = class(TCommHandle)
  private
    FDeviceName: string;
    procedure SetDeviceName(const Value: string);
  protected
    procedure OpenConn; override;
    procedure CloseConn; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property DeviceName: string read FDeviceName write SetDeviceName;
  end;

  TModemRxCommandEvent = procedure (Sender: TObject; aRx: string) of object;

  TModem = class(TComm)
  private
    fCommands: TStrings;
    FDelayBeforeInit: Integer;
    FDelayAfterInit: Integer;
    FConnectTimeout: Integer;
    FResponseTimeout: Integer;
    fReceivedBuffer: TString;
    FCommandEvent: TSimpleEvent;
    fCapturing: Boolean;
    fIsMakingCall: Boolean;
    fCancel: Boolean;
    FOnRxCommand: TModemRxCommandEvent;
    function GetCommand(Index: Integer): TString;
    procedure SetCommand(Index: Integer; Value: TString);
    function SendAndReceive(aSend: TString; aResponses: array of TString; aTimeout: Integer; var aRespCode: Integer): Boolean;
  protected
    procedure OpenConn; override;
    procedure CloseConn; override;
    procedure DoOnRxChar(Count: Integer); override;
  public
    property IsMakingCall: Boolean read fIsMakingCall;
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure Drop;
  published
    property cInit: TString index 0 read GetCommand write SetCommand;
    property DelayBeforeInit: Integer read FDelayBeforeInit write FDelayBeforeInit;
    property DelayAfterInit: Integer read FDelayAfterInit write FDelayAfterInit;
    property ResponseTimeout: Integer read FResponseTimeout write FResponseTimeout;
    property ConnectTimeout: Integer read FConnectTimeout write FConnectTimeout;
    property rInit: TString index 1 read GetCommand write SetCommand;
    property cDial: TString index 2 read GetCommand write SetCommand;
    property rConnect: TString index 3 read GetCommand write SetCommand;
    property rBusy: TString index 4 read GetCommand write SetCommand;
    property rNoCarrier: TString index 5 read GetCommand write SetCommand;
    property rNoDialtone: TString index 6 read GetCommand write SetCommand;
    property cHangUp: TString index 7 read GetCommand write SetCommand;
    property rHangUp: TString index 8 read GetCommand write SetCommand;
    property PhoneNumber: TString index 9 read GetCommand write SetCommand;
    property OnRxCommand: TModemRxCommandEvent read fOnRxCommand write fOnRxCommand; { COM thread }
  end;

  EComError = class(EConnectError)
  end;

procedure Register;

function Int2BaudRate(BR1: Longint; var BR: TBaudRate): Boolean;
function BaudRate2Int(BR: TBaudRate): Longint;

function Event_WaitFor(fEvent: TEvent; aTimeout: LongWord): TWaitResult;
{$IFDEF LINUX}
procedure AcquireLock(DeviceName: string);
procedure ReleaseLock(DeviceName: string);
function GetTickCount(): LongWord; {ms}
{$ENDIF}

implementation

resourcestring
  sCommError = 'Error %d %s in function: %s';
  sModemNoResponse = 'No response on %s';
  sModemNoDialTone = 'No dial tone';
  sModemBusy = 'Line is busy';
  sModemNoConnection = 'Cannot connect';
  {$IFDEF LINUX}
  sDeviceLocked = 'Device "%s" is locked';
  sCommErr4Databits = 'Four databits not supported';
  sCommNotSupported= 'Not supported in linux';
  sCommErrDatabits = 'Databits settings not supported';
  sCommErrParity = 'Baudrate settings not supported';
  sCommErrBaudrate = 'Baudrate settings not supported';
  sCommErrStopBits = 'Stopbits settings not supported';
  sCommErrFlow = 'Flow control settings not supported';
  {$ENDIF}

const
{$IFDEF LINUX}
  DefaultDeviceName = _PATH_TTY+'S0';
const
  EV_RXCHAR = 1;        { Any Character received }
  EV_RXFLAG = 2;        { Received certain character }
  EV_TXEMPTY = 4;       { Transmitt Queue Empty }
  EV_CTS = 8;           { CTS changed state }
  EV_DSR = $10;         { DSR changed state }
  EV_RLSD = $20;        { RLSD changed state }
  EV_BREAK = $40;       { BREAK received }
  EV_ERR = $80;         { Line status error occurred }
  EV_RING = $100;       { Ring signal detected }
  EV_PERR = $200;       { Printer error occured }
var
  CommEventThreadList: TList;
{$ELSE}
  DefaultDeviceName = 'Com2';
{$ENDIF}

procedure ComError(const Msg: string);
begin
  raise EComError.Create(Msg);
end;

procedure TCommHandle.ComError2(const aFunc: string);
var
  S: string;
const
 CRLF = TString(#13#10);
begin
{$IFDEF LINUX}
  S:= '';
{$ELSE}
  S:= SysErrorMessage(GetLastError);
(*
  SetLength(S, 1023);
  SetLength(S, FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError, 0, PChar(S), Length(S), nil));
  if (S <> '') then
    if Pos(CRLF, S) = (Length(S) - 1) then
      S := Copy(S, 1, Length(S) - 2);
*)
{$ENDIF}
  ComError(Format(sCommError, [GetLastError, S, aFunc]));
end;

{$IFNDEF LINUX}
const
  CommEventList: array[TCommEventType] of dword = (EV_BREAK, EV_CTS, EV_DSR, EV_ERR, EV_RING, EV_RLSD, EV_RXCHAR, EV_RXFLAG, EV_TXEMPTY);
{$ENDIF}

constructor TCommEventThread.Create(aComm: TCommHandle; Handle: THandle; Events: TCommEventTypes);
{$IFNDEF LINUX}
var
  EvIndex: TCommEventType;
  AttrWord: dword;
{$ENDIF}
begin
  FCommHandle := Handle;
  {$IFDEF LINUX}
  CommEventThreadList.Add(Self);
  FCriticalSection:= TCriticalSection.Create;
  ioctl(FCommHandle, TIOCMGET, @FModemFlags);
  FEvents:= Events;
  {$ELSE}
  AttrWord := $0;
  for EvIndex := Low(TCommEventType) to High(TCommEventType) do
    if EvIndex in Events then AttrWord := AttrWord or CommEventList[EvIndex];
  SetCommMask(FCommHandle, AttrWord);
  FEvent := TSimpleEvent.Create;
  {$ENDIF}
  FComm:= aComm;
  inherited Create(False);
  {$IFNDEF LINUX}
  Priority := tpHigher;
  {$ENDIF}
end;

destructor TCommEventThread.Destroy;
{$IFDEF LINUX}
var
  I: Integer;
{$ENDIF}
begin
  {$IFDEF LINUX}
  FCriticalSection.Free;
  I:= CommEventThreadList.IndexOf(Self);
  if I >= 0 then
    CommEventThreadList.Delete(I);
  {$ELSE}
  FEvent.Free;
  {$ENDIF}
  inherited Destroy;
end;

procedure TCommEventThread.Execute;
{$IFNDEF LINUX}
var
  Overlapped: TOverlapped;
  WaitEventResult: Boolean;
{$ELSE}
var
  rfds, wfds, efds: TFDSet;
  wfds2: PFDSet;
  tv: TTimeVal;
  Flags, Flags2: Integer;
{$ENDIF}
begin
{$IFDEF LINUX}
  while not Terminated do
  begin
    FD_ZERO(rfds); FD_ZERO(wfds); FD_ZERO(efds);
    FD_SET(FCommHandle, rfds);
    FD_SET(FCommHandle, wfds);
    FD_SET(FCommHandle, efds);
    tv.tv_sec:= 0;
    tv.tv_usec:= 10{ms};
    if fWriteFlag then
      wfds2:= @wfds
    else
      wfds2:= nil;    // is set when buffer is empty
    if select(FCommHandle+1, @rfds, wfds2, @efds, @tv) > 0 then
    begin
      FCriticalSection.Enter;
      try
        if FD_ISSET(FCommHandle, rfds) then
          fEventMask:= fEventMask or EV_RXCHAR;
        if FWriteFlag and FD_ISSET(FCommHandle, wfds) then
          if fComm.OutQueCount = 0 then
          begin
            fEventMask:= fEventMask or EV_TXEMPTY;
            fWriteFlag:= False;
          end;
        if FD_ISSET(FCommHandle, efds) then
          fEventMask:= fEventMask or EV_ERR;
      finally
        fCriticalSection.Leave;
      end;
      if fEventMask <> 0 then
        if FComm.DontSynchronize then DoOnSignal
                                 else Synchronize(DoOnSignal);
    end;
    if not Terminated and (FEvents * [evRing, evCts, evDsr] <> []) then
    begin
      ioctl(FCommHandle, TIOCMGET, @Flags);
      Flags2:= FModemFlags xor Flags;
      FModemFlags:= Flags;
      if (evRing in FEvents) and (Flags2 and TIOCM_RNG <> 0) then
        FEventMask:= FEventMask or EV_RING;
      if (evCts in FEvents) and (Flags2 and TIOCM_CTS <> 0) then
        FEventMask:= FEventMask or EV_CTS;
      if (evDsr in FEvents) and (Flags2 and TIOCM_DSR <> 0) then
        FEventMask:= FEventMask or EV_DSR;
//      (evBreak, evError, evevRlsd, evRxFlag);  ???  not supported in linux
    end;
  end;
  ioctl(integer(FCommHandle), TCFLSH, TCIOFLUSH);
{$ELSE}
{$IFNDEF CLR}
  FillChar(Overlapped, Sizeof(Overlapped), 0);
{$ENDIF}
  Overlapped.hEvent:= FEvent.Handle;
  while not Terminated do
  begin
    WaitEventResult:= WaitCommEvent(FCommHandle, FEventMask, {$IFNDEF CLR}@{$ENDIF}Overlapped);
    if (GetLastError = ERROR_IO_PENDING) then
      WaitEventResult:= (FEvent.WaitFor(INFINITE) = wrSignaled);
    if WaitEventResult then
    begin
      if FComm.DontSynchronize then DoOnSignal
                               else Synchronize(DoOnSignal);
      FEvent.ResetEvent;
    end;
  end;
  PurgeComm(FCommHandle, PURGE_RXABORT+PURGE_RXCLEAR+PURGE_TXABORT+PURGE_TXCLEAR);
{$ENDIF}
end;

procedure TCommEventThread.Terminate;
begin
  inherited;   // Terminated:= True;
{$IFNDEF LINUX}
  FEvent.SetEvent;
{$ENDIF}
end;

procedure TCommEventThread.DoOnSignal;
{$IFDEF LINUX}
var
  Msk: DWord;
{$ENDIF}
begin
  {$IFDEF LINUX}
  FCriticalSection.Enter;
  try
    Msk:= fEventMask;
    fEventMask:= 0;
  finally
    FCriticalSection.Leave;
  end;
  FComm.HandleCommEvent(Msk);
  {$ELSE}
  FComm.HandleCommEvent(fEventMask);
  {$ENDIF}
end;

const
  fBinary              = $00000001;
  fParity              = $00000002;
  fOutxCtsFlow         = $00000004;
  fOutxDsrFlow         = $00000008;
  fDtrControl          = $00000030;