Class TLISTENSOCKET (I wrote like Borland Socket Service class)

{This is the class I rewritten according to Borland Socket Service: TLISTENSOCKET, its function is equivalent to: "x: / program files / borland / delphi5 / bin / scktsrvr.exe". Also, it can turn your distributed server program into a program with a listening function, listen, and your Remote Datamodule can still run. Soon, if there is any bug, please point out, thank you. }

{I want to make it a control method, I don't want to change it now. Need to say,}

{

usage:

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, Scoknect, 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; Proced URE close;

IMPLEMENTATION

Function TLISTENSOCKET.GETCLIENTCOUNT: INTEGER; Begin Result: = fclientthReads.count;

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 (FREEANDNIL); inherited destroy;

Procedure Tlistensocket.open; Begin SetActiveState (TRUE);

Procedure Tlistensocket.close; Begin SetActiveState (False);

Class Procedure Tlistensocket.addClientthread (Thread: Tsocketdispatcherthread); Begin Fclientthreads.Add (Thread);

class procedure TListenSocket.RemoveClientThread (Thread: TSocketDispatcherThread); var i: integer; begin for i: = 0 to FClientThreads.Count -1 do begini: = FClientThreahs.IndexOf (Thread); if i <> - 1then FClientThreads.Delete (i END;

Procedure Tlistensocket.setActiveState (Value: Boolean); Var i: integer; begin if value dam sh.close; sh.port: = listport; sh.threadcachesize: = cachesize; sh.open; end else if not value dam If FclientCount> 0 Then Error (') also has a customer in connection status, abort.') sh.close; factive: = value;

// The following things are Copy Copy in Delphi, which is used for me. Ha ha

{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);

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 Incount; Result: = FREFCOUNT; END;

Function TsocketDispatcherThread._Release: Integer; Begin Dec (FREFCOUNT); Result: = freefcount; end; {tsocketdispatcherthread class over}

End.