利用 ScktSrvr 打造多功能 Socket 服務器

bestlong

利用ScktSrvr打造多功能Socket服務器

Socket服務端編程中最重要的也是最難處理的工作便是客戶請求的處理和數據的接收和發送，如果每一個Socket服務器應用程序的開發都要從頭到尾處理這些事情的話，人將會很累，也會浪費大量時間。試想，如果有一個通用的程序把客戶請求處理和數據的接收、發送都處理好了，程序員只需要在不同的應用中對接收到的數據進行不同的解析並生成返回的數據包，再由這個通用程序將數據包傳回客戶端，這樣，程序設計的工作將會輕鬆許多。
用Delphi進行過三層數據庫應用開發的程序員一定對Borland公司的Borland Socket Server(ScktSrvr.exe)不陌生。這是一個典型的Socket服務器程序，認真讀過該軟件的源程序的人一定會讚歎其程序編寫的高明。其程序風格堪稱典範。但它是專用於配合Borland的MIDAS進行多層應用開發的。它能不能讓我們實現上面的設想，以便我們應用到不同的應用中去呢？

隨我來吧，你會有收穫的。

首先，讓我們搞清楚它的工作方式和過程，以便看能不能用它完成我們的心願，當然改動不能太大，否則我沒耐心也沒有能力去做。

從主窗體的代碼開始：不論是以系統服務方式啟動程序或直接運行程序，當程序運行時，都會執行主窗體初始化方法：

TSocketForm.Initialize(FromService: Boolean);

該方法代碼簡單易讀，為節省篇幅在此不列出它的源代碼。該方法從註冊表鍵“HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Socket Server”中讀取端口信息，每讀到一個端口，則：創建一個TSocketDispatcher的實例，並調用該實例的ReadSettings方法讀取註冊表數據來初始化該實例，然後激活該實例。

TSocketDispatcher繼承自TServerSocket，是服務端Socket，當激活時便進入監聽狀態，監聽客戶端連接。當有客戶端連接時，觸發TSocketDispatcher實例的GetThread事件過程：

procedure TSocketDispatcher.GetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  SocketThread := TSocketDispatcherThread.Create(False, ClientSocket,
    InterceptGUID, Timeout, SocketForm.RegisteredAction.Checked, SocketForm.AllowXML.Checked);
end;

該事件過程為每一個客戶端連接創建一個TSocketDispatcherThread類的服務線程為該客戶端服務，其核心過程就是TSocketDispatcherThread的ClientExecute方法。對該方法的分析可以知道，它主要工作有兩個：一是創建一個傳送器對象(TSocketTransport)負責與客戶端進行數據傳輸，二是創建一個數據塊解析器對象（TDataBlockInterpreter）負責解析傳送器對象接收到的客戶端請求數據包。

procedure TSocketDispatcherThread.ClientExecute;
var
  Data: IDataBlock;
  msg: TMsg;
  Obj: ISendDataBlock;
  Event: THandle;
  WaitTime: DWord;
