//******************************************************************************
//                      VARIAN ASYNC32 COMPONENT
//               (c) VARIAN SOFTWARE SERVICES NL 1996-1998
//                          ALL RIGHTS RESERVED
//******************************************************************************

unit CommInt;

interface

uses
  Windows, Messages, SysUtils, Classes, CommObjs{v0.39}, ExeLogu{/v0.39};

const
  DefaultDeviceName = 'Com2';

type
  {M}
  TCommOptionName = string[20];
  TCommEventName = string[10];
  TCommParityName = string[7];
  TCommFlowControlName = string[8];
  {/M}

  ECommError = class(Exception)
    ErrorCode: Integer;
  end;

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

  TCommEventThread = class(TThread)
  private
    FCommHandle: THandle;
    FEvent: TSimpleEvent;
    FEventMask: dWord;
    FOnSignal: TCommEvent;
  protected
    procedure Execute; override;
    procedure Terminate; 
    procedure DoOnSignal;
  public
    constructor Create(Handle: THandle; Events: TCommEventTypes);
    destructor Destroy; override;
    property OnSignal: TCommEvent read FOnSignal write FOnSignal;
  end;

  TCustomComm = class;

  TCommEventChars = class(TPersistent)
  private
    FOwner: TCustomComm;
    FXonChar: Char;
    FXoffChar: Char;
    FErrorChar: Char;
    FEofChar: Char;
    FEvtChar: Char;
    procedure SetEventChar(Index: Integer; Value: Char);
  public
    constructor Create(Owner: TCustomComm);
    procedure Assign(Source: TPersistent); override;
  published
    property XonChar: Char index 1 read FXOnChar write SetEventChar default #17;
    property XoffChar: Char index 2 read FXOffChar write SetEventChar default #19;
    property ErrorChar: Char index 3 read FErrorChar write SetEventChar default #0;
    property EofChar: Char index 4 read FEofChar write SetEventChar default #0;
    property EvtChar: Char index 5 read FEvtChar write SetEventChar default #0;
  end;

  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{M}, coAbortOnError{/M});

  {M}
  TAfterOpenState = (aoDefault, aoSpecified);
  TCommEscapeState = (esOff, esOn, esDefault);
  {/M}

  TCommOptions = set of TCommOption;

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

  TCustomComm = class(TComponent)
  private
    FHandle: THandle;
    FDCB: TDCB;
    FDeviceName: string;
    FEvent: TSimpleEvent;
    FCriticalSection: TCriticalSection;
    FReadTimeout: Integer;
    FWriteTimeout: Integer;
    FReadBufSize: Integer;
    FWriteBufSize: Integer;
    FMonitorEvents: TCommEventTypes;
    FBaudRate: TBaudRate;
    FParity: TParity;
    FStopbits: TStopbits;
    FDatabits: TDatabits;
    FEventThread: TCommEventThread;
    FEventChars: TCommEventChars;
    FOptions: TCommOptions;
    FFlowControl: TFlowControl;
    FAfterOpenState: TAfterOpenState;
    FOnBreak: TNotifyEvent;
    FOnCts: TNotifyEvent;
    FOnDsr: TNotifyEvent;
    FOnError: TCommErrorEvent;
    FOnRing: TNotifyEvent;
    FOnRlsd: TNotifyEvent;
    FOnRxChar: TCommRxCharEvent;
    FOnRxFlag: TNotifyEvent;
    FOnTxEmpty: TNotifyEvent;

    FRTSOnOpen: TCommEscapeState;
    FDTROnOpen: TCommEscapeState;
    FXOnOnOpen: TCommEscapeState;
    FBreakOnOpen: TCommEscapeState;

    FRTSState: TCommEscapeState;
    FDTRState: TCommEscapeState;
    FXOnState: TCommEscapeState;
    FBreakState: TCommEscapeState;

    procedure SetDeviceName(const Value: string);
    procedure SetMonitorEvents(Value: TCommEventTypes);
    procedure SetReadBufSize(Value: Integer);
    procedure SetWriteBufSize(Value: Integer);
    procedure SetBaudRate(Value: TBaudRate);
    procedure SetParity(Value: TParity);
    procedure SetStopbits(Value: TStopBits);
    procedure SetDatabits(Value: TDatabits);
    procedure SetOptions(Value: TCommOptions);
    procedure SetFlowControl(Value: TFlowControl);
    procedure SetAfterOpenState(Value: TAfterOpenState);
    function GetModemState(Index: Integer): Boolean;
    function GetComState(Index: Integer): Boolean;
    procedure Lock;
    procedure Unlock;
    procedure CheckOpen;
    procedure EscapeComm(Flag: Integer);
    procedure InitHandshaking(var DCB: TDCB);
    procedure UpdateCommTimeouts;
  protected
    procedure CreateHandle; virtual;
    procedure DestroyHandle;
    procedure HandleCommEvent(Sender: TObject; Status: dword);
    procedure UpdateDataControlBlock;
    procedure DCBToProperties(const ADCB:TDCB);
    procedure PropertiesToDCB(var ADCB:TDCB);

    property DeviceName: string read FDeviceName write SetDeviceName;
    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 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 EventChars: TCommEventChars read FEventChars;
    property Options: TCommOptions read FOptions write SetOptions;
    property FlowControl: TFlowControl read FFlowControl write SetFlowControl default fcDefault;
    property AfterOpenState: TAfterOpenState read FAfterOpenState write SetAfterOpenState default aoSpecified;

    property RTSOnOpen: TCommEscapeState read  FRTSOnOpen write FRTSOnOpen default esOn;
    property DTROnOpen: TCommEscapeState read  FDTROnOpen write FDTROnOpen default esOn;
    property XOnOnOpen: TCommEscapeState read  FXOnOnOpen write FXOnOnOpen default esOn;
    property BreakOnOpen: TCommEscapeState read  FBreakOnOpen write FBreakOnOpen default esOff;

    property RTSState: TCommEscapeState read  FRTSState;
    property DTRState: TCommEscapeState read FDTRState;
    property XOnState: TCommEscapeState read FXOnState;
    property BreakState: TCommEscapeState read FBreakState;

    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: TCommRxCharEvent read FOnRxChar write FOnRxChar;
    property OnRxFlag: TNotifyEvent read FOnRxFlag write FOnRxFlag;
    property OnTxEmpty: TNotifyEvent read FOnTxEmpty write FOnTxEmpty;
    {v0.42}
    procedure lRaiseCommError(Msg: string; ErrCode: Integer);
    {/v0.42}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open;
    procedure Close;
    function Enabled: Boolean;
    function Write(var Buf; Count: Integer): Integer;
    function Read(var Buf; Count: Integer): Integer;
    function InQueCount: Integer;
    function OutQueCount: Integer;
    procedure PurgeIn;
    procedure PurgeOut;

    {Comm escape functions}
    procedure SetDTRState(State: Boolean);
    procedure SetRTSState(State: Boolean);
    procedure SetBREAKState(State: Boolean);
    procedure SetXONState(State: Boolean);
    {v0.39}
    procedure Flush;
    {/v0.39}
    {Comm status flags}
    property CTS: Boolean index 1 read GetModemState;
    property DSR: Boolean index 2 read GetModemState;
    property RING: Boolean index 3 read GetModemState;
    property RLSD: Boolean index 4 read GetModemState;

    property CtsHold: Boolean index 1 read GetComState;
    property DsrHold: Boolean index 2 read GetComState;
    property RlsdHold: Boolean index 3 read GetComState;
    property XoffHold: Boolean index 4 read GetComState;
    property XOffSent: Boolean index 5 read GetComState;

    property Handle: THandle read FHandle;
    {v0.47}
    property Thread: TCommEventThread read FEventThread;
    {/v0.47}
  end;

  TComm = class(TCustomComm)
  published
    property DeviceName;
    property ReadTimeout;
    property WriteTimeout;
    property ReadBufSize;
    property WriteBufSize;
    property MonitorEvents;
    property BaudRate;
    property Parity;
    property Stopbits;
    property Databits;
    property EventChars;
    property Options;
    property FlowControl;
    property AfterOpenState;
    property OnBreak;
    property OnCts;
    property OnDsr;
    property OnRing;
    property OnRlsd;
    property OnError;
    property OnRxChar;
    property OnRxFlag;
    property OnTxEmpty;

    property RTSOnOpen;
    property DTROnOpen;
    property XOnOnOpen;
    property BreakOnOpen;
    property RTSState;
    property DTRState;
    property XOnState;
    property BreakState;
  end;

  {M}
