connect.pas

一个delphi使用的传送短信(SMS)到GSM手机的单元及示范.

{ Connection components }
{ Copyright (c) 1999, 2000 by Mandys Tomas - Mandy Soft }
{ email: [e-mail] }
{ URL: http://www.2p.cz }

unit Connect;

interface
uses
  Classes, SysUtils, Windows, SyncObjs;

const
  lchOut = 1;
  lchIn = 2;
  lchError = 3;

type
  TConnection = class;

  TConnectionNotifyEvent = procedure(DataSet: TConnection) of object;

  TConnection = class(TComponent)
  private
    FActive: Boolean;
    FStreamedActive: Boolean;
    FBeforeOpen, FBeforeClose, FAfterOpen, FAfterClose: TConnectionNotifyEvent;
    procedure SetActive(aEnable: Boolean);
  protected
    procedure OpenConn; virtual; abstract;
    procedure CloseConn; virtual; abstract;
    procedure DoBeforeOpen; virtual;
    procedure DoBeforeClose; virtual;
    procedure DoAfterOpen; virtual;
    procedure DoAfterClose; virtual;
    procedure Loaded; override;
    procedure CheckInactive;
    procedure CheckActive;
  public
    destructor Destroy; override;
    procedure Open;
    procedure Close;
  published
    property Active: Boolean read FActive write SetActive;

    property BeforeOpen: TConnectionNotifyEvent read FBeforeOpen write FBeforeOpen;
    property BeforeClose: TConnectionNotifyEvent read FBeforeClose write FBeforeClose;
    property AfterOpen: TConnectionNotifyEvent read FAfterOpen write FAfterOpen;
    property AfterClose: TConnectionNotifyEvent read FAfterClose write FAfterClose;
  end;

  TAcceptChannelEvent = procedure(Sender: TComponent; const aLogName: string; aChannel: Byte; var aAccept: Boolean) of object;

  TLogger = class(TConnection)
  private
    FCriticalSection: TCriticalSection;
  protected
    FAcceptChannel: TAcceptChannelEvent;
    procedure DoLog(aText: string); virtual; abstract;
    function PreformatText(const aName: string; aChannel: Byte; aText: string): string; virtual; abstract;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    procedure Log(const aName: string; aChannel: Byte; aText: string);
  published
    property AcceptChannel: TAcceptChannelEvent read FAcceptChannel write FAcceptChannel;
  end;

  TLogFormatFlag = (lfInsertName, lfInsertChannel, lfDivideNames, lfDivideChannels, lfHexadecimal, lfStamp);
  TLogFormatFlags = set of TLogFormatFlag;

  TStreamLogger = class(TLogger)
  private
    FLogStream: TStream;
    FLogFlags: TLogFormatFlags;
    FMaxLineLength: Integer;
    FLastChannel: Byte;
    FLastName: string;
    FLineLength: Integer;
    procedure SetLogStream(Value: TStream);
  protected
    procedure OpenConn; override;
    procedure DoLog(aText: string); override;
    function PreformatText(const aName: string; aChannel: Byte; aText: string): string; override;
  public
    constructor Create(aOwner: TComponent); override;
    property LogStream: TStream read FLogStream write SetLogStream;
  published
    property LogFlags: TLogFormatFlags read FLogFlags write FLogFlags;
    property MaxLineLength: Integer read FMaxLineLength write FMaxLineLength;
  end;

  TFileLogger = class(TStreamLogger)
  private
    FLogFile: string;
    procedure SetLogFile(const aFile: string);
  protected
    procedure OpenConn; override;
    procedure CloseConn; override;
  public
  published
    property LogFile: string read FLogFile write SetLogFile;
  end;

  TFormatLogEvent = procedure(Sender: TComponent; aChannel: Byte; var aText: string) of object;

  TLogConnection = class(TConnection)
  private
    FLogger: TLogger;
    FOnFormatLog: TFormatLogEvent;
    FLogName: string;
  protected
    procedure DoFormatLog(aChannel: Byte; var aText: string); virtual;
  public
    procedure Log(aChannel: Byte; aText: string);
  published
    property Logger: TLogger read FLogger write FLogger;
    property LogName: string read FLogName write FLogName;
    property OnFormatLog: TFormatLogEvent read FOnFormatLog write FOnFormatLog;
  end;

  TCommunicationConnection = class(TLogConnection)
  public
    function Send(S: string): Integer;  { wait until not sent }
    function InQueCount: Integer; virtual; abstract;
    function Retrieve(aCount: Integer): string;
    procedure PurgeIn; virtual; abstract;
    procedure PurgeOut; virtual; abstract;
  protected
    function Write(const Buf; Count: Integer): Integer; virtual; abstract;
    function Read(var Buf; Count: Integer): Integer; virtual; abstract;
  end;

  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;

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

  TCommHandle = class;
  
  TCommEventThread = class(TThread)
  private
    FCommHandle: THandle;
    FEvent: TSimpleEvent;
    FEventMask: dWord;
    FComm: TCommHandle;
  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;
    FEvent: TSimpleEvent;
    FCriticalSection: TCriticalSection;
    FEventThread: TCommEventThread;
    FDontSynchronize: Boolean;
    FOnBreak: TNotifyEvent;
    FOnCts: TNotifyEvent;
    FOnDsr: TNotifyEvent;
    FOnError: TCommErrorEvent;
    FOnRing: TNotifyEvent;
    FOnRlsd: TNotifyEvent;
    FOnRxChar: TCommRxCharEvent;
    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);
    function GetComState(Index: Integer): Boolean;
    function GetModemState(Index: Integer): Boolean;
    procedure SetEsc(Index: Integer; Value: Boolean);
    procedure UpdateCommTimeouts;
    procedure UpdateDataControlBlock;
  protected
    procedure OpenConn; override;
    procedure CloseConn; override;
    procedure UpdateDCB; virtual;
    procedure EscapeComm(Flag: Integer);
    procedure HandleCommEvent(Status: dword); virtual;
    function Write(const Buf; Count: Integer): Integer; override;
    function Read(var Buf; Count: Integer): Integer; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property hCommDev: THandle read FhCommDev write SethCommDev;
    function InQueCount: Integer; override;
    function OutQueCount: Integer;
    procedure Lock;
    procedure Unlock;
    procedure PurgeIn; override;
    procedure PurgeOut; override;
    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;
    {Comm escape functions}
    property DTRState: Boolean index 1 write SetEsc;
    property RTSState: Boolean index 2 write SetEsc;
    property BREAKState: Boolean index 3 write SetEsc;
    property XONState: Boolean index 4 write SetEsc;
    {Comm status flags}
    property CTS: Boolean index Integer(MS_CTS_ON) read GetModemState;
    property DSR: Boolean index Integer(MS_DSR_ON) read GetModemState;
    property RING: Boolean index Integer(MS_RING_ON) read GetModemState;
    property RLSD: Boolean index Integer(MS_RLSD_ON) 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: Boolean read FDontSynchronize write FDontSynchronize;
    property FlowControl: TFlowControl read FFlowControl write SetFlowControl default fcDefault;
    property XonChar: Char index 1 read GetEventChar write SetEventChar default #17;
    property XoffChar: Char index 2 read GetEventChar write SetEventChar default #19;
    property ErrorChar: Char index 3 read GetEventChar write SetEventChar default #0;
    property EofChar: Char index 4 read GetEventChar write SetEventChar default #0;
    property EvtChar: Char index 5 read GetEventChar write SetEventChar default #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: TCommRxCharEvent read FOnRxChar write FOnRxChar;
    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;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property DeviceName: string read FDeviceName write SetDeviceName;
  end;

  EComError = class(Exception)
  end;