begin
  CoInitialize(nil); //初始化COM對像庫
  try
    Synchronize(AddClient); //顯示客戶信息
    FTransport := CreateServerTransport; //創建傳送器對象,注意FTransport和下面的FInterpreter是線程對象的屬性而不是局部變量
    try
      Event := FTransport.GetWaitEvent;
      PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE); / /建立線程消息隊列
      GetInterface(ISendDataBlock, Obj); //獲得TSocketDispatcherThread線程對象的ISendDataBlock接口
      if FRegisteredOnly then
        //創建數據塊解析器對象，注意ISendDataBlock接口實例Obj作為參數傳入了TDataBlockInterpreter的Create方法中
        FInterpreter : = TDataBlockInterpreter.Create(Obj, SSockets) else   
        FInterpreter := TDataBlockInterpreter.Create(Obj, '');            
      try
        Obj := nil;
        if FTimeout = 0 then
          WaitTime := INFINITE else
          WaitTime := 60000;
        while not Terminated and FTransport. Connected do
        try
          case MsgWaitForMultipleObjects(1, Event, False, WaitTime, QS_ALLEVENTS) of
            WAIT_OBJECT_0:
            begin
              WSAResetEvent(Event);
              Data := FTransport.Receive(False, 0); //傳送器對象接收客戶端數據
              if Assigned(Data ) then //接收成功
              begin
                FLastActivity := Now;
                FInterpreter.InterpretData(Data); //數據塊解析器對像對數據進行解析
                Data := nil;
                FLastActivity := Now;
              end;
            end;
            WAIT_OBJECT_0 + 1:
              while PeekMessage (msg, 0, 0, 0, PM_REMOVE) do
                DispatchMessage(msg);
            WAIT_TIMEOUT:
              if (FTimeout > 0) and ((Now - FLastActivity) > FTimeout) then
                FTransport.Connected := False;
          end;
        except
          FTransport.Connected : = False;
        end;
      finally
        FInterpreter.Free; //釋放數據塊解析器對象
        FInterpreter := nil;
      end;
    finally
      FTransport := nil; //釋放傳送器對象
    end;
  finally
    CoUninitialize; //關閉COM對像庫
    Synchronize( RemoveClient); //刪除顯示的客戶信息
  end;
end;

在代碼中我們沒有看到如何向客戶端傳回數據的過程，這項工作是由數據塊解析器對象、傳送器對象和接口ISendDataBlock（TSocketDispatcherThread實現了該接口）共同協調完成的。從以上代碼我們注意到，線程對象的ISendDataBlock接口(Obj變量)被作為參數傳入了TDataBlockInterpreter的Create方法中，實際上也就是線程對像被傳遞到了數據塊解析器對像中，後面我們將看到，數據塊解析器完成數據解析後，會創建一個新的數據塊（TDataBlock）對象來打包要返回到客戶端的數據，然後調用ISendDataBlock接口的Send方法（實際上是TSocketDispatcherThread的Send方法）將數據發送到客戶端，而TSocketDispatcherThread的Send方法最終調用傳送器對象（TSocketDispatcherThread的FTransport）的Send方法進行實際的數據傳輸。看下面的代碼我們就清楚這一點：

{ TSocketDispatcherThread.ISendDataBlock }

function TSocketDispatcherThread.Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock;
begin
  //用傳送器對象回傳數據，其中Data是由數據塊解析器創建的數據塊對象，以接口類型參數的方式傳到該函數
  FTransport.Send(Data);   
  //當數據塊解析器需要進行連續的數據回傳（如數據太大，一次不能不能回傳所有數據）時，
  //它向WaitForResult參數傳入True，SocketDispatcherThread就會
  //在一次發送數據之後檢索並解析客戶端的回應，決定是否繼續回傳數據。
  if WaitForResult then     
    while True do           
    begin
      Result := FTransport.Receive(True, 0); //檢索客戶端回應
      if Result = nil then break;
      if (Result.Signature and ResultSig) = ResultSig then
        break else
        FInterpreter.InterpretData(Result ); //解析客戶端回應
    end;
end;

從上面的簡單分析我們知道，在一次C/S會話過程中用到了幾個對象，分別是：傳送器(TSocketTransport)對象，數據塊解析器（TDataBlockInterpreter）對象，數據塊（TDataBlock）對象，還有就是ISendDataBlock接口，它由TSocketDispatcherThread實現。而數據處理主要在前兩者，它們分工很明確，而這兩者的協調就是通過後兩者實現。

對象間的明確分工和有序合作給我們改造提供了條件。再看離我們的設想有多遠。1、客戶請求的處理：TSocketDispatcher已經為我們做得很好了，這方面我們基本不需要改動。2、數據的接收：就看傳送器能不能接收不同類型的數據了，若不能，再看方不方便派生和使用新的傳送器類。3、發送數據：用TSocketDispatcherThread的Send方法就完成了，我們只需在解析請求後生成返回的數據塊對象，傳遞給該方法就可以了。4、解析數據：不同的應用中對數據的解析肯定是不同的，只有用新的解析器類去實現，主要看在TSocketDispatcherThread的ClientExecute方法中能否應用不同的解析器類。

