|
|
{$INCLUDE ..\cDefines.inc} unit cTCPServer; { } { TCP Server Component v3.10 } { } { This unit is copyright © 2000-2004 by David J Butler } { } { This unit is part of Delphi Fundamentals. } { Its original file name is cTCPServer.pas } { The latest version is available from the Fundamentals home page } { http://fundementals.sourceforge.net/ } { } { I invite you to use this unit, free of charge. } { I invite you to distibute this unit, but it must be for free. } { I also invite you to contribute to its development, } { but do not distribute a modified copy of this file. } { } { A forum is available on SourceForge for general discussion } { http://sourceforge.net/forum/forum.php?forum_id=2117 } { } { } { Revision history: } { 27/11/2000 0.01 Created cInternetServer unit from cInternetStandards. } { 25/01/2001 0.02 Refactored unit. Renamed to cSocketServer. } { 25/03/2001 0.03 Removed support for Delphi's sockets. } { 15/12/2001 1.04 Server now uses Fundamentals Sockets library. } { 11/02/2002 2.05 Refactored for Fundamentals 2. } { 16/02/2002 2.06 Added throttling. } { 04/09/2002 3.07 Refactored for Fundamentals 3. } { Renamed unit to cTCPServer. } { 22/06/2003 3.08 Fixed bug in TCPServer.OnDataAvailable. } { 16/10/2003 3.09 Fixed bug in threaded mode. } { Added InBufferMaxSize and OutBufferMaxSize properties. } { 09/04/2004 3.10 Improved client termination. } { } interface uses { Delphi } Messages, WinSock, SysUtils, Classes, { Fundamentals } cStrings, cStreams, cLog, cThreads, cSocketsTCP, cTCPStream, cSocketsTCPServer; { } { ATCPServer } { Base class for TCP servers. } { } { PROPERTIES } { Active } { Set Active = True to enable the server. } { } { ListenPort } { TCP port on which server listens for incoming connections. } { } { ServerMode } { smManualAccept Server triggers an OnConectionAvailable event } { and user must call Accept method to accept the } { new client. } { smAcceptClient Server automatically Accepts new client as } { soon as connection is made. } { smAcceptClientThread Server automatically Accepts new client as } { soon as connection is made. The new client is } { created in its own thread. } { } const WM_TCPSERVER_FREECLIENT = WM_USER + 1281; type { ATCPServer } TTCPServerClient = class; CTCPServerClient = class of TTCPServerClient; ATCPServer = class; ATCPServerEvent = procedure (Sender: ATCPServer) of object; ATCPServerLogEvent = procedure (Sender: ATCPServer; Msg : String) of object; TTCPServerClientEvent = procedure (Sender: TTCPServerClient) of object; TTCPServerCreateClientEvent = function (Sender: ATCPServer) : TTCPServerClient of object; TTCPServerClientArray = Array of TTCPServerClient; TTCPServerMode = (smManualAccept, smAcceptClient, smAcceptClientThread); ATCPServer = class(TComponent) protected FOnLog : ATCPServerLogEvent; FLogTo : TLog; FServerMode : TTCPServerMode; FListenPort : String; FTimeOut : Integer; FInBufferMaxSize : Integer; FOutBufferMaxSize : Integer; FLocalHost : String; FMaxBacklog : Integer; FLoadActive : Boolean; FOnActive : ATCPServerEvent; FOnInactive : ATCPServerEvent; FOnConnectionAvailable : ATCPServerEvent; FOnCreateClient : TTCPServerCreateClientEvent; FOnClientActive : TTCPServerClientEvent; FOnClientInactive : TTCPServerClientEvent; FClientClass : CTCPServerClient; FOnDataAvailable : TTCPServerClientEvent; FOnThreadRun : TTCPServerClientEvent; FMaxClients : Integer; FOnClientRemoved : TTCPServerClientEvent; FThrottleClientRead : Boolean; FThrottleClientReadRate : Integer; FThrottleClientWrite : Boolean; FThrottleClientWriteRate : Integer; FActive : Boolean; FSocket : TTCPServerSocket; FClients : TTCPServerClientArray; FAcceptPending : Boolean; FStartTime : TDateTime; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Loaded; override; procedure Init; virtual; procedure RaiseError(const Msg: String); virtual; procedure RaiseAndLogError(const Msg: String); procedure Log(const LogClass: TLogClass; const Msg: String); procedure SetListenPort(const ListenPort: String); function GetLocalHost: String; procedure SetLocalHost(const LocalHost: String); function GetMaxBacklog: Integer; procedure SetMaxBacklog(const MaxBacklog: Integer); procedure SetServerMode(const ServerMode: TTCPServerMode); procedure SetClientSocketProperties; procedure SetThrottleClientRead(const ThrottleClientRead: Boolean); procedure SetThrottleClientWrite(const ThrottleClientWrite: Boolean); procedure SetThrottleClientReadRate(const ThrottleClientReadRate: Integer); procedure SetThrottleClientWriteRate(const ThrottleClientWriteRate: Integer); procedure TriggerActive; virtual; procedure TriggerInactive; virtual; procedure Start; virtual; procedure Stop; virtual; procedure SetActive(const Active: Boolean); function GetUpTime: TDateTime; function GetUpTimeStr: String; procedure RemoveClientByIndex(const Idx: Integer); procedure RemoveClient(const Client: TTCPServerClient); procedure TriggerClientRemoved(const Client: TTCPServerClient); procedure TriggerClientActive(const Client: TTCPServerClient); virtual; procedure TriggerClientInactive(const Client: TTCPServerClient); virtual; procedure TerminateClients; procedure TriggerConnectionAvailable; virtual; procedure OnServerConnectionAvailable(Sender: TTCPServerSocket); procedure AcceptClient; procedure AcceptClientThread; function CreateClient: TTCPServerClient; virtual; procedure TriggerThreadRun(const Client: TTCPServerClient); virtual; function GetClientCount: Integer; function GetClientByIndex(const Idx: Integer): TTCPServerClient; procedure OnClientSocketDataAvailable(Sender: ATCPClientSocket); procedure OnClientSocketClose(Sender: ATCPClientSocket); function OnServerMessage(const Msg: Cardinal; const wParam, lParam: Integer; var Handled: Boolean): Integer; property OnCreateClient: TTCPServerCreateClientEvent read FOnCreateClient write FOnCreateClient; property OnClientActive: TTCPServerClientEvent read FOnClientActive write FOnClientActive; property OnClientInactive: TTCPServerClientEvent read FOnClientInactive write FOnClientInactive; property OnClientRemoved: TTCPServerClientEvent read FOnClientRemoved write FOnClientRemoved; property OnDataAvailable: TTCPServerClientEvent read FOnDataAvailable write FOnDataAvailable; property OnThreadRun: TTCPServerClientEvent read FOnThreadRun write FOnThreadRun; public constructor Create(AOwner: TComponent); override; constructor CreateEx(const ListenPort: String; const TimeOut: Integer; const ServerMode: TTCPServerMode; const ClientClass: CTCPServerClient); destructor Destroy; override; property LogTo: TLog read FLogTo write FLogTo; property OnLog: ATCPServerLogEvent read FOnLog write FOnLog; property ServerMode: TTCPServerMode read FServerMode write SetServerMode default smAcceptClient; function LocalHostName: String; property LocalHost: String read GetLocalHost write SetLocalHost; property ListenPort: String read FListenPort write SetListenPort; property MaxBacklog: Integer read GetMaxBacklog write SetMaxBacklog default DefaultBacklog; property TimeOut: Integer read FTimeOut write FTimeOut default DefaultSocketStreamTimeOut; property InBufferMaxSize: Integer read FInBufferMaxSize write FInBufferMaxSize default -1; property OutBufferMaxSize: Integer read FOutBufferMaxSize write FOutBufferMaxSize default -1; property MaxClients: Integer read FMaxClients write FMaxClients default -1; property Active: Boolean read FActive write SetActive default False; property OnActive: ATCPServerEvent read FOnActive write FOnActive; property OnInactive: ATCPServerEvent read FOnInactive write FOnInactive; property StartTime: TDateTime read FStartTime; property UpTime: TDateTime read GetUpTime; property UpTimeStr: String read GetUpTimeStr; property ThrottleClientRead: Boolean read FThrottleClientRead write SetThrottleClientRead default False; property ThrottleClientReadRate: Integer read FThrottleClientReadRate write SetThrottleClientReadRate default 0; property ThrottleClientWrite: Boolean read FThrottleClientWrite write SetThrottleClientWrite default False; property ThrottleClientWriteRate: Integer read FThrottleClientWriteRate write SetThrottleClientWriteRate default 0; function GetReadRate: Integer; function GetWriteRate: Integer; function GetTransferRate: Integer; function Accept: TTCPServerClient; property OnConnectionAvailable: ATCPServerEvent read FOnConnectionAvailable write FOnConnectionAvailable; property Socket: TTCPServerSocket read FSocket; property Client[const Idx: Integer]: TTCPServerClient read GetClientByIndex; property ClientCount: Integer read GetClientCount; function GetClientIndex(const Client: TTCPServerClient): Integer; function GetClientIndexByStream(const Stream: AStream): Integer; function GetClientIndexBySocket(const Socket: ATCPClientSocket): Integer; function HasClient(const Client: TTCPServerClient): Boolean; end; ETCPServer = class(Exception); { TTCPServerClient } TTCPServerClientSocket = class(ATCPClientSocket); TTCPServerClient = class protected FWinSocket : TSocket; FAddress : TSockAddr; FServer : ATCPServer; FStream : TSocketStream; FSocket : TTCPServerClientSocket; FTerminated : Boolean; FThread : TThreadEx; FErrorMsg : String; FData : Pointer; procedure Init; virtual; procedure Log(const LogClass: TLogClass; const Msg: String); virtual; procedure SetSocketProperties; virtual; function GetStream: TSocketStream; procedure ThreadRun; virtual; procedure ClientError(const Msg: String); virtual; procedure ClientActive; virtual; procedure ClientInactive; virtual; function GetRemoteAddress: TInAddr; function GetRemoteAddressStr: String; function GetRemotePort: Integer; public constructor Create(const Server: ATCPServer); virtual; destructor Destroy; override; property Server: ATCPServer read FServer; property Socket: TTCPServerClientSocket read FSocket; function GetSocket: TTCPServerClientSocket; property Stream: TSocketStream read GetStream; property Thread: TThreadEx read FThread; property ErrorMsg: String read FErrorMsg; property RemoteAddress: TInAddr read GetRemoteAddress; property RemoteAddressStr: String read GetRemoteAddressStr; property RemotePort: Integer read GetRemotePort; property Data: Pointer read FData write FData; // user-defined data procedure Terminate; virtual; property Terminated: Boolean read FTerminated; function ReadAvailable: String; function PeekStr(const Count: Integer): String; procedure WriteStr(const S: String); function ReadEx(const MinCount, MaxCount: Integer; const Delimiter: String; var Buf: String; const Peek: Boolean = False): Boolean; function StreamReadLine(var S: String): Boolean; function SocketReadLine(var Buf: String; const Delimiter: String = CRLF): Boolean; procedure Synchronize(const Method: TThreadMethod); end; { } { TfndTCPServer } { } type TfndTCPServer = class(ATCPServer) published property LogTo; property OnLog; property ServerMode; property LocalHost; property ListenPort; property MaxBacklog; property TimeOut; property MaxClients; property ThrottleClientRead; property ThrottleClientReadRate; property ThrottleClientWrite; property ThrottleClientWriteRate; property OnConnectionAvailable; property OnDataAvailable; property OnCreateClient; property OnClientRemoved; property OnClientActive; property OnClientInactive; property OnThreadRun; property Active; property OnActive; property OnInactive; end; implementation uses { Delphi } Windows, { Fundamentals } cUtils, cDateTime, cWinSock; { } { TTCPServerClientThread } { } type TTCPServerClientThread = class(TThreadEx) protected FServer : ATCPServer; FClient : TTCPServerClient; FRunning : Boolean; FLogClass : TLogClass; FLogMsg : String; procedure NotifyLog; procedure NotifyClientActive; procedure NotifyClientInactive; procedure Log(const LogClass: TLogClass; const Msg: String); procedure Execute; override; public constructor Create(const Server: ATCPServer; const Client: TTCPServerClient); destructor Destroy; override; procedure Terminate; override; end; constructor TTCPServerClientThread.Create(const Server: ATCPServer; const Client: TTCPServerClient); begin Assert(Assigned(Server)); Assert(Assigned(Client)); FServer := Server; FClient := Client; FClient.FSocket := nil; FClient.FThread := self; FRunning := True; FreeOnTerminate := False; inherited Create(False); end; destructor TTCPServerClientThread.Destroy; begin if FRunning then Terminate; if Assigned(FClient) and (FClient.FThread = self) then FClient.FThread := nil; inherited Destroy; end; procedure TTCPServerClientThread.NotifyClientActive; begin if not Assigned(FClient) then exit; if Terminated or FClient.Terminated then exit; FServer.TriggerClientActive(FClient); end; procedure TTCPServerClientThread.NotifyClientInactive; begin if not Assigned(FClient) then exit; if Terminated or FClient.Terminated then exit; FServer.TriggerClientInactive(FClient); end; procedure TTCPServerClientThread.NotifyLog; begin if not Assigned(FClient) then exit; if Terminated or FClient.Terminated then exit; FServer.Log(FLogClass, FLogMsg); end; procedure TTCPServerClientThread.Log(const LogClass: TLogClass; const Msg: String); begin if not Assigned(FClient) then exit; if Terminated or FClient.Terminated then exit; FLogClass := LogClass; FLogMsg := Msg; Synchronize(NotifyLog); end; procedure TTCPServerClientThread.Execute; var Quit : Boolean; begin try Quit := Terminated or not Assigned(FClient) or FClient.Terminated; if Quit then exit; // Socket window must be created in thread to have messages posted to // this thread. try FClient.FStream := TSocketStream.Create(FClient.GetSocket, False, smBlockWaitMessage, FServer.FTimeOut, FServer.FOutBufferMaxSize); except on E: Exception do begin Log(lcError, 'Socket creation error: ' + E.Message); exit; end; end; Quit := Terminated or not Assigned(FClient) or FClient.Terminated or FClient.FSocket.Terminated; if Quit then exit; // Notify Active try FClient.ClientActive; if Assigned(FServer.FOnClientActive) then Synchronize(NotifyClientActive); except on E: Exception do begin Log(lcError, 'Client activate error: ' + E.Message); exit; end; end; Quit := Terminated or not Assigned(FClient) or FClient.Terminated or FClient.FSocket.Terminated; if Quit then exit; // Run try FClient.ThreadRun; except on E: Exception do begin Log(lcError, 'Client execute error: ' + E.Message); exit; end; end; finally // Notify Inactive Quit := Terminated or not Assigned(FClient) or FClient.Terminated or FClient.FSocket.Terminated; if not Quit then try FClient.ClientInactive; if Assigned(FServer.FOnClientInactive) then Synchronize(NotifyClientInactive); except on E: Exception do Log(lcError, 'Client deactivate error: ' + E.Message); end; if Assigned(FClient) then PostMessage(FServer.FSocket.WindowHandle, WM_TCPSERVER_FREECLIENT, Integer(Pointer(FClient)), 0); FRunning := False; end; end; procedure TTCPServerClientThread.Terminate; var S : ATCPClientSocket; begin if Terminated then exit; inherited Terminate; if Assigned(FClient) then begin S := FClient.FSocket; if Assigned(S) then begin S.Terminate; if S.WindowHandle <> 0 then PostMessage(S.WindowHandle, WM_QUIT, 0, 0); end; end; end; function GetTCPServerClientThread( const Server: ATCPServer; const Client: TTCPServerClient): TTCPServerClientThread; begin Result := TTCPServerClientThread.Create(Server, Client); end; { } { ATCPServer } { } constructor ATCPServer.Create(AOwner: TComponent); begin inherited Create(AOwner); Init; end; constructor ATCPServer.CreateEx(const ListenPort: String; const TimeOut: Integer; const ServerMode: TTCPServerMode; const ClientClass: CTCPServerClient); begin inherited Create(nil); Init; FTimeOut := TimeOut; FServerMode := ServerMode; FClientClass := ClientClass; FListenPort := ListenPort; end; destructor ATCPServer.Destroy; begin if not (csDesigning in ComponentState) then begin FActive := False; if Assigned(FSocket) then FSocket.Close; FreeAndNilObjectArray(ObjectArray(FClients)); FreeAndNil(FSocket); end; inherited Destroy; end; procedure ATCPServer.Init; begin FTimeOut := DefaultSocketStreamTimeOut; FServerMode := smAcceptClient; FMaxClients := -1; FInBufferMaxSize := -1; FOutBufferMaxSize := -1; FMaxBacklog := DefaultBacklog; if csDesigning in ComponentState then exit; FSocket := TTCPServerSocket.Create; FSocket.OnConnectionAvailable := OnServerConnectionAvailable; FSocket.OnMessage := OnServerMessage; end; procedure ATCPServer.RaiseError(const Msg: String); begin raise ETCPServer.Create(Msg); end; procedure ATCPServer.RaiseAndLogError(const Msg: String); begin Log(lcError, Msg); RaiseError(Msg); end; procedure ATCPServer.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if Operation = opRemove then if AComponent = FLogTo then FLogTo := nil; end; procedure ATCPServer.Loaded; begin inherited Loaded; if csDesigning in ComponentState then exit; if FLoadActive then SetActive(True); end; procedure ATCPServer.Log(const LogClass: TLogClass; const Msg: String); begin if csDesigning in ComponentState then exit; if Assigned(FOnLog) then FOnLog(self, Msg); if Assigned(FLogTo) then FLogTo.Log(self, LogClass, Msg); end; procedure ATCPServer.SetListenPort(const ListenPort: String); begin if ListenPort = FListenPort then exit; if ListenPort = '' then RaiseError('Invalid ListenPort'); if not (csDesigning in ComponentState) and Active then RaiseError('Cannot change port while server is active'); FListenPort := ListenPort; end; function ATCPServer.GetLocalHost: String; begin if csDesigning in ComponentState then Result := FLocalHost else Result := FSocket.LocalHost; end; procedure ATCPServer.SetLocalHost(const LocalHost: String); begin if LocalHost = FLocalHost then exit; if not (csDesigning in ComponentState) and Active then RaiseError('Cannot change local host while server is active'); FLocalHost := LocalHost; end; function ATCPServer.LocalHostName: String; begin Result := FSocket.LocalHostName; end; function ATCPServer.GetMaxBacklog: Integer; begin if csDesigning in ComponentState then Result := FMaxBacklog else Result := FSocket.MaxBacklog; end; procedure ATCPServer.SetMaxBacklog(const MaxBacklog: Integer); begin if MaxBacklog = FMaxBacklog then exit; FMaxBacklog := MaxBacklog; if csDesigning in ComponentState then exit; FSocket.MaxBacklog := MaxBacklog; end; procedure ATCPServer.SetServerMode(const ServerMode: TTCPServerMode); begin if FServerMode = ServerMode then exit; if not (csDesigning in ComponentState) and Active then RaiseError('Cannot change server mode while server is active'); FServerMode := ServerMode; end; procedure ATCPServer.SetClientSocketProperties; var I : Integer; begin FThrottleClientReadRate := ThrottleClientReadRate; For I := 0 to Length(FClients) - 1 do FClients[I].SetSocketProperties; end; procedure ATCPServer.SetThrottleClientReadRate(const ThrottleClientReadRate: Integer); begin if ThrottleClientReadRate = FThrottleClientReadRate then exit; FThrottleClientReadRate := ThrottleClientReadRate; SetClientSocketProperties; end; procedure ATCPServer.SetThrottleClientWriteRate(const ThrottleClientWriteRate: Integer); begin if ThrottleClientWriteRate = FThrottleClientWriteRate then exit; FThrottleClientWriteRate := ThrottleClientWriteRate; SetClientSocketProperties; end; procedure ATCPServer.SetThrottleClientRead(const ThrottleClientRead: Boolean); begin if ThrottleClientRead = FThrottleClientRead then exit; FThrottleClientRead := ThrottleClientRead; SetClientSocketProperties; end; procedure ATCPServer.SetThrottleClientWrite(const ThrottleClientWrite: Boolean); begin if ThrottleClientWrite = FThrottleClientWrite then exit; FThrottleClientWrite := ThrottleClientWrite; SetClientSocketProperties; end; procedure ATCPServer.SetActive(const Active: Boolean); begin if FActive = Active then exit; if csDesigning in ComponentState then begin FActive := Active; exit; end; if csLoading in ComponentState then begin FLoadActive := Active; exit; end; if Active then begin if ListenPort = '' then RaiseError('ListenPort not set'); try Start; except on E: Exception do RaiseAndLogError('Server activation failed: ' + E.Message); end; FStartTime := Now; FActive := True; Log(lcInfo, 'Server active. Listening on port ' + FListenPort + '.'); TriggerActive; end else begin FActive := False; try Stop; except on E: Exception do Log(lcError, 'Server deactivation failed: ' + E.Message); end; Log(lcInfo, 'Server shutdown.'); TriggerInactive; end; end; function ATCPServer.GetUpTime: TDateTime; begin if FActive then Result := Now - FStartTime else Result := 0.0; end; function ATCPServer.GetUpTimeStr: String; begin Result := DateTimeAsElapsedTime(GetUpTime); end; procedure ATCPServer.TriggerActive; begin if Assigned(FOnActive) then FOnActive(self); end; procedure ATCPServer.TriggerInactive; begin if Assigned(FOnInactive) then FOnInactive(self); end; procedure ATCPServer.Start; begin Assert(Assigned(FSocket)); FSocket.LocalHost := FLocalHost; FSocket.ListenPort := FListenPort; FSocket.Listen; end; procedure ATCPServer.Stop; begin Assert(Assigned(FSocket)); FSocket.Close; TerminateClients; FreeAndNilObjectArray(ObjectArray(FClients)); end; procedure ATCPServer.TerminateClients; var I : Integer; C : TTCPServerClient; begin For I := Length(FClients) - 1 downto 0 do begin C := FClients[I]; if not C.Terminated then C.Terminate; end; end; procedure ATCPServer.OnServerConnectionAvailable(Sender: TTCPServerSocket); begin if not FActive then exit; if (FMaxClients >= 0) and (ClientCount >= FMaxClients) then begin FAcceptPending := True; exit; end; TriggerConnectionAvailable; if FServerMode = smManualAccept then exit; Case FServerMode of smAcceptClient : AcceptClient; smAcceptClientThread : AcceptClientThread; end; end; procedure ATCPServer.TriggerConnectionAvailable; begin if Assigned(FOnConnectionAvailable) then FOnConnectionAvailable(self); end; function ATCPServer.Accept: TTCPServerClient; var Socket : TSocket; Address : TSockAddr; begin try Socket := FSocket.SocketAccept(Address); except Result := nil; exit; end; if Socket = INVALID_SOCKET then begin Result := nil; exit; end; try Result := CreateClient; if not Assigned(Result) then raise ETCPServer.Create('No client'); except on E: Exception do begin cWinSock.CloseSocket(Socket); Log(lcError, 'Error creating client: ' + E.Message); Result := nil; exit; end; end; Result.FWinSocket := Socket; Result.FAddress := Address; Append(ObjectArray(FClients), Result); end; procedure ATCPServer.AcceptClient; var Client : TTCPServerClient; begin Repeat Client := Accept; if not Assigned(Client) then exit; Client.FStream := TSocketStream.Create(Client.GetSocket, False, smAsynchronous, FTimeOut, FOutBufferMaxSize); With Client.FSocket do begin OnDataAvailable := OnClientSocketDataAvailable; OnClose := OnClientSocketClose; end; TriggerClientActive(Client); if not FActive or ((FMaxClients >= 0) and (ClientCount >= FMaxClients)) then exit; Until False; end; procedure ATCPServer.AcceptClientThread; var Client : TTCPServerClient; Thread : TTCPServerClientThread; begin Repeat Client := Accept; if not Assigned(Client) then exit; Thread := GetTCPServerClientThread(self, Client); if not Assigned(Thread) then begin Client.Free; exit; end; if not FActive or ((FMaxClients >= 0) and (ClientCount >= FMaxClients)) then exit; Until False; end; function ATCPServer.CreateClient: TTCPServerClient; begin if Assigned(FOnCreateClient) then begin Result := FOnCreateClient(self); if Assigned(Result) then exit; end; if Assigned(FClientClass) then begin Result := FClientClass.Create(self); exit; end; Result := TTCPServerClient.Create(self); end; procedure ATCPServer.TriggerClientRemoved(const Client: TTCPServerClient); begin if Assigned(FOnClientRemoved) then FOnClientRemoved(Client); end; procedure ATCPServer.TriggerClientActive(const Client: TTCPServerClient); begin if Assigned(FOnClientActive) then FOnClientActive(Client); end; procedure ATCPServer.TriggerClientInactive(const Client: TTCPServerClient); begin if Assigned(FOnClientInactive) then FOnClientInactive(Client); end; procedure ATCPServer.TriggerThreadRun(const Client: TTCPServerClient); begin if Assigned(FOnThreadRun) then FOnThreadRun(Client); end; procedure ATCPServer.RemoveClientByIndex(const Idx: Integer); var Client : TTCPServerClient; begin Assert(Idx >= 0); Client := FClients[Idx]; Remove(ObjectArray(FClients), Idx, 1, False); TriggerClientRemoved(Client); if FAcceptPending then OnServerConnectionAvailable(FSocket); end; procedure ATCPServer.RemoveClient(const Client: TTCPServerClient); var I : Integer; begin For I := 0 to Length(FClients) - 1 do if FClients[I] = Client then begin RemoveClientByIndex(I); exit; end; end; function ATCPServer.GetReadRate: Integer; var I : Integer; S : ATCPClientSocket; begin Result := 0; For I := 0 to Length(FClients) - 1 do begin S := FClients[I].FSocket; if Assigned(S) then Inc(Result, S.GetReadRate); end; end; function ATCPServer.GetWriteRate: Integer; var I : Integer; S : ATCPClientSocket; begin Result := 0; For I := 0 to Length(FClients) - 1 do begin S := FClients[I].FSocket; if Assigned(S) then Inc(Result, S.GetWriteRate); end; end; function ATCPServer.GetTransferRate: Integer; var I : Integer; S : ATCPClientSocket; begin Result := 0; For I := 0 to Length(FClients) - 1 do begin S := FClients[I].FSocket; if Assigned(S) then Inc(Result, S.GetTransferRate); end; end; procedure ATCPServer.OnClientSocketDataAvailable(Sender: ATCPClientSocket); var I : Integer; C : TTCPServerClient; begin if not FActive or not Assigned(FOnDataAvailable) then exit; I := GetClientIndexBySocket(Sender); if I = -1 then exit; C := FClients[I]; if not C.Terminated then FOnDataAvailable(C); end; procedure ATCPServer.OnClientSocketClose(Sender: ATCPClientSocket); var I : Integer; C : TTCPServerClient; begin I := GetClientIndexBySocket(Sender); if I < 0 then exit; C := FClients[I]; if FActive and not C.Terminated then TriggerClientInactive(C); PostMessage(FSocket.WindowHandle, WM_TCPSERVER_FREECLIENT, Integer(Pointer(C)), 0); end; function ATCPServer.OnServerMessage(const Msg: Cardinal; const wParam, lParam: Integer; var Handled: Boolean): Integer; var C : TTCPServerClient; I : Integer; begin if Msg = WM_TCPSERVER_FREECLIENT then begin Handled := True; C := TTCPServerClient(Pointer(wParam)); I := GetClientIndex(C); if I >= 0 then try RemoveClientByIndex(I); finally C.Free; end; end else Handled := False; Result := 0; end; function ATCPServer.GetClientCount: Integer; begin Result := Length(FClients); end; function ATCPServer.GetClientByIndex(const Idx: Integer): TTCPServerClient; begin Result := FClients[Idx]; end; function ATCPServer.GetClientIndex(const Client: TTCPServerClient): Integer; var I : Integer; begin For I := 0 to Length(FClients) - 1 do if FClients[I] = Client then begin Result := I; exit; end; Result := -1; end; function ATCPServer.GetClientIndexByStream(const Stream: AStream): Integer; var I : Integer; begin For I := 0 to Length(FClients) - 1 do if Assigned(FClients[I]) and (FClients[I].FStream = Stream) then begin Result := I; exit; end; Result := -1; end; function ATCPServer.GetClientIndexBySocket(const Socket: ATCPClientSocket): Integer; var I : Integer; begin For I := 0 to Length(FClients) - 1 do if FClients[I].FSocket = Socket then begin Result := I; exit; end; Result := -1; end; function ATCPServer.HasClient(const Client: TTCPServerClient): Boolean; begin Result := GetClientIndex(Client) >= 0; end; { } { TTCPServerClient } { } constructor TTCPServerClient.Create(const Server: ATCPServer); begin inherited Create; Assert(Assigned(Server)); FServer := Server; Init; end; procedure TTCPServerClient.Init; begin end; destructor TTCPServerClient.Destroy; begin FreeAndNil(FThread); FreeAndNil(FStream); FreeAndNil(FSocket); inherited Destroy; end; procedure TTCPServerClient.Terminate; var T : Boolean; begin FTerminated := True; if Assigned(FThread) and not FThread.Terminated then FThread.Terminate; if Assigned(FSocket) and not FSocket.Terminated then begin FSocket.Terminate; if Assigned(FThread) and (FSocket.WindowHandle <> 0) then PostMessage(FSocket.WindowHandle, WM_QUIT, 0, 0); end; end; procedure TTCPServerClient.Log(const LogClass: TLogClass; const Msg: String); begin if Assigned(FThread) then TTCPServerClientThread(FThread).Log(LogClass, Msg) else if Assigned(FServer) then FServer.Log(LogClass, Msg); end; procedure TTCPServerClient.ThreadRun; begin if not FTerminated and Assigned(FServer) then FServer.TriggerThreadRun(self); end; procedure TTCPServerClient.SetSocketProperties; begin With FSocket do begin ReadThrottleRate := FServer.FThrottleClientReadRate; ThrottleRead := FServer.FThrottleClientRead; WriteThrottleRate := FServer.FThrottleClientWriteRate; ThrottleWrite := FServer.FThrottleClientWrite; end; end; function TTCPServerClient.GetSocket: TTCPServerClientSocket; begin if not Assigned(FSocket) then begin FSocket := TTCPServerClientSocket.Create(FWinSocket); FSocket.InBufferMaxSize := FServer.InBufferMaxSize; SetSocketProperties; end; Result := FSocket; end; function TTCPServerClient.GetStream: TSocketStream; begin if not Assigned(FStream) then FStream := TSocketStream.Create(GetSocket, False, smAsynchronous, FServer.FTimeOut, FServer.FOutBufferMaxSize); Result := FStream; end; procedure TTCPServerClient.ClientActive; begin end; procedure TTCPServerClient.ClientInactive; begin end; procedure TTCPServerClient.ClientError(const Msg: String); begin FErrorMsg := Msg; end; function TTCPServerClient.GetRemoteAddress: TInAddr; begin Result := FAddress.sin_addr; end; function TTCPServerClient.GetRemoteAddressStr: String; begin Result := IPAddressStr(FAddress.sin_addr); end; function TTCPServerClient.GetRemotePort: Integer; begin Result := NetPortToPort(FAddress.sin_port); end; procedure TTCPServerClient.WriteStr(const S: String); begin GetStream.WriteStr(S); end; function TTCPServerClient.ReadAvailable: String; begin Result := GetStream.Reader.ReadAvailable; end; function TTCPServerClient.PeekStr(const Count: Integer): String; begin Result := GetStream.Reader.PeekStr(Count); end; { Returns True if at least MinCount bytes if available and either i) Delimiter } { occurs (Delimiter <> '') or ii) if MaxCount is available (MaxCount <> -1) or } { iii) (Delimiter = '') and (MaxCount = -1) } function TTCPServerClient.ReadEx(const MinCount, MaxCount: Integer; const Delimiter: String; var Buf: String; const Peek: Boolean): Boolean; var I, L : Integer; InBuf : String; begin L := GetSocket.InBufferSize; if (L = 0) or (L < MinCount) then begin Buf := ''; Result := False; exit; end; InBuf := FSocket.PeekStr(L); if Delimiter <> '' then begin I := Pos(Delimiter, InBuf); if (I > 0) and ((MaxCount = -1) or (I <= MaxCount)) then if I - 1 >= MinCount then begin Buf := CopyLeft(InBuf, I - 1); if not Peek then FSocket.Skip(I + Length(Delimiter) - 1); Result := True; exit; end else begin Result := False; Buf := ''; exit; end; end else if MaxCount = -1 then begin Buf := InBuf; if not Peek then FSocket.Skip(Length(InBuf)); Result := True; exit; end; if (MaxCount >= 0) and (L >= MaxCount) then begin Buf := CopyLeft(InBuf, MaxCount); if not Peek then FSocket.Skip(MaxCount); Result := True; end else begin Buf := ''; Result := False; end; end; function TTCPServerClient.SocketReadLine(var Buf: String; const Delimiter: String): Boolean; begin try Result := ReadEx(0, -1, Delimiter, Buf); except on E: Exception do begin Log(lcError, 'Read error: ' + E.Message); Result := False; end; end; end; function TTCPServerClient.StreamReadLine(var S: String): Boolean; begin S := ''; Result := False; if FTerminated then exit; try S := GetStream.Reader.ExtractLine; Result := True; except on E: Exception do Log(lcError, 'Read error: ' + E.Message); end; end; procedure TTCPServerClient.Synchronize(const Method: TThreadMethod); begin if Assigned(FThread) then FThread.Synchronize(Method); end; end.