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

 Socket服务端编程中最重要的也是最难处理的工作便是客户请求的处理和数据的接收和发送，如果每一个Socket服务器应用程序的开发都要从头到尾处理这些事情的话，人将会很累，也会浪费大量时间。试想，如果有一个通用的程序把客户请求处理和数据的接收、发送都处理好了，程序员只需要在不同的应用中对接收到的数据进行不同的解析并生成返回的数据包，再由这个通用程序将数据包传回客户端，这样，程序设计的工作将会轻松许多。 
　　用Delphi进行过三层数据库应用开发的程序员一定对Borland公司的Borland Socket Server(ScktSrvr.exe)不陌生。这是一个典型的Socket服务器程序，认真读过该软件的源程序的人一定会赞叹其程序编写的高明。其程序风格堪称典范。但它是专用于配合Borland的MIDAS进行多层应用开发的。它能不能让我们实现上面的设想，以便我们应用到不同的应用中去呢？

　　随我来吧，你会有收获的。

　　首先，让我们搞清楚它的工作方式和过程，以便看能不能用它完成我们的心愿，当然改动不能太大，否则我没耐心也没有能力去做。

　　从主窗体的代码开始：不论是以系统服务方式启动程序或直接运行程序，当程序运行时，都会执行主窗体初始化方法：

         TSocketForm.Initialize(FromService: Boolean);

　　该方法代码简单易读，为节省篇幅在此不列出它的源代码。该方法从注册表键“HKEY_LOCAL_MACHINESOFTWAREBorlandSocket 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[i]).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://blog.csdn.net/aroc_lo/article/details/9170247