從接收數據開始。

數據接收由傳送器(TSocketTransport)對象完成，該類在Sconnect單元中（請先將Sconnect單元做一個備份），我們看它的接收（Receive）方法：

function TSocketTransport.Receive(WaitForInput: Boolean; Context: Integer): IDataBlock;
var
  RetLen, Sig, StreamLen: Integer;
  P: Pointer;
  FDSet: TFDSet;
  TimeVal: PTimeVal;
  RetVal: Integer;
begin
  Result := nil;
  TimeVal := nil;
  FD_ZERO(FDSet);
  FD_SET(FSocket.SocketHandle, FDSet);
  if not WaitForInput then
  begin
    New(TimeVal);
    TimeVal.tv_sec := 0;
    TimeVal.tv_usec := 1;
  end;
  RetVal := select(0, @ FDSet, nil, nil, TimeVal);
  if Assigned(TimeVal) then
    FreeMem(TimeVal);
  if RetVal = SOCKET_ERROR then
    raise ESocketConnectionError.Create(SysErrorMessage(WSAGetLastError));
  if (RetVal = 0) then Exit;
  //以上代碼與Socket原理密切相關，功能是實現數據接收控制，本人理解還不是很透，也不需要改動它。
  //以下代碼才開始接收數據
  RetLen := FSocket.ReceiveBuf(Sig, SizeOf(Sig)); //檢索數據簽名
  if RetLen <> SizeOf(Sig) then
    raise ESocketConnectionError.CreateRes(@SSocketReadError); //出錯
  CheckSignature (Sig); //檢查數據標誌，若不合法則產生異常
  RetLen := FSocket.ReceiveBuf(StreamLen, SizeOf(StreamLen)); //檢索數據長度
  if RetLen = 0 then
    raise ESocketConnectionError.CreateRes(@SSocketReadError); / /出錯
  if RetLen <> SizeOf(StreamLen) then
    raise ESocketConnectionError.CreateRes(@SSocketReadError); //出錯
  Result := TDataBlock.Create as IDataBlock; //創建數據塊對象
  Result.Size := StreamLen; //設置數據塊對象的Size，即數據長度
  Result.Signature := Sig; //設置數據塊對象的數據標誌
  P := Result.Memory; //取得數據塊對象的內存指針
  Inc(Integer(P), Result.BytesReserved) ; //跳過保留字節數
  while StreamLen > 0 do //接收StreamLen字節的數據並寫入數據塊對象的數據域
  begin
    RetLen := FSocket.ReceiveBuf(P^, StreamLen);
    if RetLen = 0 then
      raise ESocketConnectionError.CreateRes(@SSocketReadError);
    if RetLen > 0 then
    begin
      Dec(StreamLen, RetLen);
      Inc(Integer(P), RetLen);
    end;
  end;
  if StreamLen <> 0 then
    raise ESocketConnectionError.CreateRes(@SInvalidDataPacket) ; //出錯
  InterceptIncoming(Result); //如果採用了加密、壓縮等處理過數據，在此將其還原
end;

分析到此，我們得先了解一下數據塊對象，它並不復雜，因此在此不對其代碼進行分析，只簡單說明它的結構。其實從MIDAS應用的客戶端傳來的請求就是一個數據塊，上述接收過程將其接收後還原成一個數據塊對象。注意不要混淆數據塊和數據塊對象，前者是數據流，後者是一個對象，封裝了數據塊和對數據塊操作的方法。數據塊的前8個字節（兩個整數）為保留字節（BytesReserved=8），分別是數據塊簽名（Signature）和實際數據長度（Size），緊接著才是實際的數據，其長度由Size域指定。數據塊簽名取值於一些預定義的常量，這些常量定義在SConnect單元中，如下：

const

  { Action Signatures }

  CallSig = $DA00; // Call signature
  ResultSig = $DB00; // Result signature
  asError = $01; // Specify an exception was raised
  asInvoke = $02; // Specify a call to Invoke
  asGetID = $03; // Specify a call to GetIdsOfNames
  asCreateObject = $04; // Specify a com object to create
  asFreeObject = $05; // Specify a dispatch to free
  asGetServers = $10; // Get classname list
  asGetGUID = $11; // Get GUID for ClassName
  asGetAppServers = $12; // Get AppServer classname list
  asSoapCommand = $14; // Soap command
  asMask = $FF; // Mask for action