const
  CommOptionNames: array[TCommOption] of TCommOptionName =
  ('Parity Check        ',
   'DSR Sensitive       ',
   'TX Continue On XOff ',
   'Enable Error Char   ',
   'Strip 0             ',
   'Abort On Error      ');

  CommEventNames: array[TCommEventType] of TCommEventName =
  ('BREAK',
   'CTS',
   'DSR',
   'ERROR',
   'RING',
   'RLSD',
   'RXCHAR',
   'RXFLAG',
   'TXEMPTY');

  CommParityNames: array[TParity] of TCommParityName =
  ('NONE',
   'ODD',
   'EVEN',
   'MARK',
   'SPACE');

  CommFlowControlNames: array[TFlowControl] of TCommFlowControlName =
  ('NONE',
   'CTS',
   'DTR',
   'SOFTWARE',
   'DEFAULT');

function BaudRatePropToUser(BaudRate:TBaudRate):longint;
function BaudRateUserToProp(BaudRate:longint; var ABaudRate:TBaudRate):boolean;

function ParityPropToUser(Parity:TParity):char;
function ParityUserToProp(Parity:char; var AParity:TParity):boolean;

function StopBitsPropToUser(StopBits:TStopBits):integer;
function StopBitsUserToProp(StopBits:integer; var AStopBits:TStopBits):boolean;

function DataBitsPropToUser(DataBits:TDataBits):integer;
function DataBitsUserToProp(DataBits:integer; var ADataBits:TDataBits):boolean;

function FlowControlPropToUser(FlowControl:TFlowControl):shortstring;
function FlowControlUserToProp(FlowControl:shortstring; var AFlowControl:TFlowControl):boolean;
{v0.39}
function CommErrorsMsg(Errors: integer): string;
{/v0.39}
{/M}



procedure Register;