procedure Register;

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

resourcestring
  sActiveConnection = 'Connection is active';
  sInactiveConnection = 'Connection is inactive';
  sCommError = 'Error %d in function: %s';
implementation

const
  DefaultDeviceName = 'Com2';

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

procedure ComError2(const aFunc: string);
begin
  ComError(Format(sCommError, [GetLastError, aFunc]));
end;

destructor TConnection.Destroy;
begin
  Destroying;
  Close;
  inherited;
end;

procedure TConnection.Open;
begin
  Active:= True;
end;

procedure TConnection.Close;
begin
  Active:= False;
end;

procedure TConnection.SetActive;
begin
  if (csReading in ComponentState) then
  begin
    if aEnable then
      FStreamedActive := True;
  end
else
  if FActive <> aEnable then
  begin
    if aEnable then
      begin
        DoBeforeOpen;
        try
          OpenConn;
        except
          CloseConn;
          raise;
        end;
        FActive:= aEnable;
        DoAfterOpen;
      end
    else
      begin
        if not (csDestroying in ComponentState) then
          DoBeforeClose;
        CloseConn;
        FActive:= aEnable;
        if not (csDestroying in ComponentState) then
          DoAfterClose;
      end;
  end;
end;

procedure TConnection.DoBeforeOpen;
begin
  if Assigned(FBeforeOpen) then
    FBeforeOpen(Self);