從傳送器的接收方法可看出，如果接收到的數據簽名不合法，將引發異常，後續數據就不再接收。再看下面對簽名的檢查：

procedure CheckSignature(Sig: Integer);
begin
  if (Sig and $FF00 <> CallSig) and
     (Sig and $FF00 <> ResultSig) then
    raise Exception.CreateRes(@SInvalidDataPacket);
end;

簽名的高字節必須為CallSig或ResultSig，滿足這個條件就可通過接收檢查這一關，後續數據就可正常接收。簽名的低字節由解析器解析，以實現不同的數據處理。

對數據簽名的檢查使得Scktsrvr.exe的應用範圍局限於MIDAS應用。如果我們要做成通用Socket服務器，比如做一個WWW服務器或做一個HTTP代理服務器，客戶端（瀏覽器）發送來的請求（Http請求根本就不符合數據塊的結構）是通不過檢查的，連請求都無法接收，更談不上處理了。因此這是首先要改造的部分。

為了使服務器保留MIDAS的功能，又能用於其他Socket應用，我把數據傳輸分為MIDAS數據傳輸和自定義數據傳輸，如果是前者，接收方法自然不需變動，如果是後者，則跳過兩個保留字節的接收，直接接收數據寫到數據塊對像中，至於數據解析，前面說過，是必須用新的解析器類的，我們在新的解析器中處理。改造很簡單：

1、給傳送器類添加一個IsCustomTrans屬性：

  TSocketTransport = class(TInterfacedObject, ITransport)
  private
    ...
    FIsCustomTrans: Boolean; { === My Code === }
    ...
  public
    ...
    property IsCustomTrans: Boolean read FIsCustomTrans write FIsCustomTrans; { === My Code == = }
  end;

2、改寫TSocketTransport的Receive方法：

function TSocketTransport.Receive(WaitForInput: Boolean; Context: Integer): IDataBlock;
var
  RetLen, Sig, StreamLen: Integer;
  P: Pointer;
  FDSet: TFDSet;
  TimeVal: PTimeVal;
  RetVal: Integer;
begin
  ...
  if (RetVal = 0 ) then Exit;
  if not IsCustomTrans then { === My Code === }
    begin
      RetLen := FSocket.ReceiveBuf(Sig, SizeOf(Sig));
      ...
      if RetLen <> SizeOf(StreamLen) then
        raise ESocketConnectionError.CreateRes (@SSocketReadError);
    end
  else
    StreamLen:=FSocket.ReceiveLength; { === My Code === }
  Result := TDataBlock.Create as IDataBlock;
  if not IsCustomTrans then { === My Code === }
    Result.Signature := Sig;
  ...
end;

2、TSocketTransport的Send方法用於實際回傳數據，也需改寫：

function TSocketTransport.Send(const Data: IDataBlock): Integer;
var
  P: Pointer;
begin
  Result := 0;
  InterceptOutgoing(Data);
  P := Data.Memory;
  if IsCustomTrans then { === My Code === }
    FSocket .SendBuf(PByteArray(P)^[Data.BytesReserved],Data.Size) { === My Code ===不發送保留字節}
  else
    FSocket.SendBuf(P^, Data.Size + Data.BytesReserved);
end;

到此，發送和接收的處理就改造完了，只用了幾行代碼，是不是很簡單？

接下來要處理的是數據解析。