implementation
const
  sOpenError = 'Error accessing specified device';
  sInvalidHandle = 'Invalid device handle, access denied';
  sPortAlreadyOpen = 'Port already assigned (open)';
  sPortNotOpen = 'Port not open, unable to complete operation';
  sSetupCommErr = 'Error initializing Read/Write Buffers';
  sUpdateDCBErr = 'Error updating DataControlBlock';
  {M}
  sOpenDCBErr = 'Error getting DCB after open';
  {/M}
  sCommTimeoutsErr = 'Error updating CommTimeouts';
  sEscFuncError = 'EscapeCommFunction failure';
  sReadError = 'Read error';
  sWriteError = 'Write error';
  sMsgExtention = ' (Error: %d) ';

  PurgeRead      = PURGE_RXABORT + PURGE_RXCLEAR;
  PurgeWrite     = PURGE_TXABORT + PURGE_TXCLEAR;
  PurgeReadWrite = PurgeRead + PurgeWrite;

  fBinary              = $00000001;
    { Specifies whether binary mode is enabled. The Win32 API does
      not support nonbinary mode transfers, so this member should
      be TRUE. Trying to use FALSE will not work.
      Under Windows 3.1, if this member is FALSE, nonbinary mode
      is enabled, and the character specified by the EofChar member
      is recognized on input and remembered as the end of data.}
  fParity              = $00000002;
    { Specifies whether parity checking is enabled. If this member
      is TRUE, parity checking is performed and errors are reported. }
  fOutxCtsFlow         = $00000004;
    { Specifies whether the CTS (clear-to-send) signal is monitored
      for output flow control. If this member is TRUE and CTS is
      turned off, output is suspended until CTS is sent again. }
  fOutxDsrFlow         = $00000008;
    { Specifies whether the DSR (data-set-ready) signal is monitored
      for output flow control. If this member is TRUE and DSR is turned
      off, output is suspended until DSR is sent again. }
  fDtrControl          = $00000030;
    { Specifies the DTR (data-terminal-ready) flow control.
      This member can be one of the following values: }
    fDtrControlDisable   = $00000000;
      { DTR_CONTROL_DISABLE Disables the DTR line when the device
        is opened and leaves it disabled. }
    fDtrControlEnable    = $00000010;
      {  DTR_CONTROL_ENABLE Enables the DTR line when the device
         is opened and leaves it on. }
    fDtrControlHandshake = $00000020;
      { DTR_CONTROL_HANDSHAKE Enables DTR handshaking. If handshaking
        is enabled, it is an error for the application to adjust
        the line by using the EscapeCommFunction function. }
  fDsrSensitivity      = $00000040;
    { Specifies whether the communications driver is sensitive to the
      state of the DSR signal. If this member is TRUE, the driver ignores
      any bytes received, unless the DSR modem input line is high. }
  fTXContinueOnXoff    = $00000080;
    { Specifies whether transmission stops when the input buffer is full
      and the driver has transmitted the XoffChar character. If this
      member is TRUE, transmission continues after the input buffer has
      come within XoffLim bytes of being full and the driver has
      transmitted the XoffChar character to stop receiving bytes.
      If this member is FALSE, transmission does not continue until
      the input buffer is within XonLim bytes of being empty and
      the driver has transmitted the XonChar character to resume
      reception. }
  fOutX                = $00000100;
    { fOutX Specifies whether XON/XOFF flow control is used during
      transmission. If this member is TRUE, transmission stops when
      the XoffChar character is received and starts again when the
      XonChar character is received. }
  fInX                 = $00000200;
    { fInX Specifies whether XON/XOFF flow control is used during
      reception. If this member is TRUE, the XoffChar character is
      sent when the input buffer comes within XoffLim bytes of being
      full, and the XonChar character is sent when the input buffer
      comes within XonLim bytes of being empty. }
  fErrorChar           = $00000400;
    { Specifies whether bytes received with parity errors are replaced
      with the character specified by the ErrorChar member. If this
      member is TRUE and the fParity member is TRUE, replacement occurs. }
  fNull                = $00000800;
    { Specifies whether null bytes are discarded. If this member is TRUE,
      null bytes are discarded when received. }
  fRtsControl          = $00003000;
    { Specifies the RTS (request-to-send) flow control. If this value
      is zero, the default is RTS_CONTROL_HANDSHAKE. This member can
      be one of the following values: }
  fRtsControlDisable   = $00000000;
    { RTS_CONTROL_DISABLE Disables the RTS line when the device
      is opened and leaves it disabled. }
  fRtsControlEnable    = $00001000;
    { RTS_CONTROL_ENABLE  Enables the RTS line when the device is
      opened and leaves it on. }
  fRtsControlHandshake = $00002000;
    { RTS_CONTROL_HANDSHAKE Enables RTS handshaking. The driver
      raises the RTS line when the "type-ahead" (input) buffer is less
      than one-half full and lowers the RTS line when the buffer is more
      than three-quarters full. If handshaking is enabled, it is an error
      for the application to adjust the line by using the
      EscapeCommFunction function. }
  fRtsControlToggle    = $00003000;
   { RTS_CONTROL_TOGGLE	Specifies that the RTS line will be high
     if bytes are available for transmission. After all buffered bytes
     have been sent, the RTS line will be low. }
  fAbortOnError        = $00004000;
    { Specifies whether read and write operations are terminated
      if an error occurs. If this member is TRUE, the driver terminates
      all read and write operations with an error status if an error
      occurs. The driver will not accept any further communications
      operations until the application has acknowledged the error by
      calling the ClearCommError function. }
  fDummy2              = $FFFF8000;

  CommEventList: array[TCommEventType] of dword =
    ( EV_BREAK,
      EV_CTS,
      EV_DSR,
      EV_ERR,
      EV_RING,
      EV_RLSD,
      EV_RXCHAR,
      EV_RXFLAG,
      EV_TXEMPTY);

  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 =
    (fParity, fDsrSensitivity, fTXContinueOnXoff, fErrorChar, fNull
     {M},fAbortOnError{/M});

  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 );

{M}
function BaudRatePropToUser(BaudRate:TBaudRate):longint;
begin
  BaudRatePropToUser := CommBaudRates[BaudRate];
end;

function BaudRatePropToDCB(BaudRate:TBaudRate):longint;
begin
  BaudRatePropToDCB := CommBaudRates[BaudRate];
end;

