//這是一個串行控件的加強版,它繼承于SpCom.

// Author: 周益波 中國大陸
// Email:  zhouyibo2000@sina.com
// StartDate: 2001/9/14

// version 1.00: 2001/9/19
//               - 用戶收發數據更加方便,發送和接收數據都存在隊列中,方便操作.
//               - 簡化了對錯誤的處理過程,錯誤類型采用集中式管理.
//               - 自定義錯誤類型,可以是無限多個錯誤.
//               - 每個錯誤都有自己的重發次數和延遲時間.
//               - 錯誤次數可以是獨立計數,也可以是混合計數.

unit TSComm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SPComm, extctrls, MMSystem;

    {以下為接收數據的檢查結果消息}
{const TSCOM_USER                    = WM_USER + $100;       //用戶自定義消息
      TSCOM_ALLRIGHT                = TSCOM_USER + $1;      //完全正確
      TSCOM_TOPOVERTIMEERROR        = TSCOM_USER + $2;      //上位機超時錯誤
      TSCOM_TOPFRAMEFORMATERROR     = TSCOM_USER + $3;      //上位機幀格式錯誤
      TSCOM_TOPCHECKSUMERROR        = TSCOM_USER + $4;      //上位機校驗和錯誤
      TSCOM_BOTTOMOVERTIMEERROR     = TSCOM_USER + $5;      //下位機超時錯誤
      TSCOM_BOTTOMFRAMEFORMATERROR  = TSCOM_USER + $6;      //下位機幀格式錯誤
      TSCOM_BOTTOMCHECKSUMERROR     = TSCOM_USER + $7;      //下位機校驗和錯誤
      TSCOM_OTHERERROR              = TSCOM_USER + $8;      //其他錯誤
}

const TSCOM_NULL = -2;              //沒收到
      TSCOM_RIGHT = -1;             //收到錯誤

type
    {檢查結果}
  TTSComm = class;

  TErrorStyle = (esOverTime, esOther);

    {存儲結構的列表}
  TRecordList = class(TList)
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
  end;

    {接收數據事件}
  TTSReceiveDataEvent = procedure(Sender: TObject; Buffer: PChar; BufferLength: Word; HasSendData: Pointer;
                                  var ADataBuffer: string; var ErrorIndex: Integer) of object;

    {發送數據事件}
  TTSSendDataEvent = procedure(Sender: TObject; SendData: Pointer) of object;

    {接收數據錯誤事件}
  TTSReceiveErrorEvent = procedure(Sender: TObject; HasSendData: Pointer; ErrorIndex: Integer) of object;

    {分類錯誤事件}
  TTSSingleReceiveErrorEvent = procedure(Sender: TObject; HasSendData: Pointer; ErrorCount: Integer) of object;

    {錯誤設置類}
  TCustomErrorOption = class(TCollectionItem)
  private
    FErrorStyle: TErrorStyle;
    FCount: Word;
    FDelay: Longword;
    FTimeIndex: Integer;
    FIndex: Word;
    FSendInfoList: TRecordList;
    FDateTime: TDateTime;
    FText: string;
    FEnabled: Boolean;
    FOnTSSingleReceiveError: TTSSingleReceiveErrorEvent;
    procedure SetCount(const ACount: Word);
    procedure SetDelay(const ADelay: Longword);
    procedure SetErrorIndex(const AIndex: Word);
    procedure SetDateTime(const ADateTime: TDateTime);
    procedure SetText(const AText: string);
    procedure SetErrorStyle(const AErrorStyle: TErrorStyle);
    procedure SetEnabled(const AEnabled: Boolean);
    procedure SetTimeIndex(const Value: Integer);
  protected
    function GetDisplayName: string; override;
    property Index: Word read FIndex write SetErrorIndex;
    property DateTime: TDateTime read FDateTime write SetDateTime;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function AddSendInfoValue(Value: Pointer): Integer;
    property TimeIndex: Integer read FTimeIndex Write SetTimeIndex;
    property SendInfoList: TRecordList read FSendInfoList;
  published
    property Count: Word read FCount write SetCount;
    property Delay: Longword read FDelay write SetDelay;
    property Text: string read FText write SetText;
    property Enabled: Boolean read FEnabled write SetEnabled;
    property ErrorStyle: TErrorStyle read FErrorStyle write SetErrorStyle;
    property OnTSSingleReceiveError: TTSSingleReceiveErrorEvent
      read FOnTSSingleReceiveError write FOnTSSingleReceiveError;
  end;

  TErrorOptions = class(TCollection)
  private
    FTSComm: TTSComm;
    FCurrentErrorOption: TCustomErrorOption; //當前錯誤
    FOverTimeErrorOption: TCustomErrorOption;//超時錯誤
    function GetItem(Index: Integer): TCustomErrorOption;
    procedure SetItem(Index: Integer; Value: TCustomErrorOption);
    procedure SetOverTimeErrorOption(const Value: TCustomErrorOption);
    procedure SetCurrentErrorOption(const Value: TCustomErrorOption);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(TSComm: TTSComm);
    function Add: TCustomErrorOption;
    property Items[Index: Integer]: TCustomErrorOption read GetItem write SetItem; default;
    property CurrentErrorOption: TCustomErrorOption read FCurrentErrorOption write SetCurrentErrorOption;
    property OverTimeErrorOption: TCustomErrorOption read FOverTimeErrorOption write SetOverTimeErrorOption stored True;
  end;

  TGeneralOption = class(TPersistent)
  private
    FTSComm: TTSComm;
    FIsSingleCountError: Boolean;  //錯誤次數是否獨立
    FIsSingleIndexError: Boolean;  //錯誤當前次數是否獨立
    FIsSingleDelayError: Boolean;  //錯誤延遲時間是否獨立
    FIsCumulateError: Boolean;     //錯誤是否累積
    FErrorCount: Word;             //錯誤總次數
    FErrorDelay: Cardinal;         //錯誤延遲時間
    FErrorIndex: Word;             //錯誤次數
    FSucceedDelay: Cardinal;       //接收數據成功后延遲
    FSucceedDelayIndex: Cardinal;  //接收數據成功后當前延遲
    FSucceedCount: Word;           //成功次數
    FSucceedCountIndex: Word;      //成功當前次數
    procedure SetErrorCount(const Value: Word);
    procedure SetErrorDelay(const Value: Cardinal);
    procedure SetIsCumulateError(const Value: Boolean);
    procedure SetIsSingleCountError(const Value: Boolean);
    procedure SetIsSingleDelayError(const Value: Boolean);
    procedure SetIsSingleIndexError(const Value: Boolean);
    procedure SetSucceedCount(const Value: Word);
    procedure SetSucceedDelay(const Value: Cardinal);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(TSComm: TTSComm); virtual;
  published
    property IsSingleCountError: Boolean read FIsSingleCountError write SetIsSingleCountError;
    property IsSingleDelayError: Boolean read FIsSingleDelayError write SetIsSingleDelayError;
    property IsSingleIndexError: Boolean read FIsSingleIndexError write SetIsSingleIndexError;
    property IsCumulateError: Boolean read FIsCumulateError write SetIsCumulateError;
    property ErrorCount: Word read FErrorCount write SetErrorCount;
    property ErrorDelay: Cardinal read FErrorDelay write SetErrorDelay;
    property SucceedDelay: Cardinal read FSucceedDelay write SetSucceedDelay;
    property SucceedCount: Word read FSucceedCount write SetSucceedCount;
  end;

    {串行通訊加強類}
  TTSComm = class(TComm)
  private
    FErrorOptions: TErrorOptions;
    FGeneralOption: TGeneralOption;
