ITPub博客

首页 > IT基础架构 > 网络安全 > 类TListenSocket(我写的类似Borland Socket Service的类) (转)

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

原创 网络安全 作者:worldblog 时间:2007-12-04 14:32:03 0 删除 编辑
类TListenSocket(我写的类似Borland Socket Service的类) (转)[@more@]

{这是我根据Borland Socket Service改写的类:TListenSocket, 它的功能是相当于:"X:Program FilesBorlandDelphi5Binscktsrvr.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.

 


来自 “ ITPUB博客 ” ,链接:http://blog.itpub.net/10752043/viewspace-988372/,如需转载,请注明出处,否则将追究法律责任。

请登录后发表评论 登录
全部评论
  • 博文量
    6241
  • 访问量
    2410763