function BaudRateUserToProp(BaudRate:longint; var ABaudRate:TBaudRate):boolean;
var br:TBaudRate;
begin
  BaudRateUserToProp := false;
  for br := low(br) to high(br) do begin
    if BaudRate = CommBaudRates[br] then begin
      ABaudRate := br;
      BaudRateUserToProp := true;
      exit;
    end;
  end;
  ABaudRate := br9600;
end;

function BaudRateDCBToProp(BaudRate:longint; var ABaudRate:TBaudRate):boolean;
begin
  BaudRateDCBToProp := BaudRateUserToProp(BaudRate, ABaudRate);
end;


function ParityPropToUser(Parity:TParity):char;
begin
  ParityPropToUser := CommParityNames[Parity][1];
end;

function ParityPropToDCB(Parity:TParity):integer;
begin
  ParityPropToDCB := CommParity[Parity];
end;

function ParityUserToProp(Parity:char; var AParity:TParity):boolean;
var pa:TParity;
begin
  ParityUserToProp := false;
  for pa := low(pa) to high(pa) do begin
    if Upcase(Parity) = CommParityNames[pa] then begin
      AParity := pa;
      ParityUserToProp := true;
      exit;
    end;
  end;
  AParity := paNone;
end;

function ParityDCBToProp(Parity:integer; var AParity:TParity):boolean;
var pa:TParity;
begin
  ParityDCBToProp := false;
  for pa := low(pa) to high(pa) do begin
    if Parity = CommParity[pa] then begin
      AParity := pa;
      ParityDCBToProp := true;
      exit;
    end;
  end;
  AParity := paNone;
end;

function StopBitsPropToUser(StopBits:TStopBits):integer;
var i:integer;
begin
  i := 10;
  case StopBits of
    sb10: i := 10;
    sb15: i := 15;
    sb20: i := 20;
  end;
  if i <> 15 then
    i := i div 10;
  StopBitsPropToUser := i;
end;

function StopBitsPropToDCB(StopBits:TStopBits):integer;
begin
  StopBitsPropToDCB := CommStopbits[Stopbits];
end;

function StopBitsUserToProp(StopBits:integer; var AStopBits:TStopBits):boolean;
begin
  StopBitsUserToProp := true;
  if StopBits < 10 then
    StopBits := StopBits * 10;
  case StopBits of
    10: AStopBits := sb10;
    15: AStopBits := sb15;
    20: AStopBits := sb20;
  else
    AStopBits := sb10;
    StopBitsUserToProp := false;
  end;
end;

function StopBitsDCBToProp(StopBits:integer; var AStopBits:TStopBits):boolean;
var sb:TStopBits;
begin
  StopBitsDCBToProp := false;
  for sb := low(sb) to high(sb) do begin
    if StopBits = CommStopbits[sb] then begin
      AStopBits := sb;
      StopBitsDCBToProp := true;
      exit;
    end;
  end;
  AStopBits := sb10;
end;


function DataBitsPropToUser(DataBits:TDataBits):integer;
var
  i:integer;
begin
  i := 8;
  case DataBits of
    da4: i := 4;
    da5: i := 5;
    da6: i := 6;
    da7: i := 7;
    da8: i := 8;
  end;
  DataBitsPropToUser := i;
end;

function DataBitsUserToProp(DataBits:integer; var ADataBits:TDataBits):boolean;
begin
  DataBitsUserToProp := true;
  case DataBits of
    4: ADataBits := da4;
    5: ADataBits := da5;
    6: ADataBits := da6;
    7: ADataBits := da7;
    8: ADataBits := da8;
  else
    ADataBits := da8;
    DataBitsUserToProp := false;
  end;
end;

function DataBitsPropToDCB(DataBits:TDataBits):integer;
begin
  DataBitsPropToDCB := CommDataBits[DataBits];
end;

function DataBitsDCBToProp(DataBits:integer; var ADataBits:TDataBits):boolean;
var db:TDataBits;
begin
  DataBitsDCBToProp := false;
  for db := low(db) to high(db) do begin
    if DataBits = CommDataBits[db] then begin
      ADataBits := db;
      DataBitsDCBToProp := true;
      exit;
    end;
  end;
  ADataBits := da8;
end;

function FlowControlPropToUser(FlowControl:TFlowControl):shortstring;
begin
  FlowControlPropToUser := CommFlowControlNames[FlowControl];
end;

function FlowControlUserToProp(FlowControl:shortstring; var AFlowControl:TFlowControl):boolean;
var
  i:integer;
  fc:TFlowControl;
begin
  FlowControlUserToProp := false;
  for i := 1 to length(FlowControl) do
    FlowControl[i] := upcase(FlowControl[i]);
  for fc := low(fc) to high(fc) do begin
    if FlowControl = CommFlowControlNames[fc] then begin
      AFlowControl := fc;
      FlowControlUserToProp := true;
      exit;
    end;;
  end;
  AFlowControl := fcNone;
end;