MIDAS的數據解析器類為TDataBlockInterpreter，它繼承於TCustomDataBlockInterpreter。這兩個類也在Sconnect單元中，定義如下：

  TCustomDataBlockInterpreter = class
  protected
    procedure AddDispatch(Value: TDataDispatch); virtual; abstract;
    procedure RemoveDispatch(Value: TDataDispatch); virtual; abstract;

    { Sending Calls }
    procedure CallFreeObject(DispatchIndex: Integer); virtual; abstract;
    function CallGetIDsOfNames(DispatchIndex: Integer; const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall; abstract ;
    function CallInvoke(DispatchIndex, DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall; abstract;
    function CallGetServerList: OleVariant; virtual; abstract;

    { Receiving Calls }

    function InternalCreateObject(const ClassID: TGUID): OleVariant; virtual; abstract;
    function CreateObject(const Name: string): OleVariant; virtual; abstract;
    function StoreObject(const Value: OleVariant): Integer; virtual; abstract;
    function LockObject(ID: Integer): IDispatch; virtual; abstract;
    procedure UnlockObject(ID: Integer; const Disp: IDispatch); virtual; abstract;
    procedure ReleaseObject(ID: Integer); virtual; abstract;
    function CanCreateObject(const ClassID: TGUID): Boolean; virtual ; abstract;
    function CallCreateObject(Name: string): OleVariant; virtual; abstract;
  public
    procedure InterpretData(const Data: IDataBlock); virtual; abstract;
  end;


  { TBinary... }
  TDataBlockInterpreter = class(TCustomDataBlockInterpreter)
  private
    FDispatchList: TList;
    FDispList: OleVariant;
    FSendDataBlock: ISendDataBlock;
    FCheckRegValue: string;
    function GetVariantPointer(const Value: OleVariant): Pointer;
    procedure CopyDataByRef(const Source: TVarData; var Dest : TVarData);
    function ReadArray(VType: Integer; const Data: IDataBlock): OleVariant;
    procedure WriteArray(const Value: OleVariant; const Data: IDataBlock);
    function ReadVariant(out Flags: TVarFlags; const Data: IDataBlock): OleVariant;
    procedure WriteVariant(const Value: OleVariant; const Data: IDataBlock);
    procedure DoException(const Data: IDataBlock);
  protected
    procedure AddDispatch(Value: TDataDispatch); override;
    procedure RemoveDispatch(Value: TDataDispatch); override;
    function InternalCreateObject(const ClassID: TGUID ): OleVariant; override;
    function CreateObject(const Name: string): OleVariant; override;
    function StoreObject(const Value: OleVariant): Integer; override;
    function LockObject(ID: Integer): IDispatch; override;
    procedure UnlockObject(ID: Integer ; const Disp: IDispatch); override;
    procedure ReleaseObject(ID: Integer); override;
    function CanCreateObject(const ClassID: TGUID): Boolean; override;

    {Sending Calls}
    procedure CallFreeObject(DispatchIndex: Integer); override;
    function CallGetIDsOfNames(DispatchIndex: Integer; const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; override;
    function CallInvoke(DispatchIndex, DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; override;
    function CallGetServerList: OleVariant; override;

    {Receiving Calls}
    procedure DoCreateObject(const Data: IDataBlock);
    procedure DoFreeObject(const Data: IDataBlock);
    procedure DoGetIDsOfNames(const Data: IDataBlock);
    procedure DoInvoke(const Data: IDataBlock);
    function DoCustomAction(Action: Integer; const Data: IDataBlock): Boolean; virtual;
    procedure DoGetAppServerList(const Data: IDataBlock);
    procedure DoGetServerList(const Data: IDataBlock);

  public
    constructor Create(SendDataBlock: ISendDataBlock; CheckRegValue: string);
    destructor Destroy; override;
    function CallCreateObject(Name: string): OleVariant; override;
    procedure InterpretData(const Data: IDataBlock); override;
  end;

TCustomDataBlockInterpreter類完全是一個抽像類，它的方法全是虛擬、抽象方法。TDataBlockInterpreter繼承於它，實現了它的所有方法。

TDataBlockInterpreter如何解析數據塊我們就不去理它了，因為我們不用動它，我們要做的是自己的解析器類。如果有興趣的話，網上搜索一下“讀一讀Scktsrvr.exe的源程序”。

要創建我們自己的解析器類，很自然想到的就是從TCustomDataBlockInterpreter繼承，象TDataBlockInterpreter類一樣一個個實現它的虛擬方法。但是且慢，先考慮一下，實現這一大堆的方法對我們有用嗎？這些方法主要是用於響應MIDAS客戶的數據庫訪問請求的。雖然我們可以因為用不上而在方法的實現中置之不理，但是拷貝這一大堆方法到新類中並生成一大串無用的空方法就是一件煩人的事情，有些函數類方法還必須得寫一行無用的返回值行，浪費時間。因此，我決定為TCustomDataBlockInterpreter創建一個祖先類。

解析器類的主要方法就是：

procedure InterpretData(const Data: IDataBlock);

這一個方法從TCustomDataBlockInterpreter類移到新的解析器祖先類中，新的解析器祖先類定義和實現如下：

type

  TBaseDataBlockInterpreter = class     
  protected
    FDispatchList: TList;
    FSendDataBlock: ISendDataBlock;
  public
    constructor Create(SendDataBlock: ISendDataBlock; CheckRegValue: string);
    destructor Destroy; override;
    procedure InterpretData(const Data: IDataBlock); virtual; abstract;
    function DisconnectOnComplete: Boolean; virtual;
  end;

implementation

constructor TBaseDataBlockInterpreter.Create(SendDataBlock: ISendDataBlock;CheckRegValue: string);
begin
  inherited Create;
  FDispatchList := TList.Create;
  FSendDataBlock:=SendDataBlock;
  //CheckRegValue未用，保留該參數只是使該方法與TDataBlockInterpreter參數一致
end;

destructor TBaseDataBlockInterpreter.Destroy;
var
  i: Integer;
begin
  for i := FDispatchList.Count - 1 downto 0 do
    TDataDispatch(FDispatchList).FInterpreter := nil;
  FDispatchList.Free;
  FSendDataBlock := nil;
  inherited;
end;

function TBaseDataBlockInterpreter.DisconnectOnComplete: Boolean;
begin
  Result:=False;
end;

該類中有關FDispatchList的代碼是直接從TDataBlockInterpreter類中移過來的（藍色字部分），如果不移到此，當MIDAS客戶端斷開連接時服務端會出錯，我不明白是為什麼。該類加了一個虛擬方法DisconnectOnComplete，簡單地返回False。設置該方法的目的是用於一些服務端完成服務後主動斷開連接的應用，在子類中重載該方法並返回True即可，這將在後面敘述。TCustomDataBlockInterpreter類從TBaseDataBlockInterpreter繼承，並取消InterpretData方法：

  TCustomDataBlockInterpreter = class(TBaseDataBlockInterpreter) { === Modified === }
  protected
    ...
  public
    //procedure InterpretData(const Data: IDataBlock); virtual; abstract; { === Modified === }
  end;

對TDataBlockInterpreter的更改也很簡單：

  TDataBlockInterpreter = class(TCustomDataBlockInterpreter)   
  private
    //FDispatchList: TList; { === Modified === }
    FDispList: OleVariant;
    //FSendDataBlock: ISendDataBlock; { === Modified === }     
    ...
  protected
    ...
  public
    . ..
  end;

constructor TDataBlockInterpreter.Create(SendDataBlock: ISendDataBlock; CheckRegValue: string);
begin
  inherited Create(SendDataBlock, CheckRegValue); { === Modified === }
  //FSendDataBlock := SendDataBlock; { === Modified === }
  // FDispatchList := TList.Create; { === Modified === }
  FCheckRegValue := CheckRegValue;
end;

destructor TDataBlockInterpreter.Destroy; //該方法的代碼都註釋完了，可以刪除該方法
//var
// i: Integer;
begin
// for i := FDispatchList.Count - 1 downto 0 do
// TDataDispatch(FDispatchList[i ]).FInterpreter := nil;
// FDispatchList.Free;
// FSendDataBlock := nil;        
  inherited Destroy;
end;


至此，對解析器類的修改完成。當某應用(非MIDAS應用)需要一個解析器時，從TBaseDataBlockInterpreter繼承，然後實現InterpretData方法即可，根據應用性質決定是否重載DisconnectOnComplete方法使之返回True。

還有什麼要做呢？我們給TSocketTransport加了一個IsCustomTrans屬性，該屬性的值在何處設置？與解析器有關係嗎？不同的解析器類又如何根據應用的性質創建呢？

由上面對Scktsrvr工作過程的分析我們知道，傳送器對象和解析器對像都是在服務線程(TSocketDispatcherThread)的ClientExecute方法中創建、使用並銷毀的，而服務線程又是由服務Socket(TSocketDispatcher)創建的，因此必須從這兩個類中進行處理。

回過頭看TSocketDispatcherThread的ClientExecute方法，傳送器對象（TSocketTransport）的創建這下面這句：

    FTransport := CreateServerTransport;

間接地通過方法CreateServerTransport來創建傳送器對象，再看CreateServerTransport方法：

function TSocketDispatcherThread.CreateServerTransport: ITransport;
var
  SocketTransport: TSocketTransport;
begin
  SocketTransport := TSocketTransport.Create;
  SocketTransport.Socket := ClientSocket;
  SocketTransport.InterceptGUID := FInterceptGUID;
  Result := SocketTransport as ITransport;
end;

傳送器對像在這裡創建，當然這裡就是設置它的IsCustomTrans屬性的最佳地方。IsCustomTrans屬性是區分MIDAS應用和非MIDAS應用的，我們很容易想到的就是為TSocketDispatcherThread也添加一個新屬性來標誌是哪一類應用，然後根據該屬性的值來設置傳送器對象的IsCustomTrans屬性值就很容易辦到。加一個什麼樣的屬性呢？

我們先來看看解析器對象。MIDAS應用使用的解析器類是TDataBlockInterpreter，非MIDAS應用使用我們自定義的解析器類。解析器類在TSocketDispatcherThread中是一個屬性：

FInterpreter: TDataBlockInterpreter;

定義為TDataBlockInterpreter類型，就只能應用於MIDAS應用，必須更改，讓它可以使用我們的自定義解析器類。但我們自定義的解析器類的類名是什麼，我自己都還沒想好呢，怎麼指定FInterpreter的類型？就算定好了類名，定義成

FInterpreter: TMyDataBlockInterpreter;

那MIDAS應用要用的TDataBlockInterpreter又怎麼辦。不管定義為TBaseDataBlockInterpreter的哪一個子類都行不通，必須要定義成基類：

FInterpreter: TBaseDataBlockInterpreter;

而TBaseDataBlockInterpreter是一個抽像類，我們不能直接創建它的實例，創建對象時必須要使用其子類來創建，在這裡就是TDataBlockInterpreter類或我們自定義的解析器類。類似於

  FInterpreter:=TDataBlockInterpreter.Create()

和

  FInterpreter:=TMyDataBlockInterpreter.Create()。

問題是類名事先不能確定，我們不能等到定好了類名後再來這裡寫代碼，這樣做不可能通用。因此必須要能夠動態指定類名。這就需要用到類引用類型了，因為可以用類名給類引用類型的變量賦值，然後由它來創建對象。為此，我們先定義一個TBaseDataBlockInterpreter類的類引用類型TDataBlockInterpreterClass，放在TBaseDataBlockInterpreter類的定義之前即可：

  TDataBlockInterpreterClass = class of TBaseDataBlockInterpreter;   

然後為TSocketDispatcherThread添加一個DataBlockInterpreterClass屬性

  TSocketDispatcherThread = class(TServerClientThread, ISendDataBlock)
  private
    ...
    FInterpreter: TBaseDataBlockInterpreter; { === Modified === }
    FDataBlockInterpreterClass: TDataBlockInterpreterClass; { === New === }
  protected
    ...
  public
    ...
    property DataBlockInterpreterClass: TDataBlockInterpreterClass read FDataBlockInterpreterClass write FDataBlockInterpreterClass; { === New === }
  end;

於是設置傳送器類的IsCustomTrans屬性和創建不同解析器對象就迎韌而解了：

function TSocketDispatcherThread.CreateServerTransport: ITransport;
var
  SocketTransport: TSocketTransport;
begin
  SocketTransport := TSocketTransport.Create;
  SocketTransport.Socket := ClientSocket;
  SocketTransport.InterceptGUID := FInterceptGUID;
  if DataBlockInterpreterClass.ClassName='TDataBlockInterpreter' then { === New == = }
    SocketTransport.IsCustomTrans:=False { === New === }
  else { === New === }
    SocketTransport.IsCustomTrans:=True; { === New === }
  Result := SocketTransport as ITransport;
end;

procedure TSocketDispatcherThread.ClientExecute;
begin
  ...
      if FRegisteredOnly then
        FInterpreter := DataBlockInterpreterClass.Create(Obj, SSockets) { === Modified === }
      else
        FInterpreter := DataBlockInterpreterClass.Create(Obj, ''); { === Modified === }
      try
        ...
            WAIT_OBJECT_0:
              begin
                WSAResetEvent(Event);
                  ...
                  if FInterpreter.DisconnectOnComplete then //添加的兩行代碼，DisconnectOnComplete在此運用
                    FTransport.Connected := False;
              end;
            WAIT_OBJECT_0 + 1:
        ...
      finally
        FInterpreter.Free;
        FInterpreter := nil;
      end;
  ...
end;

最後給TSocketDispatcher類也添加一個DataBlockInterpreterClass屬性，並修改其GetThread方法：

  TSocketDispatcher = class(TServerSocket)
  private
    ...
    FDataBlockInterpreterClass: TDataBlockInterpreterClass;{ === New === }
    ...
  public
    ...
    property DataBlockInterpreterClass: TDataBlockInterpreterClass read FDataBlockInterpreterClass write FDataBlockInterpreterClass; { === New === }
  end;

procedure TSocketDispatcher.GetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  SocketThread := TSocketDispatcherThread.Create(True, ClientSocket,
    InterceptGUID, Timeout, SocketForm.RegisteredAction.Checked, SocketForm.AllowXML.Checked);{ = == Modified === }
  TSocketDispatcherThread(SocketThread).DataBlockInterpreterClass:=FDataBlockInterpreterClass;{ === New === }
  SocketThread.Resume;{ === New === }
end;

至此，與Socket有關的所有類更改完成，添加和改動的代碼不過數十行，Scktsrvr.exe在保留原功能的基礎上可以很方便地增加其他服務功能，做成一個多功能Socket服務端應用程序。

在Scktsrvr主窗體代碼中，對主窗體的ReadSettings方法的子過程CreateItem進行一點點修改：

  procedure CreateItem(ID: Integer);
  var
    SH: TSocketDispatcher;
  begin
    SH := TSocketDispatcher.Create(nil);
    SH.DataBlockInterpreterClass:=TDataBlockInterpreter; { === New === }
    ...
  end;

保存並編譯，新的Scktsrvr.exe產生了，但功能還沒有增加。假設要增加http代理功能，首先從TBaseDataBlockInterpreter派生一個新類TProxyDataBlockInterpreter並實現InterpretData方法，然後定義一個TSocketDispatcher類型的變量，再創建一個TSocketDispatcher對象實例到該變量並指定其DataBlockInterpreterClass屬性為TProxyDataBlockInterpreter即可。示例如下：

var
    ProxySocket: TSocketDispatcher;

procedure CreateProxyServerSocket;
begin
  ProxySocket:= TSocketDispatcher.Create(nil);
  with ProxySocket do
    begin
      Port:=8080;
      ThreadCacheSize := 10;
      FInterceptGUID := '';
      FTimeout := 0;
      DataBlockInterpreterClass:=TProxyDataBlockInterpreter;
      Open;
    end;
end;

後話：TSocketDispatcher類和TSocketDispatcherThread類在Scktsrvr.exe的主窗體單元中，為使應用更加靈活，最好將這兩個類的代碼拷貝出來放到一個獨立的單元中（當然還要進行一些修改），這樣，在我們自己的應用中加入這個單元和SConnect單元，就可以很方便地按我們自己喜好的風格設計Socket服務器應用程序界面了。


資料來源 http://www.cnblogs.com/94YY/archive/2011/05/12/2044086.html