类TListenSocket(我写的类似Borland Socket Service的类)

{这是我根据Borland Socket Service改写的类：TListenSocket, 它的功能是相当于："X:/Program Files/Borland/Delphi5/Bin/scktsrvr.exe"。也是说它可以将你的分布式服务端程序变成一个有侦听功能的程序，有侦听，还有你的Remote DataModule可以照样运行。写出来不久，如果有什么BUG，请指出，谢谢。}

{本想把它做成控件方式的，现在不想去改动了。有需要再说，}

{

用法：

uses Listensocket;

var Socket:TListenSocket;

const ListenPort=8888;

Socket:=TListenSocket.Create(Self);

Socket.ListenPort:=ListPort;

Socket.Open;

//OK

}

unit ListenSocket;

interface

uses  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,  SConnect,ScktComp,SvcMgr, ActiveX,MidConst,winsock,MyConst;

var     FClientThreads:TList;type  TSocketDispatcherThread = class(TServerClientThread, ISendDataBlock)  private    FRefCount: Integer;    FInterpreter: TDataBlockInterpreter;    FTransport: ITransport;    FLastActivity: TDateTime;    FTimeout: TDateTime;    FRegisteredOnly: Boolean;    procedure AddClient;    procedure RemoveClient;  protected    function CreateServerTransport: ITransport; virtual;   { procedure AddClient;    procedure RemoveClient; }    { IUnknown }    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;    function _AddRef: Integer; stdcall;    function _Release: Integer; stdcall;    { ISendDataBlock }    function Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock; stdcall;  public    constructor Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket;      const InterceptGUID: string; Timeout: Integer; RegisteredOnly: Boolean);    procedure ClientExecute; override;  end;

type MyServerSocket=Class(TServerSocket)  private    procedure GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;var SocketThread: TServerClientThread);  public    constructor Create(AOwner: TComponent); override;end;

type  TListenSocket = class(TObject)  private    FActive:Boolean;    FListPort :integer;    FCacheSize :integer;    SH:MyServerSocket;    FItemIndex :integer;    procedure SetActiveState(Value:boolean);    function GetClientCount :integer;    { Private declarations }  public    property CacheSize :integer read FCacheSize write FCacheSize;    property ListPort:integer read FListPort write FListPort;    property Active :boolean read FActive write SetActiveState;    property ClientCount:integer read GetClientCount;  public    constructor Create(AOwner :TComponent);    destructor Destroy;override;    class procedure AddClientThread(Thread :TSocketDispatcherThread);    class procedure RemoveClientThread(Thread:TSocketDispatcherThread);    procedure Open;    procedure Close;  end;

implementation

function TListenSocket.GetClientCount :integer;begin  Result:=FClientThreads.Count;end;

constructor TListenSocket.Create(AOwner :TComponent);begin  LoadWinSock2;  FActive:=False;  FClientCount:=0;  FCacheSize :=10;  FClientThreads:=TList.Create;  SH:=MyServerSocket.Create(nil);  inherited Create;end;

destructor TListenSocket.Destroy;begin  SetActiveState(False);  FreeAndNil(FClientThreahs);  inherited Destroy;end;

procedure TListenSocket.Open;begin  SetActiveState(True);end;

procedure TListenSocket.Close;begin  SetActiveState(False);end;

class procedure TListenSocket.AddClientThread(Thread :TSocketDispatcherThread);begin  FClientThreads.Add(Thread);end;

class procedure TListenSocket.RemoveClientThread(Thread :TSocketDispatcherThread);var i:integer;begin  for i:=0 to FClientThreads.Count -1 do  begin

    i:=FClientThreahs.IndexOf(Thread);    if i<>-1then      FClientThreads.Delete(i);  end;end;

procedure TListenSocket.SetActiveState(Value:boolean);var i:integer;begin  if Value then  begin    SH.Close;    SH.Port :=ListPort;    SH.ThreadCacheSize :=CacheSize;    SH.Open;  end else  if not Value then//if FClientCount>0 then Error('还有客户在连接状态，中止。')    SH.Close;  FActive:=Value;end;

//下面的东西都是在Delphi中Copy过来的，为我所用了。呵呵

{MyServerSocket Class}procedure MyServerSocket.GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;  var SocketThread: TServerClientThread);begin  SocketThread:=TSocketDispatcherThread.Create(false,ClientSocket,'',0,false);end;

constructor MyServerSocket.Create(AOwner: TComponent);begin  inherited Create(AOwner);  ServerType := stThreadBlocking;  OnGetThread := GetThread;end;{MyServerSocket Class over}

{TSocketDispatcherThread class}function TSocketDispatcherThread.CreateServerTransport: ITransport;var  SocketTransport: TSocketTransport;begin  SocketTransport := TSocketTransport.Create;  SocketTransport.Socket := ClientSocket;  Result := SocketTransport as ITransport;end;

constructor TSocketDispatcherThread.Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket;      const InterceptGUID: string; Timeout: Integer; RegisteredOnly: Boolean);begin  FTimeout:=EncodeTime(Timeout div 60, Timeout mod 60, 0, 0);  FRegisteredOnly:=RegisteredOnly;  FLastActivity:=Now;  inherited Create(CreateSuspended, ASocket);end;

function TSocketDispatcherThread.Send(const Data:IDataBlock; WaitForResult:Boolean):IDataBlock;begin  FTransport.Send(Data);  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;

procedure TSocketDispatcherThread.AddClient;begin  TListenSocket.AddClientThread(Self);end;

procedure TSocketDispatcherThread.RemoveClient;begin  TListenSocket.RemoveClientThread(Self);end;

procedure TSocketDispatcherThread.ClientExecute;var  Data: IDataBlock;  msg: TMsg;  Obj: ISendDataBlock;  Event: THandle;  WaitTime: DWord;begin  CoInitialize(nil);  try    Synchronize(AddClient);    FTransport := CreateServerTransport;    try      Event := FTransport.GetWaitEvent;      PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);      GetInterface(ISendDataBlock, Obj);      if FRegisteredOnly then        FInterpreter := TDataBlockInterpreter.Create(Obj, SSockets) else        FInterpreter := TDataBlockInterpreter.Create(Obj, '');      try        Obj := nil;        if FTimeout = 0 then          WaitTime := INFINITE else          WaitTime := 60000; //MAXIMUM_WAIT_OBJECTS        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;    Synchronize(RemoveClient);  end;end;

function TSocketDispatcherThread.QueryInterface(const IID: TGUID; out Obj): HResult;begin  if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;end;

function TSocketDispatcherThread._AddRef: Integer;begin  Inc(FRefCount);  Result := FRefCount;end;

function TSocketDispatcherThread._Release: Integer;begin  Dec(FRefCount);  Result := FRefCount;end;{TSocketDispatcherThread class over}

end.