{v0.39}
function CommErrorsMsg(Errors: integer): string;
begin
  Result := '';
  if (Errors and CE_BREAK) <> 0 then
    Result := Result + 'BREAK ';
  if (Errors and CE_DNS) <> 0 then
    Result := Result + 'DNS ';
  if (Errors and CE_FRAME) <> 0 then
    Result := Result + 'FRAME ';
  if (Errors and CE_IOE) <> 0 then
    Result := Result + 'IOE ';
  if (Errors and CE_MODE) <> 0 then
    Result := Result + 'MODE ';
  if (Errors and CE_OOP) <> 0 then
    Result := Result + 'OOP ';
  if (Errors and CE_OVERRUN) <> 0 then
    Result := Result + 'OVERRUN ';
  if (Errors and CE_PTO) <> 0 then
    Result := Result + 'PTO ';
  if (Errors and CE_RXOVER) <> 0 then
    Result := Result + 'RXOVER ';
  if (Errors and CE_RXPARITY) <> 0 then
    Result := Result + 'RXPARITY ';
  if (Errors and CE_TXFULL) <> 0 then
    Result := Result + 'TXFULL ';
{CE_BREAK	The hardware detected a break condition.
CE_DNS	Windows 95 only: A parallel device is not selected.
CE_FRAME	The hardware detected a framing error.
CE_IOE	An I/O error occurred during communications with the device.
CE_MODE	The requested mode is not supported, or the hFile parameter is invalid. If this value is specified, it is the only valid error.
CE_OOP	Windows 95 only: A parallel device signaled that it is out of paper.
CE_OVERRUN	A character-buffer overrun has occurred. The next character is lost.
CE_PTO	Windows 95 only: A time-out occurred on a parallel device.
CE_RXOVER	An input buffer overflow has occurred. There is either no room in the input buffer, or a character was received after the end-of-file (EOF) character.
CE_RXPARITY	The hardware detected a parity error.
CE_TXFULL	The application tried to transmit a character, but the output buffer was full.}





end;
{/v0.39}

{/M}
{ RaiseCommError }
procedure RaiseCommError(Msg: string; ErrCode: Integer);
var
  E: ECommError;
begin
  {v0.39}
  ExeLog.LogErr('COM ' + Msg + Format(sMsgExtention, [ErrCode]));
  {/v0.39}
  E := ECommError.Create(Msg + Format(sMsgExtention, [ErrCode]));
  E.ErrorCode := ErrCode;
  raise E;
end; { RaiseCommError }

{ TCommEventThread }

constructor TCommEventThread.Create(Handle: THandle; Events: TCommEventTypes);
var
  EvIndex: TCommEventType;
  AttrWord: dword;
begin
  Priority := tpHigher;
  FreeOnTerminate := True;
  FCommHandle := Handle;
  AttrWord := $0;
  for EvIndex := evBreak to evTxEmpty do
    if EvIndex in Events then AttrWord := AttrWord or CommEventList[EvIndex];
  SetCommMask(FCommHandle, AttrWord);
  FEvent := TSimpleEvent.Create;
  inherited Create(false);
end;

destructor TCommEventThread.Destroy;
begin
  FEvent.Free;
  Inherited Destroy;
end;

procedure TCommEventThread.Execute;
var
  Overlapped: TOverlapped;
  WaitEventResult: Boolean;
begin
  FillChar(Overlapped, Sizeof(Overlapped), 0);
  Overlapped.hEvent := FEvent.Handle;
  while (not Terminated) do
  begin
    WaitEventResult := WaitCommEvent(FCommHandle, FEventMask, @Overlapped);
    if (GetLastError = ERROR_IO_PENDING) then
      WaitEventResult := (FEvent.WaitFor(INFINITE) = wrSignaled);
    if WaitEventResult then
    begin
      {v0.43}
      if not Terminated then
      {/v0.43}
        Synchronize(DoOnSignal);
      FEvent.ResetEvent;
    end;
  end;
  {v0.47 - FCommHandle may not be available at this point }{/v0.47
  PurgeComm(FCommHandle, PurgeReadWrite);}
end;

procedure TCommEventThread.Terminate;
begin
  {v0.47}
  PurgeComm(FCommHandle, PurgeReadWrite);
  {/v0.47}
  FEvent.SetEvent;
  inherited;
end;

procedure TCommEventThread.DoOnSignal;
begin
  if Assigned(FOnSignal) then FOnSignal(Self, FEventMask);
end;

{TCommEventChars}

constructor TCommEventChars.Create(Owner: TCustomComm);
begin
  Inherited Create;
  FOwner := Owner;
  FXonChar := #17;
  FXoffChar := #19;
  FErrorChar := #0;
  FEofChar := #0;
  FEvtChar := #0;
end;

procedure TCommEventChars.SetEventChar(Index: Integer; Value: Char);
begin
  case Index of
    1: FXOnChar := Value;
    2: FXOffChar := Value;
    3: FErrorChar := Value;
    4: FEofChar := Value;
    5: FEvtChar := Value;
  end;
  if FOwner <> nil then
    FOwner.UpdateDataControlBlock;
end;

procedure TCommEventChars.Assign(Source: TPersistent);
begin
  if (Source <> nil) and (Source is TCommEventChars) then
  begin
    FXonChar := TCommEventChars(Source).FXonChar;
    FXoffChar := TCommEventChars(Source).FXoffChar;
    FErrorChar := TCommEventChars(Source).FErrorChar;
    FEofChar := TCommEventChars(Source).FEofChar;
    FEvtChar := TCommEventChars(Source).FEvtChar;
  end else inherited Assign(Source);
end;


{ TCustomComm }
constructor TCustomComm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle := INVALID_HANDLE_VALUE;
  FDeviceName := DefaultDeviceName;
  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;

  FRTSOnOpen := esOn;
  FDTROnOpen := esOn;
  FXOnOnOpen := esOn;
  FBreakOnOpen := esOff;

  FRTSState := esDefault;
  FDTRState := esDefault;
  FXOnState := esDefault;
  FBreakState := esDefault;

  FAfterOpenState := aoSpecified;
  FEventChars := TCommEventChars.Create(self);
  FEvent := TSimpleEvent.Create;
  FCriticalSection := TCriticalSection.Create;
end;

