其实不难做,代码如下,将其存为.pas文件,在包中安装就可以了.如何使用就不说了:
unit ScktDsph;
Interface
Uses Windows, ScktComp, SConnect, ActiveX, MidConst, Classes,
WinSock, Messages, SysUtils;
Type
TSocketDispatcherThread = Class;
TClientNotify = Procedure(Thread :TSocketDispatcherThread) Of Object;
TSocketDispatcher = Class(TCustomServerSocket)
Private
FInterceptGUID: AnsiString;
FTimeout: Integer;
FOnAddClient, FOnRemoveClient, FOnClientUpdate :TClientNotify;
Procedure GetThread(Sender :TObject;
ClientSocket :TServerClientWinSocket;
Var SocketThread: TServerClientThread);
Procedure AddClient(Thread :TSocketDispatcherThread);
Procedure RemoveClient(Thread :TSocketDispatcherThread);
Procedure ClientUpdate(Thread :TSocketDispatcherThread);
Public
Constructor Create(AOwner: TComponent);
Override;
Destructor Destroy;
Override;
Public
Property Socket: TServerWinSocket read FServerSocket;
Published
Property InterceptGUID: AnsiString Read FInterceptGUID Write FInterceptGUID;
Property Timeout: Integer Read FTimeout Write FTimeout;
Property OnAddClient :TClientNotify Read FOnAddClient Write FOnAddClient;
Property OnRemoveClient :TClientNotify Read FOnRemoveClient Write FOnRemoveClient;
Property OnClientUpdate :TClientNotify Read FOnClientUpdate Write FOnClientUpdate;
{ TCustomServerSocket }
Property Active;
Property Port Default 211;
Property ThreadCacheSize Default 10;
{
Property ServerType;
Property Service;
Property OnListen;
Property OnAccept;
Property OnGetThread;
Property OnGetSocket;
Property OnThreadStart;
Property OnThreadend;
Property OnClientConnect;
Property OnClientDisconnect;
Property OnClientRead;
Property OnClientWrite;
Property OnClientError;
}
end;
//---------------------------------------------------------------------------
TSocketDispatcherThread = class(TServerClientThread, ISendDataBlock)
private
FRefCount: Integer;
FInterpreter: TDataBlockInterpreter;
FTransport: ITransport;
FInterceptGUID: string;
FLastActivity: TDateTime;
FTimeout: Integer;
FRegisteredOnly: Boolean;
FOnAddClient, FOnRemoveClient, FOnClientUpdate :TClientNotify;
Procedure AddClient;
Procedure RemoveClient;
Procedure ClientUpdate;
protected
function CreateServerTransport: ITransport;
virtual;
{ 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;
Public
OwnerData
ointer;
// provider a Tag for save custom data
Property LastActivity: TDateTime read FLastActivity;
end;
Resourcestring
SNoWinSock2 = '运行程序需要 WinSock 2.0以上版本';
procedure Register;
Implementation
{ TSocketDispatcher }
Constructor TSocketDispatcher.Create(AOwner: TComponent);
begin
If Not LoadWinSock2 then
Raise Exception.CreateRes(@SNoWinSock2);
FServerSocket := TServerWinSocket.Create(INVALID_SOCKET);
InitSocket(FServerSocket);
FServerSocket.ThreadCacheSize := 10;
Port := 211;
ServerType := stThreadBlocking;
OnGetThread := GetThread;
FOnAddClient := Nil;
FOnRemoveClient := Nil;
Inherited Create(AOwner);
end;
Destructor TSocketDispatcher.Destroy;
begin
Inherited Destroy;
end;
procedure TSocketDispatcher.GetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket;
Var SocketThread: TServerClientThread);
begin
SocketThread := TSocketDispatcherThread.Create(False, ClientSocket,
InterceptGUID, Timeout, False);
TSocketDispatcherThread(SocketThread).FOnAddClient := AddClient;
TSocketDispatcherThread(SocketThread).FOnRemoveClient := RemoveClient;
TSocketDispatcherThread(SocketThread).FOnClientUpdate := ClientUpdate;
end;
Procedure TSocketDispatcher.AddClient(Thread :TSocketDispatcherThread);
begin
If Assigned(FOnAddClient) And Not (csLoading In ComponentState) then
FOnAddClient( Thread );
end;
Procedure TSocketDispatcher.RemoveClient( Thread :TSocketDispatcherThread );
begin
If Assigned(FOnRemoveClient) And Not (csLoading In ComponentState) then
FOnRemoveClient(Thread);
end;
Procedure TSocketDispatcher.ClientUpdate(Thread :TSocketDispatcherThread);
begin
If Assigned(FOnClientUpdate) And Not (csLoading In ComponentState) then
FOnClientUpdate(Thread);
end;
{ TSocketDispatcherThread }
constructor TSocketDispatcherThread.Create(CreateSuspended: Boolean;
ASocket: TServerClientWinSocket;
const InterceptGUID: string;
Timeout: Integer;
RegisteredOnly: Boolean);
begin
FInterceptGUID := InterceptGUID;
FTimeout := Timeout;
FLastActivity := Now;
FRegisteredOnly := RegisteredOnly;
OwnerData := Nil;
Inherited Create(CreateSuspended, ASocket);
end;
function TSocketDispatcherThread.CreateServerTransport: ITransport;
var
SocketTransport: TSocketTransport;
begin
SocketTransport := TSocketTransport.Create;
SocketTransport.Socket := ClientSocket;
SocketTransport.InterceptGUID := FInterceptGUID;
Result := SocketTransport as ITransport;
end;
{ TSocketDispatcherThread.IUnknown }
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.ISendDataBlock }
function TSocketDispatcherThread.Send(const Data: IDataBlock;
WaitForResult: Boolean): IDataBlock;
begin
FTransport.Send(Data);
If WaitForResult then
While Truedo
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.ClientExecute;
Var
Data: IDataBlock;
Obj: ISendDataBlock;
Event: THandle;
TimeSub :TDateTime;
Hour, Min, Sec, MSec:Word;
begin
Synchronize(AddClient);
CoInitialize(Nil);
Try
FTransport := CreateServerTransport;
Try
Event := FTransport.GetWaitEvent;
GetInterface(ISendDataBlock, Obj);
If FRegisteredOnly then
FInterpreter := TDataBlockInterpreter.Create(Obj, SSockets)
else
FInterpreter := TDataBlockInterpreter.Create(Obj, '');
Try
Obj := Nil;
While Not Terminated And FTransport.Connecteddo
Try
Case WaitForSingleObject(Event, 60000) Of
// always wait for 1mins for a circle check
WAIT_TIMEOUT:
begin
If (FTimeout = 0) Or (FTransport.Connected = False) then
Continue;
TimeSub := Now - FLastActivity;
DecodeTime(TimeSub, Hour, Min, Sec, MSec);
If Hour*60+Min > FTimeout then
FTransport.Connected := False;
end;
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;
Synchronize(ClientUpdate);
// try notify socket dispatcher we are updated
end;
end;
end;
Except
FTransport.Connected := False;
end;
Finally
FInterpreter.Free;
FInterpreter := nil;
end;
Finally
FTransport := nil;
end;
Finally
CoUninitialize;
Synchronize(RemoveClient);
end;
end;
Procedure TSocketDispatcherThread.AddClient;
begin
Try
FOnAddClient(Self);
Except
end;
end;
Procedure TSocketDispatcherThread.RemoveClient;
begin
Try
FOnRemoveClient(Self);
Except
end;
end;
Procedure TSocketDispatcherThread.ClientUpdate;
begin
Try
FOnClientUpdate(Self);
Except
end;
end;
procedure Register;
begin
RegisterComponents('DataSnap', [TSocketDispatcher]);
end;
end.
