I
import
Unregistered / Unconfirmed
GUEST, unregistred user!
主 题：****新年贺礼----TListenSocket***** 作 者：saoren
所属论坛：Delphi
问题点数：88
回复次数：4
发表时间：2001-1-29 8:34:00
新年好，新年进步，给大家献上新年礼物，我写的一个类似：Borland Socket Service功能的类，并请大家指出错误。
本想藏私，不过，没有交流，就没有进步，所以大家进步，哈哈，
用法简单：
uses ListenSocket;
SH:TListenSocket;
SH:=TListenSocket.Create(Self);
SH.ListPort:=8888;
SH.Open;
//OK.你的（SERVER）程序变成一个侦听程序了。oh
unit ListenSocket;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
SConnect,ScktComp,SvcMgr, ActiveX,MidConst,winsock,MyConst;
var FClientCount:integer;
FClientThreads:TStringList;
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:=FClientCount;
end;
constructor TListenSocket.Create(AOwner :TComponent);
begin
LoadWinSock2;
FActive:=False;
FClientCount:=0;
FCacheSize :=10;
FClientThreads:=TStringList.Create;
SH:=MyServerSocket.Create(nil);
inherited Create;
end;
destructor TListenSocket.Destroy;
begin
SetActiveState(False);
FClientThreads.Free;
inherited Destroy;
end;
procedure TListenSocket.Open;
begin
SetActiveState(True);
end;
procedure TListenSocket.Close;
begin
SetActiveState(False);
end;
class procedure TListenSocket.AddClientThread(Thread :TSocketDispatcherThread);
begin
Inc(FClientCount);
FClientThreads.AddObject(Thread.ClientSocket.RemoteHost,Thread);
end;
class procedure TListenSocket.RemoveClientThread(Thread :TSocketDispatcherThread);
var i:integer;
begin
for i:=0 to FClientThreads.Count -1 do
begin
if TSocketDispatcherThread(FClientThreads.Objects)=Thread then
begin
FClientThreads.Delete(i);
Dec(FClientCount);
end;
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
SH.Close;
FActive:=Value;
end;
{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.
所属论坛：Delphi
问题点数：88
回复次数：4
发表时间：2001-1-29 8:34:00
新年好，新年进步，给大家献上新年礼物，我写的一个类似：Borland Socket Service功能的类，并请大家指出错误。
本想藏私，不过，没有交流，就没有进步，所以大家进步，哈哈，
用法简单：
uses ListenSocket;
SH:TListenSocket;
SH:=TListenSocket.Create(Self);
SH.ListPort:=8888;
SH.Open;
//OK.你的（SERVER）程序变成一个侦听程序了。oh
unit ListenSocket;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
SConnect,ScktComp,SvcMgr, ActiveX,MidConst,winsock,MyConst;
var FClientCount:integer;
FClientThreads:TStringList;
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:=FClientCount;
end;
constructor TListenSocket.Create(AOwner :TComponent);
begin
LoadWinSock2;
FActive:=False;
FClientCount:=0;
FCacheSize :=10;
FClientThreads:=TStringList.Create;
SH:=MyServerSocket.Create(nil);
inherited Create;
end;
destructor TListenSocket.Destroy;
begin
SetActiveState(False);
FClientThreads.Free;
inherited Destroy;
end;
procedure TListenSocket.Open;
begin
SetActiveState(True);
end;
procedure TListenSocket.Close;
begin
SetActiveState(False);
end;
class procedure TListenSocket.AddClientThread(Thread :TSocketDispatcherThread);
begin
Inc(FClientCount);
FClientThreads.AddObject(Thread.ClientSocket.RemoteHost,Thread);
end;
class procedure TListenSocket.RemoveClientThread(Thread :TSocketDispatcherThread);
var i:integer;
begin
for i:=0 to FClientThreads.Count -1 do
begin
if TSocketDispatcherThread(FClientThreads.Objects)=Thread then
begin
FClientThreads.Delete(i);
Dec(FClientCount);
end;
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
SH.Close;
FActive:=Value;
end;
{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.