end;

procedure TConnection.DoBeforeClose;
begin
  if Assigned(FBeforeClose) then
    FBeforeClose(Self);
end;

procedure TConnection.DoAfterOpen;
begin
  if Assigned(FAfterOpen) then
    FAfterOpen(Self);
end;

procedure TConnection.DoAfterClose;
begin
  if Assigned(FAfterClose) then
    FAfterClose(Self);
end;

procedure TConnection.Loaded;
begin
  inherited Loaded;
  if FStreamedActive then
    Active := True;
end;

procedure TConnection.CheckInactive;
begin
  if Active then
    ComError(sActiveConnection);
end;

procedure TConnection.CheckActive;
begin
  if not Active then
    ComError(sInactiveConnection);
end;

constructor TLogger.Create;
begin
  inherited;
  FCriticalSection:= TCriticalSection.Create;
end;

destructor TLogger.Destroy;
begin
  FCriticalSection.Free;
  inherited;
end;

procedure TLogger.Log;     // multithreaded
var
  F: Boolean;
begin
  if FActive then
  begin
    F:= True;
    if Assigned(FAcceptChannel) then
      FAcceptChannel(Self, aName, aChannel, F);
    if F then
    begin
      FCriticalSection.Enter;
      try
        DoLog(PreformatText(aName, aChannel, aText));
      finally
        FCriticalSection.Leave;
      end;
    end;
  end;
end;

constructor TStreamLogger.Create;
begin
  inherited;
  FLogFlags:= [lfInsertName, lfInsertChannel, lfDivideNames, lfDivideChannels, lfHexadecimal];
  FMaxLineLength:= 80;
end;

procedure TStreamLogger.SetLogStream;
begin
  CheckInactive;
  FLogStream:= Value;
end;

procedure TStreamLogger.DoLog;
begin
  FLogStream.WriteBuffer(aText[1], Length(aText));
end;

procedure TStreamLogger.OpenConn;
begin
  FLogStream.Position:= FLogStream.Size;
end;

function TStreamLogger.PreformatText;
const
  CRLF = #13#10;
var
  I: Integer;
  F: Boolean;
  function FormatCh(B: Byte): string;
  begin
    Result:= Format('%.2x)', [B]);
    if not (lfHexadecimal in FLogFlags) then
      Result:= Result+' ';
  end;
  procedure InsT(var S: string; const aT: string);
  begin
    S:= S+aT;
    Inc(FLineLength, Length(aT));
  end;
begin
  Result:= '';
  I:= 1;
  while I <= Length(aText) do
  begin
    if (FLastName <> aName) and (lfDivideNames in FLogFlags) or
       (FLastChannel <> aChannel) and (lfDivideChannels in FLogFlags) then
    begin
      FLineLength:= 0;
    end;
    F:= FLineLength = 0;
    if FLineLength = 0 then
    begin
      Result:= Result+CRLF;
      if lfStamp in FLogFlags then
        InsT(Result, DateTimeToStr(Now)+')');
    end;
    if ((FLastName <> aName) or F) and (lfInsertName in FLogFlags) then
      begin
        InsT(Result, aName+'-');
        if lfInsertChannel in FLogFlags then
          InsT(Result, FormatCh(aChannel));
      end
    else
      begin
        if ((FLastChannel <> aChannel) or F) and (lfInsertChannel in FLogFlags) then
          InsT(Result, FormatCh(aChannel));
      end;
    while I <= Length(aText) do
    begin
      if lfHexadecimal in FLogFlags then InsT(Result, Format('%.2x ', [Byte(aText[I])]))
                                    else InsT(Result, aText[I]);
      Inc(I);
      if (FMaxLineLength <> 0) and (FLineLength >= FMaxLineLength) then
      begin
        FLineLength:= 0;    // write on next line
      end;
    end;
  end;

  FLastChannel:= aChannel;
  FLastName:= aName;
end;

procedure TFileLogger.SetLogFile;
var
  SaveLogActive: Boolean;
begin
  if (csReading in ComponentState) then
  begin
    FLogFile:= aFile;
  end
else
  if aFile <> FLogFile then
  begin
    SaveLogActive:= Active;
    FActive:= False;
    FLogFile:= aFile;
    if FLogFile <> '' then
      Active:= SaveLogActive;
  end;
end;

procedure TFileLogger.OpenConn;