{v0.42}
procedure TCustomComm.lRaiseCommError(Msg: string; ErrCode: Integer);
begin
  RaiseCommError(FDeviceName + ' ' + Msg, ErrCode);
end;
{/v0.42}

destructor TCustomComm.Destroy;
begin
  Close;
  FEventChars.Free;
  FEvent.Free;
  FCriticalSection.Free;
  inherited Destroy;
end;

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

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

function TCustomComm.Enabled: Boolean;
begin
  Result := FHandle <> INVALID_HANDLE_VALUE;
end;

procedure TCustomComm.CheckOpen;
begin
  if Enabled then lRaiseCommError(sPortAlreadyOpen, -1);
end;

procedure TCustomComm.CreateHandle;
begin
  FHandle := CreateFile(PCHAR(FDeviceName),
    GENERIC_READ or GENERIC_WRITE, 0, nil,
    OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);

  if not Enabled then
    lRaiseCommError(sOpenError, GetLastError);

  if GetFileType(FHandle) <> FILE_TYPE_CHAR then
  begin
    DestroyHandle;
    lRaiseCommError(sInvalidHandle, -1);
  end;
end;

procedure TCustomComm.DestroyHandle;
begin
  CloseHandle(FHandle);
  FHandle := INVALID_HANDLE_VALUE;
end;

procedure TCustomComm.Open;
begin
  CheckOpen;
  {v0.43}
  ExeLog.Log(FDeviceName + '.Open');
  {/v0.43}
  CreateHandle;

  if Enabled then
  begin
    {v0.39}
    PurgeComm(FHandle, PurgeReadWrite);
    {/v0.39}
    FEventThread := TCommEventThread.Create(FHandle, FMonitorEvents);
    FEventThread.OnSignal := HandleCommEvent;

    UpdateCommTimeouts;

    if AfterOpenState = aoSpecified then
      UpdateDataControlBlock
    else begin
      if not GetCommState(FHandle, FDCB) then
        lRaiseCommError(sUpdateDCBErr, GetLastError)
      else
        DCBToProperties(FDCB);
    end;

    if not SetupComm(FHandle, FReadBufSize, FWriteBufSize) then
      lRaiseCommError(sSetupCommErr, GetLastError);
    if FRTSOnOpen <> esDefault then
      SetRTSState(FRTSOnOpen = esOn);
    if FDTROnOpen <> esDefault then
      SetDTRState(FDTROnOpen = esOn);
    if FXOnOnOpen <> esDefault then
      SetXOnState(FXOnOnOpen = esOn);
    if FBreakOnOpen <> esDefault then
      SetBreakState(FBreakOnOpen = esOn);
  end;
end;

procedure TCustomComm.Close;
begin
  if Enabled then
  begin
    {v0.43}
    ExeLog.Log(FDeviceName + '.Close');
    Lock;
    {/v0.43}
      FEventThread.OnSignal := nil;
      FEventThread.Terminate;
      {v0.47}
      FEventThread := nil;
      {/v0.47}
      DestroyHandle;
    {v0.43}
    Unlock;
    {/v0.43}
  end;
end;

function TCustomComm.Write(var Buf; Count: Integer): Integer;
var
  Overlapped: TOverlapped;
  ErrorCode: Integer;