///////////////////////////////////////////////////////////////////////////////////////

    FSendList: TRecordList;           //發送數據列表
    FReceiveList: TRecordList;        //接收數據列表
    FSendRecord: Pointer;             //發送的數據

    FDataBuffer: string;              //經過自定義檢查后的數據

    FTimeID: Longint;                 //多媒體定時器的返回值

    FHasSend: Boolean;                //數據是否已經發送
    FHasReceive: Boolean;             //數據是否已經接收

    {接受數據事件,在這里可以檢測接收的數據的格式是否符合通訊協議}
    FOnTSReceiveData: TTSReceiveDataEvent;
    {發送數據事件,在這里可以編寫怎樣發送數據}
    FOnTSSendData: TTSSendDataEvent;
    {接收數據錯誤事件,在這里可以編寫錯誤處理事件}
    FOnTSReceiveError: TTSReceiveErrorEvent;

    procedure SetDataBuffer(Value: string);
      {定時事件}
    procedure TimeProcedure;
    procedure SetErrorOption(ACustomErrorOption: TCustomErrorOption);
    procedure ClearErrorOptionIndex;
    procedure ClearErrorOptionTimeIndex;
    procedure SetGeneralOption(const Value: TGeneralOption);
  protected
    function Perform(Msg: Cardinal; WParam, LParam: Longint): Longint;
    procedure ReceiveData(Buffer: PChar; BufferLength: Word); override;
    procedure SetErrorOptions(Value: TErrorOptions);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
      {發送本列表頭數據}
    function SendAgain: boolean;
      {發送下一項數據}
    function SendNext: boolean;
      {把發送數據添加進列表}
    function AddToSendList(AItem: Pointer): Integer;
      {把接收數據添加進列表}
    function AddToReceiveList(AItem: Pointer): Integer;
    procedure DeleteReceiveList(Index: Integer);

    property DataBuffer: string read FDataBuffer write SetDataBuffer;
    property SendList: TRecordList read FSendList write FSendList;
    property ReceiveList: TRecordList read FReceiveList write FReceiveList;
    property SendRecord: pointer read FSendRecord;

  published
    property ErrorOptions: TErrorOptions read FErrorOptions write SetErrorOptions;
    property GeneralOption: TGeneralOption read FGeneralOption write SetGeneralOption;

    property OnTSReceiveData: TTSReceiveDataEvent
      read FOnTSReceiveData write FOnTSReceiveData;
    property OnTSSendData: TTSSendDataEvent
      read FOnTSSendData write FOnTSSendData;
    property OnTSReceiveError: TTSReceiveErrorEvent
      read FOnTSReceiveError write FOnTSReceiveError;

  end;

  {回調函數,多謀體定時器}
