comms.pas

Motorola 集群通信系统中SDTS车载台PEI端测试程序

// a FREEWARE Delphi Component
// TComPort component, version 1.71
// for Delphi 2.0, 3.0, 4.0
// written by Dejan Crnila, 1998-1999
// email: [e-mail], [e-mail]

unit Comms;

interface

uses
  Windows, Messages, Classes, SysUtils, GenAlg;

type
  TBaudRate = (br110, br300, br600, br1200, br2400, br4800, br9600,
               br14400, br19200, br38400, br56000, br57600, br115200);
  TPortType = (COM1, COM2, COM3, COM4, COM5, COM6, COM7, COM8);
  TStopBits = (sbOneStopBit, sbOne5StopBits, sbTwoStopBits);
  TDataBits = (dbFive, dbSix, dbSeven, dbEight);
  TParityBits = (prNone, prOdd, prEven, prMark, prSpace);
  TDtrFlowControl = (dtrDisable, dtrEnable, dtrHandshake);
  TRtsFlowControl = (rtsDisable, rtsEnable, rtsHandshake, rtsToggle);
  TEvent = (evRxChar, evTxEmpty, evRxFlag, evRing, evBreak, evCTS,
            evDSR, evError, evRLSD, evRx80Full);
  TEvents = set of TEvent;
  TSyncMethod = (smSynchronize, smWindow, smNone);
  TRxCharEvent = procedure(Sender: TObject; InQue: Integer) of object;

  TComPort = class;

  TComThread = class(TThread)
  private
    Owner: TComPort;
    Mask: DWORD;
    StopEvent: THandle;
  protected
    procedure Execute; override;
    procedure DoEvents;
    procedure SendEvents;
    procedure DispatchComMsg;
    procedure Stop;
  public
    constructor Create(AOwner: TComPort);
    destructor Destroy; override;
  end;

  TComTimeouts = class(TPersistent)
  private
    ComPort: TComPort;
    FReadInterval: Integer;
    FReadTotalM: Integer;
    FReadTotalC: Integer;
    FWriteTotalM: Integer;
    FWriteTotalC: Integer;
    procedure SetReadInterval(Value: Integer);
    procedure SetReadTotalM(Value: Integer);
    procedure SetReadTotalC(Value: Integer);
    procedure SetWriteTotalM(Value: Integer);
    procedure SetWriteTotalC(Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(AComPort: TComPort);
  published
    property ReadInterval: Integer read FReadInterval write SetReadInterval;
    property ReadTotalMultiplier: Integer read FReadTotalM write SetReadTotalM;
    property ReadTotalConstant: Integer read FReadTotalC write SetReadTotalC;
    property WriteTotalMultiplier: Integer read FWriteTotalM write SetWriteTotalM;
    property WriteTotalConstant: Integer read FWriteTotalC write SetWriteTotalC;
  end;

  TFlowControl = class(TPersistent)
  private
    ComPort: TComPort;
    FOutCtsFlow: Boolean;
    FOutDsrFlow: Boolean;
    FControlDtr: TDtrFlowControl;
    FControlRts: TRtsFlowControl;
    FXonXoffOut: Boolean;
    FXonXoffIn:  Boolean;
    procedure SetOutCtsFlow(Value: Boolean);
    procedure SetOutDsrFlow(Value: Boolean);
    procedure SetControlDtr(Value: TDtrFlowControl);
    procedure SetControlRts(Value: TRtsFlowControl); 
    procedure SetXonXoffOut(Value: Boolean);
    procedure SetXonXoffIn(Value: Boolean);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(AComPort: TComPort);
  published
    property OutCtsFlow: Boolean read FOutCtsFlow write SetOutCtsFlow;
    property OutDsrFlow: Boolean read FOutDsrFlow write SetOutDsrFlow;
    property ControlDtr: TDtrFlowControl read FControlDtr write SetControlDtr;
    property ControlRts: TRtsFlowControl read FControlRts write SetControlRts;
    property XonXoffOut: Boolean read FXonXoffOut write SetXonXoffOut;
    property XonXoffIn:  Boolean read FXonXoffIn write SetXonXoffIn;
  end;

  TParity = class(TPersistent)
  private
    ComPort: TComPort;
    FBits: TParityBits;
    FCheck: Boolean;
    FReplace: Boolean;
    FReplaceChar: Byte;
    procedure SetBits(Value: TParityBits);
    procedure SetCheck(Value: Boolean);
    procedure SetReplace(Value: Boolean);
    procedure SetReplaceChar(Value: Byte);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(AComPort: TComPort);
  published
    property Bits: TParityBits read FBits write SetBits;
    property Check: Boolean read FCheck write SetCheck;
    property Replace: Boolean read FReplace write SetReplace;
    property ReplaceChar: Byte read FReplaceChar write SetReplaceChar;
  end;

  TComPort = class(TComponent)
  private
    EventThread: TComThread;
    ThreadCreated: Boolean;
    Stack: TStack;
    FHandle: THandle;
    FWindow: THandle;
    FConnected: Boolean;
    FBaudRate: TBaudRate;
    FPort: TPortType;
    FStopBits: TStopBits;
    FDataBits: TDataBits;
    FDiscardNull: Boolean;
    FEventChar: Byte;
    FEvents: TEvents;
    FWriteBufSize: DWORD;
    FReadBufSize: DWORD;
    FParity: TParity;
    FTimeouts: TComTimeouts;
    FFlowControl: TFlowControl;
    FSyncMethod: TSyncMethod;
    FOnRxChar: TRxCharEvent;
    FOnTxEmpty: TNotifyEvent;
    FOnBreak: TNotifyEvent;
    FOnRing: TNotifyEvent;
    FOnCTS: TNotifyEvent;
    FOnDSR: TNotifyEvent;
    FOnRLSD: TNotifyEvent;
    FOnError: TNotifyEvent;
    FOnRxFlag: TNotifyEvent;
    FOnOpen: TNotifyEvent;
    FOnClose: TNotifyEvent;
    FOnRx80Full: TNotifyEvent;
    procedure SetBaudRate(Value: TBaudRate);
    procedure SetPort(Value: TPortType);
    procedure SetStopBits(Value: TStopBits);
    procedure SetDataBits(Value: TDataBits);
    procedure SetDiscardNull(Value: Boolean);
    procedure SetEventChar(Value: Byte);
    procedure SetWriteBufSize(Value: DWORD);
    procedure SetReadBufSize(Value: DWORD);
    procedure SetSyncMethod(Value: TSyncMethod);
    procedure DoOnRxChar;
    procedure DoOnTxEmpty;
    procedure DoOnBreak;
    procedure DoOnRing;
    procedure DoOnRxFlag;
    procedure DoOnCTS;
    procedure DoOnDSR;
    procedure DoOnError;
    procedure DoOnRLSD;
    procedure DoOnRx80Full;
    procedure InitOverlapped(var PO: POverlapped);
    procedure DoneOverlapped(var PO: POverlapped);
    function ComString: String;
  protected
    procedure CreateHandle;
    procedure DestroyHandle;
    procedure SetTimeouts;
    procedure SetDCB;
    procedure SetComm;
    procedure SetupComPort;
    procedure WindowMethod(var Message: TMessage);
  public
    property Connected: Boolean read FConnected;
    property Handle: THandle read FHandle;
    procedure Open;
    procedure Close;
    function InQue: DWORD;
    function OutQue: DWORD;
    function HighCTS: Boolean;
    function HighDSR: Boolean;
    function HighRLSD: Boolean;
    function HighRing: Boolean;
    procedure SetDTR(State: Boolean);
    procedure SetRTS(State: Boolean);
    procedure SetXonXoff(State: Boolean);
    procedure SetBreak(State: Boolean);
    function Write(var Buffer; Count: DWORD; WaitFor: Boolean): DWORD;
    function WriteString(Str: String; WaitFor: Boolean): DWORD;
    function Read(var Buffer; Count: DWORD; WaitFor: Boolean): DWORD;
    function ReadString(var Str: String; Count: DWORD; WaitFor: Boolean): DWORD;
    function PendingIO: Boolean;
    function WaitForLastIO: DWORD;
    procedure AbortAllIO;
    procedure ShowPropForm;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BaudRate: TBaudRate read FBaudRate write SetBaudRate;
    property Port: TPortType read FPort write SetPort;
    property Parity: TParity read FParity write FParity;
    property StopBits: TStopBits read FStopBits write SetStopBits;
    property DataBits: TDataBits read FDataBits write SetDataBits;
    property DiscardNull: Boolean read FDiscardNull write SetDiscardNull;
    property EventChar: Byte read FEventChar write SetEventChar;
    property Events: TEvents read FEvents write FEvents;
    property WriteBufSize: DWORD read FWriteBufSize write SetWriteBufSize;
    property ReadBufSize: DWORD read FReadBufSize write SetReadBufSize;
    property FlowControl: TFlowControl read FFlowControl write FFlowControl;
    property Timeouts: TComTimeouts read FTimeouts write FTimeouts;
    property SyncMethod: TSyncMethod read FSyncMethod write SetSyncMethod;
    property OnRxChar: TRxCharEvent read FOnRxChar write FOnRxChar;
    property OnTxEmpty: TNotifyEvent read FOnTxEmpty write FOnTxEmpty;
    property OnBreak: TNotifyEvent read FOnBreak write FOnBreak;
    property OnRing: TNotifyEvent read FOnRing write FOnRing;
    property OnCTS: TNotifyEvent read FOnCTS write FOnCTS;
    property OnDSR: TNotifyEvent read FOnDSR write FOnDSR;
    property OnRLSD: TNotifyEvent read FOnRLSD write FOnRLSD;
    property OnRxFlag: TNotifyEvent read FOnRxFlag write FOnRxFlag;
    property OnError: TNotifyEvent read FOnError write FOnError;
    property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnRx80Full: TNotifyEvent read FOnRx80Full
                                      write FOnRx80Full;
  end;

  EComPort   = class(Exception);

const
  dcb_Binary           = $00000001;
  dcb_Parity           = $00000002;
  dcb_OutxCtsFlow      = $00000004;
  dcb_OutxDsrFlow      = $00000008;
  dcb_DtrControl       = $00000030;
  dcb_DsrSensivity     = $00000040;
  dcb_TXContinueOnXOff = $00000080;
  dcb_OutX             = $00000100;
  dcb_InX              = $00000200;
  dcb_ErrorChar        = $00000400;
  dcb_Null             = $00000800;
  dcb_RtsControl       = $00003000;
  dcb_AbortOnError     = $00004000;

  NOT_FINISHED         = $FFFFFFFF;
  NO_OPERATION         = $FFFFFFFE;

  CM_COMPORT           = WM_USER + 9; // change this if used by other unit

procedure Register;

implementation

uses
  DsgnIntf, CommForm, Controls, Forms;

type
  TComPortEditor = class(TComponentEditor)
  private
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

function LastErr: String;
begin
  Result := IntToStr(GetLastError);
end;

function GetTOValue(Value: Integer): DWORD;
begin
  if Value = -1 then
    Result := MAXDWORD
  else
    Result := Value;
end;

// TComThread

constructor TComThread.Create(AOwner: TComPort);
var
  AMask: DWORD;
begin
  inherited Create(True);
  StopEvent := CreateEvent(nil, True, False, nil);
  Owner := AOwner;
  AMask := 0;
  if evRxChar in Owner.FEvents then AMask := AMask or EV_RXCHAR;
  if evRxFlag in Owner.FEvents then AMask := AMask or EV_RXFLAG;
  if evTxEmpty in Owner.FEvents then AMask := AMask or EV_TXEMPTY;
  if evRing in Owner.FEvents then AMask := AMask or EV_RING;
  if evCTS in Owner.FEvents then AMask := AMask or EV_CTS;
  if evDSR in Owner.FEvents then AMask := AMask or EV_DSR;
  if evRLSD in Owner.FEvents then AMask := AMask or EV_RLSD;
  if evError in Owner.FEvents then AMask := AMask or EV_ERR;
  if evBreak in Owner.FEvents then AMask := AMask or EV_BREAK;
  if evRx80Full in Owner.FEvents then AMask := AMask or EV_RX80FULL;
  SetCommMask(Owner.FHandle, AMask);
  Resume;
end;

procedure TComThread.Execute;
var
  EventHandles: Array[0..1] of THandle;
  Overlapped: TOverlapped;
  Signaled, BytesTrans: DWORD;
begin
  FillChar(Overlapped, SizeOf(Overlapped), 0);
  Overlapped.hEvent := CreateEvent(nil, True, True, nil);
  EventHandles[0] := StopEvent;
  EventHandles[1] := Overlapped.hEvent;
  repeat
    WaitCommEvent(Owner.FHandle, Mask, @Overlapped);
    Signaled := WaitForMultipleObjects(2, @EventHandles, False, INFINITE);
    case Signaled of
      WAIT_OBJECT_0: Break;
      WAIT_OBJECT_0 + 1: if GetOverlappedResult(Owner.FHandle, Overlapped,
                              BytesTrans, False) then DispatchComMsg;
      else Break;
    end;
  until False;
  PurgeComm(Owner.FHandle, PURGE_TXABORT or PURGE_RXABORT or
     PURGE_TXCLEAR or PURGE_RXCLEAR);
  CloseHandle(Overlapped.hEvent);
  CloseHandle(StopEvent);
end;

procedure TComThread.Stop;
begin
  SetEvent(StopEvent);
end;

destructor TComThread.Destroy;
begin
  Stop;
  inherited Destroy;
end;

procedure TComThread.DispatchComMsg;
begin
  if (Owner.SyncMethod = smSynchronize) then
    Synchronize(DoEvents)
  else
    if (Owner.SyncMethod = smWindow) then
      SendEvents
    else
      DoEvents;
end;

procedure TComThread.SendEvents;
begin
  if (EV_RXCHAR and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_RXCHAR, 0);
  if (EV_TXEMPTY and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_TXEMPTY, 0);
  if (EV_BREAK and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_BREAK, 0);
  if (EV_RING and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_RING, 0);
  if (EV_CTS and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_CTS, 0);
  if (EV_DSR and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_DSR, 0);
  if (EV_RXFLAG and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_RXFLAG, 0);
  if (EV_RLSD and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_RLSD, 0);
  if (EV_ERR and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_ERR, 0);
  if (EV_RX80FULL and Mask) > 0 then
    SendMessage(Owner.FWindow, CM_COMPORT, EV_RX80FULL, 0);
end;

procedure TComThread.DoEvents;
begin
  if (EV_RXCHAR and Mask) > 0 then Owner.DoOnRxChar;
  if (EV_TXEMPTY and Mask) > 0 then Owner.DoOnTxEmpty;
  if (EV_BREAK and Mask) > 0 then Owner.DoOnBreak;
  if (EV_RING and Mask) > 0 then Owner.DoOnRing;
  if (EV_CTS and Mask) > 0 then Owner.DoOnCTS;
  if (EV_DSR and Mask) > 0 then Owner.DoOnDSR;
  if (EV_RXFLAG and Mask) > 0 then Owner.DoOnRxFlag;
  if (EV_RLSD and Mask) > 0 then Owner.DoOnRLSD;
  if (EV_ERR and Mask) > 0 then Owner.DoOnError;
  if (EV_RX80FULL and Mask) > 0 then Owner.DoOnRx80Full;
end;

// TComTimeouts

constructor TComTimeouts.Create(AComPort: TComPort);
begin
  ComPort := AComPort;
  FReadInterval := -1;
  FWriteTotalM := 100;
  FWriteTotalC := 1000;
end;

procedure TComTimeouts.AssignTo(Dest: TPersistent);
begin
  if Dest is TComTimeouts then begin
    with TComTimeouts(Dest) do begin
      FReadInterval := Self.FReadInterval;
      FReadTotalM := Self.FReadTotalM;
      FReadTotalC := Self.FReadTotalC;
      FWriteTotalM := Self.FWriteTotalM;
      FWriteTotalC := Self.FWriteTotalC;
      ComPort := Self.ComPort;
    end
  end
  else
    inherited AssignTo(Dest);
end;

procedure TComTimeouts.SetReadInterval(Value: Integer);
begin
  if Value <> FReadInterval then begin
    FReadInterval := Value;
    ComPort.SetTimeouts;
  end;
end;

procedure TComTimeouts.SetReadTotalC(Value: Integer);
begin
  if Value <> FReadTotalC then begin
    FReadTotalC := Value;
    ComPort.SetTimeouts;
  end;
end;

procedure TComTimeouts.SetReadTotalM(Value: Integer);
begin
  if Value <> FReadTotalM then begin
    FReadTotalM := Value;
    ComPort.SetTimeouts;
  end;
end;