begin
  Lock;
  try
    FillChar(Overlapped, Sizeof(Overlapped), 0);
    Overlapped.hEvent := FEvent.Handle;
    if not WriteFile(FHandle, Buf, Count, dWord(Result),
      @Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
    begin
      ErrorCode := GetLastError;
      lRaiseCommError(sWriteError, ErrorCode);
    end;
    if FEvent.WaitFor(FWriteTimeout) <> wrSignaled then
      Result := -1
    else
     begin
       GetOverlappedResult(Handle, Overlapped, dWord(Result), False);
       FEvent.ResetEvent;
     end;
  finally
    Unlock;
  end;
end;

function TCustomComm.Read(var Buf; Count: Integer): Integer;
var
  Overlapped: TOverlapped;
  ErrorCode: Integer;
begin
  Lock;
  try
    FillChar(Overlapped, Sizeof(Overlapped), 0);
    Overlapped.hEvent := FEvent.Handle;
    if not ReadFile(FHandle, Buf, Count, dWord(Result),
      @Overlapped) and (GetLastError <> ERROR_IO_PENDING) then
    begin
      ErrorCode := GetLastError;
      lRaiseCommError(sReadError, ErrorCode);
    end;
    if FEvent.WaitFor(FReadTimeout) <> wrSignaled then
      Result := -1
    else
     begin
       GetOverlappedResult(Handle, Overlapped, dWord(Result), False);
       FEvent.ResetEvent;
     end;
  finally
    Unlock;
  end;
end;

function TCustomComm.InQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Enabled then
  begin
    ClearCommError(FHandle, Errors, @ComStat);
    Result := ComStat.cbInQue;
  end else Result := -1;
end;

function TCustomComm.OutQueCount: Integer;
var
  ComStat: TComStat;
  Errors: dword;
begin
  if Enabled then
  begin
    ClearCommError(FHandle, Errors, @ComStat);
    Result := ComStat.cbOutQue;
  end else Result := -1;
end;

procedure TCustomComm.PurgeIn;
begin
  if Enabled then
    PurgeComm(FHandle, PurgeRead);
end;

procedure TCustomComm.PurgeOut;
begin
  if Enabled then
    PurgeComm(FHandle, PurgeWrite);
end;

procedure TCustomComm.SetDeviceName(const Value: string);
begin
  if FDeviceName <> Value then
  begin
    CheckOpen;
    FDeviceName := Value;
  end;
end;

procedure TCustomComm.SetMonitorEvents(Value: TCommEventTypes);
begin
  if FMonitorEvents <> Value then
  begin
    CheckOpen;
    FMonitorEvents := Value;
  end;
end;

procedure TCustomComm.SetReadBufSize(Value: Integer);
begin
  if FReadBufSize <> Value then
  begin
    CheckOpen;
    FReadBufSize := Value;
  end;
end;

procedure TCustomComm.SetWriteBufSize(Value: Integer);
begin
  if FWriteBufSize <> Value then
  begin
    CheckOpen;
    FWriteBufSize := Value;
  end;
end;

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

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

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

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

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

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

procedure TCustomComm.SetAfterOpenState(Value: TAfterOpenState);
begin
  if FAfterOpenState <> Value then
  begin
    FAfterOpenState := Value;
  end;
end;

procedure TCustomComm.HandleCommEvent(Sender: TObject; Status: dword);
var
  ComStat: TComStat;
  Errors: dword;
begin
  ClearCommError(FHandle, Errors, @ComStat);
  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
    if ComStat.cbInQue > 0 then
      if assigned(FOnRxChar) then FOnRxChar(self, ComStat.cbInQue);
  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;

function TCustomComm.GetModemState(Index: Integer): boolean;
var
  Flag, State: dword;
begin
  case Index of
    1: State := MS_CTS_ON;
    2: State := MS_DSR_ON;
    3: State := MS_RING_ON;
    4: State := MS_RLSD_ON;
    else
      State := 0;
  end;
  Result := false;
  if Enabled then
    if GetCommModemStatus(FHandle, Flag) then
      Result := (Flag and State > 0);
end;

function TCustomComm.GetComState(Index: Integer): Boolean;
var
  Flag: TComStateFlag;
  ComStat: TComStat;
  Errors: dword;
begin
  case Index of
    1: Flag := fCtlHold;
    2: Flag := fDsrHold;
    3: Flag := fRlsHold;
    4: Flag := fXoffHold;
    5: Flag := fXOffSent;
    else
      Flag := fCtlHold;
  end;
  Result := false;
  if Enabled then
  begin
    ClearCommError(FHandle, Errors, @ComStat);
    Result := Flag in ComStat.Flags;
  end;
end;

{M}
procedure TCustomComm.DCBToProperties(const ADCB:TDCB);
var
  OptIndex: TCommOption;
{  br:TBaudRate;
  pa:TParity;
  sb:TStopBits;
  db:TDataBits;
  ok:boolean;}
begin
  if not BaudRateDCBToProp(ADCB.BaudRate, FBaudRate) then
    lRaiseCommError('DCBToProperties unknown BaudRate:' + IntToStr(ADCB.BaudRate), -1);

  if not ParityDCBToProp(ADCB.Parity, FParity) then
    lRaiseCommError('DCBToProperties unknown Parity:' + IntToStr(ADCB.Parity), -1);

  if not StopBitsDCBToProp(ADCB.StopBits, FStopBits) then
    lRaiseCommError('DCBToProperties unknown StopBits:' + IntToStr(ADCB.StopBits), -1);

  if not DataBitsDCBToProp(ADCB.ByteSize, FDataBits) then
    lRaiseCommError('DCBToProperties unknown DataBits:' + IntToStr(ADCB.ByteSize), -1);

  FEventChars.XonChar := ADCB.XonChar;
  FEventChars.XOffChar := ADCB.XoffChar;
  FEventChars.ErrorChar := ADCB.ErrorChar;
  FEventChars.EofChar := ADCB.EofChar;
  FEventChars.EvtChar := ADCB.EvtChar;

  {
  ADCB.XonLim := FReadBufSize div 4;
  ADCB.XoffLim := FReadBufSize div 4;
  }

  if (ADCB.Flags and (fOutX or fInX)) = (foutX or fInX) then
  begin
    FFlowControl := fcSoftware
  end else if (ADCB.Flags and (fOutxCtsFlow or fRTSControlHandshake))
    = (fOutxCtsFlow or fRTSControlHandshake) then begin
    FFlowControl := fcCTS
  end else if (ADCB.Flags and (fOutxDsrFlow or fDtrControlHandshake))
    = (fOutxDsrFlow or fDtrControlHandshake) then begin
    FFlowControl := fcDTR
  end else begin
    FFlowControl := fcDefault;
  end;
  (*
  case FFlowControl of
    fcNone: //Clear all flags
      DCB.Flags := fBinary;
    fcDefault:; //do nothing;
    fcCTS:
      DCB.Flags := DCB.Flags or fOutxCtsFlow or fRtsControlHandshake;
    fcDTR:
      DCB.Flags := DCB.Flags or fOutxDsrFlow or fDtrControlHandshake;
    fcSoftware:
      DCB.Flags := DCB.Flags or fOutX or fInX;
  end;
  *)
  FOptions := [];
  for OptIndex := Low(OptIndex) to High(OptIndex) do
  begin
    if (ADCB.Flags and CommOptions[OptIndex]) <> 0 then
      Include(FOptions, OptIndex);
  end;
end;

procedure TCustomComm.PropertiesToDCB(var ADCB:TDCB);
{moved from UpdateDataControlBlock to this separate procedure}
var
  OptIndex: TCommOption;
begin
  ADCB.BaudRate := CommBaudRates[FBaudRate];
  ADCB.Parity := CommParity[FParity];
  ADCB.Stopbits := CommStopbits[FStopbits];
  ADCB.Bytesize := CommDatabits[FDatabits];
  ADCB.XonChar := FEventChars.XonChar;
  ADCB.XoffChar := FEventChars.XOffChar;
  ADCB.ErrorChar := FEventChars.ErrorChar;
  ADCB.EofChar := FEventChars.EofChar;
  ADCB.EvtChar := FEventChars.EvtChar;
  ADCB.XonLim := FReadBufSize div 4;
  ADCB.XoffLim := FReadBufSize div 4;

  InitHandshaking(ADCB);

  for OptIndex := Low(OptIndex) to High(OptIndex) do begin
    if OptIndex in FOptions then begin
      ADCB.Flags := ADCB.Flags or CommOptions[OptIndex]
    end else begin
      ADCB.Flags := ADCB.Flags and (not CommOptions[OptIndex]);
    end;
  end;
end;
{/M}

procedure TCustomComm.UpdateDataControlBlock;
begin
  if Enabled then
  begin
    GetCommState(FHandle, FDCB);{dcb}
    {M}
    PropertiesToDCB(FDCB);
    {/M}
    if not SetCommState(FHandle, FDCB) then
      lRaiseCommError(sUpdateDCBErr, GetLastError);
  end;
end;

(*
The EscapeCommFunction function directs a specified communications device to perform an extended function.

BOOL EscapeCommFunction(

    HANDLE hFile,	// handle to communications device
    DWORD dwFunc 	// extended function to perform
   );


Parameters

hFile

Identifies the communications device. The CreateFile function returns this handle. 

dwFunc

Specifies the code of the extended function to perform. This parameter can be one of the following values: 

Value	Meaning
CLRDTR	Clears the DTR (data-terminal-ready) signal.
CLRRTS	Clears the RTS (request-to-send) signal.
SETDTR	Sends the DTR (data-terminal-ready) signal.
SETRTS	Sends the RTS (request-to-send) signal.
SETXOFF	Causes transmission to act as if an XOFF character has been received.
SETXON	Causes transmission to act as if an XON character has been received.
SETBREAK	Suspends character transmission and places the transmission line in a break state until the ClearCommBreak function is called (or EscapeCommFunction is called with the CLRBREAK extended function code). The SETBREAK extended function code is identical to the SetCommBreak function. Note that this extended function does not flush data that has not been transmitted.
CLRBREAK	Restores character transmission and places the transmission line in a nonbreak state. The CLRBREAK extended function code is identical to the ClearCommBreak function.


Return Values

If the function succeeds, the return value is nonzero.
If the function fails, the return value is zero. To get extended error information, call GetLastError.

See Also

ClearCommBreak, CreateFile, SetCommBreak
*)

procedure TCustomComm.EscapeComm(Flag: Integer);
var
  Escaped: Boolean;
begin
  if Enabled then
  begin
    Escaped := EscapeCommFunction(FHandle, Flag);
    if not Escaped then
      lRaiseCommError(SEscFuncError, GetLastError);
  end else lRaiseCommError(SPortNotOpen, -1);
end;

procedure TCustomComm.SetDTRState(State: boolean);
const
  DTR: array[boolean] of Integer = (CLRDTR, SETDTR);
begin
  EscapeComm(DTR[State]);
  FDTRState := TCommEscapeState(State);

end;

procedure TCustomComm.SetRTSState(State: boolean);
const
  RTS: array[boolean] of Integer = (CLRRTS, SETRTS);
begin
  EscapeComm(RTS[State]);
  FRTSState := TCommEscapeState(State);
end;

procedure TCustomComm.SetBREAKState(State: Boolean);
const
  BREAK: array[boolean] of Integer = (CLRBREAK, SETBREAK);
begin
  EscapeComm(BREAK[State]);
  if Enabled then
    PurgeComm(FHandle, PurgeReadWrite);
  FBreakState := TCommEscapeState(State);
end;

procedure TCustomComm.SetXONState(State: Boolean);
const
  XON: array[boolean] of Integer = (SETXOFF, SETXON);
begin
  EscapeComm(XON[State]);
  FXOnState := TCommEscapeState(State);
end;

procedure TCustomComm.UpdateCommTimeouts;
var
  CommTimeouts: TCommTimeouts;
begin
  FillChar(CommTimeOuts, Sizeof(CommTimeOuts), 0);
  CommTimeOuts.ReadIntervalTimeout := MAXDWORD;
  if not SetCommTimeOuts(FHandle, CommTimeOuts) then
    lRaiseCommError(sCommTimeoutsErr, GetLastError);
end;

procedure TCustomComm.InitHandshaking(var DCB: TDCB);
begin
  case FFlowControl of
    fcNone: begin
      DCB.Flags := fBinary; //Clear all flags
    end;
    fcDefault: begin
       //do nothing;
    end;
    fcCTS: begin
      DCB.Flags :=
      (DCB.Flags or
                (fOutxCtsFlow or fRtsControlHandshake)
       and (not (fOutxDsrFlow or fDtrControlHandshake or fOutX or fInX))
      );
    end;
    fcDTR: begin
      DCB.Flags :=
      (DCB.Flags or
                (fOutxDsrFlow or fDtrControlHandshake)
       and (not (fOutxCtsFlow or fRtsControlHandshake or fOutX or fInX))
       );
    end;
    fcSoftware: begin
      DCB.Flags :=
      (DCB.Flags or
                (fOutX or fInX)
       and (not (fOutxDsrFlow or fDtrControlHandshake or fOutxCtsFlow or fRtsControlHandshake))
      );
    end;
  end;
end;

{v0.39}
procedure TCustomComm.Flush;
begin
  if Enabled then
    FlushFileBuffers(FHandle);
end;
{/v0.39}


procedure Register;
begin
  RegisterComponents('Varian Freeware', [TComm]);
end;

end.