procedure TimeProc(uID, uMsg, dwUser, dw1, dw2: Longint) stdcall;

var TSComm1: TTSComm;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Custom', [TTSComm]);
end;

{ TTSComm }

function TTSComm.Perform(Msg: Cardinal; WParam, LParam: Integer): Longint;
var
  Message: TMessage;
begin
  Message.Msg := Msg;
  Message.WParam := WParam;
  Message.LParam := LParam;
  Message.Result := 0;
  if Self <> nil then Dispatch(Message);
  Result := Message.Result;
end;

procedure TimeProc(uID, uMsg, dwUser, dw1, dw2: Longint) stdcall;
begin
  TSComm1.TimeProcedure;
end;

procedure TTSComm.TimeProcedure;
begin
  if FErrorOptions.CurrentErrorOption <> nil then
  begin
    FErrorOptions.CurrentErrorOption.TimeIndex := FErrorOptions.CurrentErrorOption.TimeIndex + 1;
    if FErrorOptions.CurrentErrorOption.TimeIndex > FErrorOptions.CurrentErrorOption.Delay then
    begin
      FErrorOptions.CurrentErrorOption.TimeIndex := 0;
      FErrorOptions.CurrentErrorOption := FErrorOptions.OverTimeErrorOption;
      SetErrorOption(FErrorOptions.CurrentErrorOption);
    end;
  end;
end;

procedure TTSComm.ReceiveData(Buffer: PChar; BufferLength: Word);
var ErrorIndex: Integer;
begin
  inherited ReceiveData(Buffer, BufferLength);
  if Assigned(FOnTSReceiveData) then
  begin
    ErrorIndex := TSCOM_NULL;
    FDataBuffer := '';
    FOnTSReceiveData(self, Buffer, BufferLength, FSendRecord, FDataBuffer, ErrorIndex);
    if (ErrorIndex >= 0) and (FErrorOptions[ErrorIndex].Enabled) then
    begin
      if FHasSend then
      begin
        FErrorOptions.CurrentErrorOption := FErrorOptions[ErrorIndex];
        SetErrorOption(FErrorOptions.CurrentErrorOption);
      end;
      FHasSend := False;
    end else if ErrorIndex = TSCOM_RIGHT then
    begin
      FErrorOptions.CurrentErrorOption.TimeIndex :=
        FErrorOptions.CurrentErrorOption.FDelay - FGeneralOption.FSucceedDelay;
      FHasReceive := True;
    end;
  end;
end;

procedure TTSComm.SetErrorOption(ACustomErrorOption: TCustomErrorOption);

  procedure SetErrorEvent(var AErrorIndex: Word; AErrorCount: Word);
  begin
    Inc(AErrorIndex);
    if Assigned(ACustomErrorOption.FOnTSSingleReceiveError) then
      ACustomErrorOption.FOnTSSingleReceiveError(ACustomErrorOption,
        FSendRecord, AErrorIndex);
    begin
      if AErrorIndex > AErrorCount then
      begin
        AErrorIndex := 0;
        if Assigned(FOnTSReceiveError) then
          FOnTSReceiveError(Self, FSendRecord, ACustomErrorOption.ID);
        if ACustomErrorOption.ErrorStyle = esOverTime then
          FHasSend := SendNext;
      end else
      begin
        if ACustomErrorOption.ErrorStyle = esOverTime then
          FHasSend := SendAgain;
      end;
    end;
  end;

  procedure SetSendData(var AErrorIndex: Word; AErrorCount: Word);
  begin
  end;

begin
  if not FHasReceive then     //如果沒有收到
  begin
    if FHasSend then          //如果已經發送
    begin
      if FGeneralOption.IsSingleCountError then
      begin
        if FGeneralOption.IsSingleIndexError then
          SetErrorEvent(FGeneralOption.FErrorIndex, ACustomErrorOption.Count)
        else
          SetErrorEvent(ACustomErrorOption.FIndex, ACustomErrorOption.Count);
      end else
      begin
        SetErrorEvent(FGeneralOption.FErrorIndex, FGeneralOption.ErrorCount);
      end;
    end else                  //沒有發送
    begin
      FHasSend := SendAgain;
    end;
  end else FHasSend := SendNext;
  FHasReceive := False;