Дельфовая обертка для создания TCP серверов.
на каждый коннект свой поток
кэш потоков — обработчиков соединений — т.е.
существенное ускорение обработки новых соединений
плюс возможность выполнить предварительные действия
(например подсоединиться к базе данных)
для использования нужно создать своих наследников
(это НЕ КОМПОНЕНТЫ!!!)
заодно покрыты тема "как получить IP адреса компьютера")
код "живой" так что не судите строго за огрехи,
к тому-же он компилиться под Дельфи 3 и я не ставил задачи
чтобы он компилился без ругани на всех дельфях.
{ =========================================================================== }
{ }
{ Base socket wrapper (threaded model) and misc. functions }
{ Copyright (C) 2002 FleXoft Co. by NeuroVirus <virus@moe.ru> }
{ }
{ =========================================================================== }
{ History: }
{ 0.1 (12-Feb-2002) - initial release, no pools, just simple wrapper }
{ 0.2 (01-Mar-2002) - added server client's handlers pool }
{ 0.3 (10-Mar-2002) - some bugfixes }
{ 0.4 (15-May-2002) - 0.3 version lost, rewritten some pool code }
{ 0.5 (17-Jul-2002) - SendStr() modified for chunked sending }
{ 0.6 (21-Jul-2002) - added AcceptError() and BadRoutedClient() procedures }
{ added ClientClass property }
{ =========================================================================== }
unit fxSockets;
interface
uses
Windows, Classes, SysUtils, WinSock;
const
{ missing in D.3 winsock.pas }
SD_RECEIVE = 0;
SD_SEND = 1;
SD_BOTH = 2;
SOCKET_ERROR = winsock.SOCKET_ERROR;
ANY_IFACE = '0.0.0.0';
LOCAL_IFACE = '127.0.0.1';
type
{ =========================================================================== }
TSocketClient = class;
TSocketClientClass = class of TSocketClient;
TSocketServer = class(TObject)
private
FSocket : TSocket; { listening socket handle }
FSockAddr : TSockAddr; { listening socket address }
FThread : THandle; { listening thread handle }
FListLock : TRTLCriticalSection; { clients and cache list padlock }
FNoClients : THandle; { signaled when no active clients }
FClients : TList; { active clients list }
FNoCached : THandle; { signaled when no cached clients }
FCached : TList; { cached clients list }
FReuseAddr : integer; { reuse listening bind address }
FTimeout : integer; { client timeout, just pass to client }
FMaxConns : integer; { max. connections, 0-no limit }
FCliClass : TSocketClientClass; { client class }
function GetListen: boolean;
function GetReuseAddr: boolean;
procedure SetReuseAddr(RA: boolean);
procedure SetMaxConns(MC: integer);
procedure SetTimeout(Tout: integer);
function GetLocIface: string;
procedure SetLocIface(Iface: string);
function GetLocPort: word;
procedure SetLocPort(P: word);
function GetCachedCnt: integer;
function GetConnCnt: integer;
function GetCached(i: integer): TSocketClient;
function GetConnect(i: integer): TSocketClient;
procedure FillCache;
procedure ClientGone(SC: TSocketClient);
procedure ClientFree(SC: TSocketClient);
procedure Spawn(NSocket: TSocket; LSAddr, RSAddr: TSockAddr);
procedure ExecThread;
protected
procedure LockList;
procedure UnlockList;
property Handle : TSocket read FSocket;
procedure AcceptError(ErrorCode: integer); virtual;
procedure BadRoutedClient(LSAddr, RSAddr: TSockAddr);
function GetClient: TSocketClient; virtual; abstract;
public
constructor Create;
destructor Destroy; override;
property ClientClass : TSocketClientClass read FCliClass write FCliClass;
property CacheCount : integer read GetCachedCnt;
property Cached[i: integer]: TSocketClient read GetCached;
property ReuseAddr : boolean read GetReuseAddr write SetReuseAddr;
property MaxConns : integer read FMaxConns write SetMaxConns;
property Timeout : integer read FTimeout write SetTimeout;
property ConnCount : integer read GetConnCnt;
property Connections[i: integer]: TSocketClient read GetConnect;
property LocalIface : string read GetLocIface write SetLocIface;
property LocalPort : word read GetLocPort write SetLocPort;
property Listening : boolean read GetListen;
procedure CloseAll;
procedure Listen;
procedure Stop;
end;
{ --------------------------------------------------------------------------- }
TSocketClient = class(TObject)
private
FServer : TSocketServer; { server object reference }
FOverload : boolean; { max connections exceeded }
FSameOver : boolean; { max conns. from one IP exceeded }
FKilled : integer; { activated for kill flag }
FTimeout : integer; { operations timeout (in secs) }
FSocket : TSocket; { connection socket handle }
FRSockAddr : TSockAddr; { remote socket addresse }
FLSockAddr : TSockAddr; { local socket addresse }
FActive : THandle; { activate/kill event }
FThread : THandle; { main client thread handle }
FRHostName : string; { resolved host name }
function GetRHost: string;
function GetRAddr: string;
function GetRPort: word;
function GetLAddr: string;
function GetLPort: word;
function GetClosed: boolean;
procedure Activate;
procedure Killing;
procedure ExecThread;
protected
property Server : TSocketServer read FServer;
property Handle : TSocket read FSocket;
property Overload : boolean read FOverload;
property SameOver : boolean read FSameOver;
property Timeout : integer read FTimeout;
procedure ClientInit; virtual; { one time after created }
procedure ClientDone; virtual; { one time before destroying }
procedure Execute; virtual; abstract; { client's code here }
function DataWaits: integer; { bytes_num; SOCKET_ERROR }
function CanWrite(TOut: integer): integer; { 1-can; 0-tout; SOCKET_ERROR }
function CanRead(TOut: integer): integer; { 1-can; 0-tout; SOCKET_ERROR }
function RecvBuff(var Buff; const Len: integer): integer;
function SendBuff(var Buff; const Len: integer): integer;
function RecvStr(var S: string): integer;
function SendStr(S: string): integer;
public
constructor Create;
destructor Destroy; override;
property RemoteHost : string read GetRHost;
property RemoteAddr : string read GetRAddr;
property RemotePort : word read GetRPort;
property LocalAddr : string read GetLAddr;
property LocalPort : word read GetLPort;
property Closed : boolean read GetClosed;
procedure Close;
end;
{ =========================================================================== }
{ misc. socket library functions }
function WinSockErrorDesc(Error: integer): string;
function WinSockInitError: integer;
function WinSockDescription: string;
function WinSockStatus: string;
function WinSockVersion: word;
function WinSockVersionStr: string;
function WinSockMaxSockets: integer;
function WinSockMaxDGSize: integer;
function LocalHostName: string;
function GetInterfaces(S: TStrings): string;
{ =========================================================================== }
implementation
const
CACHE_LO_WATER = 3;
CACHE_HI_WATER = 7;
const
DEF_CHUNK_SIZE = 4096;
{ =========================================================================== }
function ServerLoop(SS: TSocketServer): integer;
begin
Result := 0; try SS.ExecThread; except end;
end;
constructor TSocketServer.Create;
begin
inherited Create;
InitializeCriticalSection(FListLock);
FNoClients := CreateEvent(NIL, True, True, NIL);
FNoCached := CreateEvent(NIL, True, True, NIL);
FClients := TList.Create;
FCached := TList.Create;
FSocket := INVALID_SOCKET;
FSockAddr.sin_family := AF_INET;
FSockAddr.sin_port := 0;
FSockAddr.sin_addr.S_addr := 0;
FThread := 0; FReuseAddr := 0;
FTimeout := 0; FMaxConns := 0;
FCliClass := NIL;
end;
destructor TSocketServer.Destroy;
begin
Stop;
EnterCriticalSection(FListLock);
FClients.Free; FCached.Free;
if (FThread <> 0) then CloseHandle(FThread);
CloseHandle(FNoClients);
CloseHandle(FNoCached);
LeaveCriticalSection(FListLock);
inherited Destroy;
DeleteCriticalSection(FListLock);
end;
{ ------------------ }
procedure TSocketServer.LockList;
begin
EnterCriticalSection(FListLock);
end;
procedure TSocketServer.UnlockList;
begin
LeaveCriticalSection(FListLock);
end;
function TSocketServer.GetReuseAddr: boolean;
begin
Result := (FReuseAddr <> 0);
end;
procedure TSocketServer.SetReuseAddr(RA: boolean);
begin
InterlockedExchange(FReuseAddr, integer(RA));
end;
procedure TSocketServer.SetMaxConns(MC: integer);
begin
if (MC < 0) then MC := 0;
InterlockedExchange(FMaxConns, MC);
end;
procedure TSocketServer.SetTimeout(Tout: integer);
begin
if (Tout < 0) then Tout := 0;
InterlockedExchange(FTimeout, Tout);
end;
function TSocketServer.GetLocIface: string;
begin
Result := StrPas(inet_ntoa(FSockAddr.sin_addr));
end;
procedure TSocketServer.SetLocIface(Iface: string);
var Addr: integer;
begin
Addr := inet_addr(PChar(Iface));
if (Addr = INADDR_NONE) then Addr := INADDR_ANY;
InterlockedExchange(FSockAddr.sin_addr.S_addr, Addr);
end;
function TSocketServer.GetLocPort: word;
begin
Result := ntohs(FSockAddr.sin_port);
end;
procedure TSocketServer.SetLocPort(P: word);
begin
FSockAddr.sin_port := htons(P);
end;
function TSocketServer.GetCachedCnt: integer;
begin
EnterCriticalSection(FListLock);
Result := FCached.Count;
LeaveCriticalSection(FListLock);
end;
function TSocketServer.GetConnCnt: integer;
begin
EnterCriticalSection(FListLock);
Result := FClients.Count;
LeaveCriticalSection(FListLock);
end;
function TSocketServer.GetCached(i: integer): TSocketClient;
begin
Result := NIL; if (i < 0) then Exit;
EnterCriticalSection(FListLock);
if (i < FCached.Count) then
Result := TSocketClient(FCached.Items[i]);
LeaveCriticalSection(FListLock);
end;
function TSocketServer.GetConnect(i: integer): TSocketClient;
begin
Result := NIL; if (i < 0) then Exit;
EnterCriticalSection(FListLock);
if (i < FClients.Count) then
Result := TSocketClient(FClients.Items[i]);
LeaveCriticalSection(FListLock);
end;
function TSocketServer.GetListen: boolean;
begin
Result := (FSocket <> INVALID_SOCKET);
end;
{ ------------------ }
(*
function TSocketServer.GetClient: TSocketClient;
begin
{ must be overriden by child server }
{ with no inheritance call !!! }
Result := TSocketClient.Create;
end;
*)
{ calling from listen/clients threads }
{ make at least CACHE_LOW_WATER idle clients }
procedure TSocketServer.FillCache;
var CC: TSocketClient;
begin
EnterCriticalSection(FListLock);
while (FCached.Count < CACHE_LO_WATER) do begin
if Assigned(FCliClass) then CC := FCliClass.Create
else CC := GetClient;
CC.FServer := Self; FCached.Add(CC);
end; ResetEvent(FNoCached);
LeaveCriticalSection(FListLock);
end;
{ client work finished, its thread return client }
{ into cache but not more than CACHE_HI_WATER }
procedure TSocketServer.ClientGone(SC: TSocketClient);
begin
EnterCriticalSection(FListLock);
FClients.Remove(SC);
if (FClients.Count = 0) then SetEvent(FNoClients);
if (FCached.Count < CACHE_HI_WATER) and
(FSocket <> INVALID_SOCKET) then begin
FCached.Add(SC); ResetEvent(FNoCached);
end else SC.Killing; { not cache, kill }
LeaveCriticalSection(FListLock);
end; //``````````````````````````````````````````````````````````````````````
{ client object about to destroying }
{ remove it from active and cache lists }
procedure TSocketServer.ClientFree(SC: TSocketClient);
begin
EnterCriticalSection(FListLock);
FCached.Remove(SC); FClients.Remove(SC);
if (FClients.Count = 0) then SetEvent(FNoClients);
if (FCached.Count = 0) then SetEvent(FNoCached);
LeaveCriticalSection(FListLock);
end;
{ spawn new client connection worker }
{ may be from cache or create new one }
procedure TSocketServer.Spawn(NSocket: TSocket; LSAddr, RSAddr: TSockAddr);
var CC: TSocketClient; Over: boolean;
begin
EnterCriticalSection(FListLock);
Over := (FMaxConns > 0) and
(FClients.Count >= FMaxConns);
if (FCached.Count > 0) then begin
CC := FCached.Items[FCached.Count - 1];
FCached.Delete(FCached.Count - 1);
if (FCached.Count = 0) then SetEvent(FNoCached);
end else begin
if Assigned(FCliClass) then CC := FCliClass.Create
else CC := GetClient;
end;
if Assigned(CC) then begin
FClients.Add(CC); ResetEvent(FNoClients);
LeaveCriticalSection(FListLock);
end else begin
{ Critical: kill it if create or get-cached client failed }
shutdown(NSocket, SD_BOTH); closesocket(NSocket);
LeaveCriticalSection(FListLock); Exit;
end;
CC.FSocket := NSocket; CC.FServer := Self;
CC.FTimeout := FTimeout; CC.FOverload := Over;
CC.FRSockAddr := RSAddr; CC.FLSockAddr := LSAddr;
CC.Activate;
end;
{ virtual procedure, may use for logging or delay }
procedure TSocketServer.AcceptError(ErrorCode: integer);
begin
end;
{ virtual procedure, may use for logging }
procedure TSocketServer.BadRoutedClient(LSAddr, RSAddr: TSockAddr);
begin
end;
{ main listening thread which accepting connections }
procedure TSocketServer.ExecThread;
var NSocket: TSocket; Res: integer;
RSAddr, LSAddr: TSockAddr;
RSALen, LSALen: integer;
begin
FillCache; { preload cache }
while True do begin
RSALen := SizeOf(RSAddr);
NSocket := accept(FSocket, @RSAddr, @RSALen);
if (NSocket = INVALID_SOCKET) then begin
Res := WSAGetLastError;
AcceptError(Res);
if (Res = WSAEMFILE) or
(Res = WSAENOBUFS) then Sleep(0)
else Break;
end else begin
LSALen := SizeOf(LSAddr);
getsockname(NSocket, LSAddr, LSALen);
if (RSAddr.sin_addr.S_addr = INADDR_ANY) or
(LSAddr.sin_addr.S_addr = INADDR_ANY) then begin
{ Warning: immediately kill bad routed connection }
BadRoutedClient(LSAddr, RSAddr);
shutdown(NSocket, SD_BOTH); closesocket(NSocket);
end else begin
{ Ok, activating working client handler }
Spawn(NSocket, LSAddr, RSAddr);
end;
end;
end;
closesocket(InterlockedExchange(FSocket, INVALID_SOCKET));
end;
{ ------------------ }
procedure TSocketServer.CloseAll;
var i: integer;
begin
EnterCriticalSection(FListLock);
for i := 0 to FClients.Count - 1 do
TSocketClient(FClients.Items[i]).Close;
LeaveCriticalSection(FListLock);
WaitForSingleObject(FNoClients, INFINITE);
end;
procedure RaiseErr(fn: string; no: integer);
begin
raise Exception.Create(fn + ' error #' + IntToStr(no));
end;
procedure TSocketServer.Listen;
var Res: integer; TID: THandle;
begin
if (FSocket <> INVALID_SOCKET) then Stop;
try
FSocket := winsock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
if (FSocket = INVALID_SOCKET) then RaiseErr('socket', WSAGetLastError);
Res := winsock.bind(FSocket, FSockAddr, SizeOf(FSockAddr));
if (Res = SOCKET_ERROR) then RaiseErr('bind', WSAGetLastError);
Res := winsock.listen(FSocket, SOMAXCONN);
if (Res = SOCKET_ERROR) then RaiseErr('listen', WSAGetLastError);
FThread := BeginThread(NIL, 0, @ServerLoop, Self, 0, TID);
if (FThread = 0) then RaiseErr('thread', GetLastError);
except
if (FSocket <> INVALID_SOCKET) then
closesocket(InterlockedExchange(FSocket, INVALID_SOCKET));
raise;
end;
end;
procedure TSocketServer.Stop;
var Sk: TSocket; i: integer;
XX: array[0..1] of THandle;
begin
Sk := InterlockedExchange(FSocket, INVALID_SOCKET);
if (Sk <> INVALID_SOCKET) then closesocket(Sk);
EnterCriticalSection(FListLock);
for i := 0 to FClients.Count - 1 do
TSocketClient(FClients.Items[i]).Killing;
for i := 0 to FCached.Count - 1 do
TSocketClient(FCached.Items[i]).Killing;
LeaveCriticalSection(FListLock);
XX[0] := FNoClients; XX[1] := FNoCached;
WaitForMultipleObjects(2, @XX, True, INFINITE);
WaitForSingleObject(FThread, INFINITE);
CloseHandle(InterlockedExchange(FThread, 0));
end;
{ =========================================================================== }
function ClientLoop(SC: TSocketClient): integer;
begin
Result := 0; SC.ExecThread; SC.Free;
end;
constructor TSocketClient.Create;
var TID: THandle;
begin
inherited Create;
FServer := NIL; FKilled := 0;
FTimeout := 0;
FOverload := False; FSameOver := False;
FSocket := INVALID_SOCKET;
FRSockAddr.sin_family := AF_INET;
FRSockAddr.sin_port := 0;
FRSockAddr.sin_addr.S_addr := 0;
FActive := CreateEvent(NIL, False, False, NIL);
FThread := BeginThread(NIL, 0, @ClientLoop, Self, 0, TID);
end;
destructor TSocketClient.Destroy;
begin
FServer.ClientFree(Self);
CloseHandle(FActive); CloseHandle(FThread);
inherited Destroy;
end;
{ ------------------ }
procedure TSocketClient.ClientInit;
begin
{ --- inherited by child object --- }
end;
procedure TSocketClient.ClientDone;
begin
{ --- inherited by child object --- }
end;
(*
procedure TSocketClient.Execute;
begin
{ --- inherited by child object --- }
end;
*)
function TSocketClient.GetRHost: string;
var pHE: PHostEnt;
begin
if (FRHostName = EmptyStr) then begin
pHE := gethostbyaddr(@FRSockAddr.sin_addr,
SizeOf(FRSockAddr.sin_addr),
PF_INET);
if not Assigned(pHE) then FRHostName := GetRAddr
else FRHostName := StrPas(pHE^.h_name);
end; Result := FRHostName;
end;
function TSocketClient.GetRAddr: string;
begin
Result := StrPas(inet_ntoa(FRSockAddr.sin_addr));
end;
function TSocketClient.GetRPort: word;
begin
Result := ntohs(FRSockAddr.sin_port);
end;
function TSocketClient.GetLAddr: string;
begin
Result := StrPas(inet_ntoa(FLSockAddr.sin_addr));
end;
function TSocketClient.GetLPort: word;
begin
Result := ntohs(FLSockAddr.sin_port);
end;
function TSocketClient.GetClosed: boolean;
begin
Result := (FSocket = INVALID_SOCKET);
end;
{ ------------------ }
procedure TSocketClient.Activate;
begin
InterlockedExchange(FKilled, 0);
SetEvent(FActive);
end;
procedure TSocketClient.Killing;
begin
InterlockedExchange(FKilled, 1);
SetEvent(FActive); Close;
end;
procedure TSocketClient.ExecThread;
begin
try ClientInit; except end;
while (FKilled = 0) do begin
WaitForSingleObject(FActive, INFINITE);
if (FKilled <> 0) then Break;
FServer.FillCache;
FRHostName := EmptyStr;
try Execute; except end; Close;
FServer.ClientGone(Self);
end;
try ClientDone; except end;
end;
procedure TSocketClient.Close;
var Sk: TSocket;
begin
Sk := InterlockedExchange(FSocket, INVALID_SOCKET);
if (Sk <> INVALID_SOCKET) then begin
shutdown(Sk, SD_BOTH); closesocket(Sk);
end;
end;
{ ------------------ }
function TSocketClient.DataWaits: integer;
var Res: integer;
begin
Res := ioctlsocket(FSocket, FIONREAD, Result);
if (Res <> 0) then Result := SOCKET_ERROR;
end;
function TSocketClient.CanWrite(TOut: integer): integer;
var FDSet: TFDSet; TV: TTimeVal;
begin
FD_ZERO(FDSet); FD_SET(FSocket, FDSet);
if (TOut >= 0) then begin
TV.tv_sec := TOut; TV.tv_usec := 0;
Result := select(0, NIL, @FDSet, NIL, @TV);
end else Result := select(0, NIL, @FDSet, NIL, NIL);
end;
function TSocketClient.CanRead(TOut: integer): integer;
var FDSet: TFDSet; TV: TTimeVal;
begin
FD_ZERO(FDSet); FD_SET(FSocket, FDSet);
if (TOut >= 0) then begin
TV.tv_sec := TOut; TV.tv_usec := 0;
Result := select(0, @FDSet, NIL, NIL, @TV);
end else Result := select(0, @FDSet, NIL, NIL, NIL);
end;
function TSocketClient.RecvBuff(var Buff; const Len: integer): integer;
begin
Result := recv(FSocket, Buff, Len, 0);
if (Result = 0) then begin
Result := SOCKET_ERROR;
WSASetLastError(WSAENOTCONN);
end; if (Result = SOCKET_ERROR) then Close;
end;
function TSocketClient.SendBuff(var Buff; const Len: integer): integer;
begin
Result := send(FSocket, Buff, Len, 0);
if (Result = SOCKET_ERROR) then Close;
end;
function TSocketClient.RecvStr(var S: string): integer;
var Sz: integer; FDSet: TFDSet;
begin
FD_ZERO(FDSet); FD_SET(FSocket, FDSet);
Result := select(0, @FDSet, NIL, NIL, NIL);
if (Result = SOCKET_ERROR) then Exit;
Result := ioctlsocket(FSocket, FIONREAD, Sz);
if (Sz <= 0) then begin Close; Exit; end;
if (Result = SOCKET_ERROR) then Exit;
SetLength(S, Sz); Result := RecvBuff(S[1], Sz);
end;
function TSocketClient.SendStr(S: string): integer;
var r, z: integer;
begin
z := Length(S);
r := z; Result := z;
while (z > 0) do begin
if (z > DEF_CHUNK_SIZE) then z := DEF_CHUNK_SIZE;
Result := SendBuff(S[1], z);
if (Result <= 0) then Break;
Delete(S, 1, z); z := Length(S);
end;
if (Result > 0) then Result := r;
end;
{ =========================================================================== }
type
TaPInAddr = packed array [0..63] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
WSAInit : integer;
WSAData : TWSAData;
function WinSockErrorDesc(Error: integer): string;
begin
case Error of
0 : Result := EmptyStr;
WSAEINTR : Result := 'Interrupted system call';
WSAEBADF : Result := '';
WSAEACCES : Result := 'Permission denied';
WSAEFAULT : Result := '';
WSAEINVAL : Result := 'Invalid argument(s)';
WSAEMFILE : Result := '';
WSAEWOULDBLOCK : Result := 'Operation would block';
WSAEINPROGRESS : Result := 'Operation in progress';
WSAEALREADY : Result := '';
WSAENOTSOCK : Result := 'Not a socket';
WSAEDESTADDRREQ : Result := 'Destination address required';
WSAEMSGSIZE : Result := 'Message too long';
WSAEPROTOTYPE : Result := '';
WSAENOPROTOOPT : Result := '';
WSAEPROTONOSUPPORT : Result := 'Protocol not supported';
WSAESOCKTNOSUPPORT : Result := '';
WSAEOPNOTSUPP : Result := 'Option not supported';
WSAEPFNOSUPPORT : Result := 'Protocol family not supported';
WSAEAFNOSUPPORT : Result := 'Address family not supported';
WSAEADDRINUSE : Result := 'Address already in use';
WSAEADDRNOTAVAIL : Result := 'Cannot assign requested address';
WSAENETDOWN : Result := 'Network is down';
WSAENETUNREACH : Result := 'Network unreachable';
WSAENETRESET : Result := 'Network dropped connection on reset';
WSAECONNABORTED : Result := 'Connection aborted';
WSAECONNRESET : Result := 'Connection reset';
WSAENOBUFS : Result := 'No buffer space available';
WSAEISCONN : Result := '';
WSAENOTCONN : Result := 'Not connected';
WSAESHUTDOWN : Result := '';
WSAETOOMANYREFS : Result := '';
WSAETIMEDOUT : Result := 'Operation timeout';
WSAECONNREFUSED : Result := 'Connection refused';
WSAELOOP : Result := '';
WSAENAMETOOLONG : Result := '';
WSAEHOSTDOWN : Result := 'Host is down';
WSAEHOSTUNREACH : Result := 'Host unreachable';
WSAENOTEMPTY : Result := '';
WSAEPROCLIM : Result := 'Too many processes';
WSAEUSERS : Result := '';
WSAEDQUOT : Result := '';
WSAESTALE : Result := '';
WSAEREMOTE : Result := '';
WSASYSNOTREADY : Result := 'System not ready';
WSAVERNOTSUPPORTED : Result := 'Not supported';
WSANOTINITIALISED : Result := 'Not initialized';
WSAEDISCON : Result := 'Shutdown in progress';
WSAHOST_NOT_FOUND : Result := 'Host not found';
WSATRY_AGAIN : Result := 'Lookup try again';
WSANO_RECOVERY : Result := 'Lookup no recovery';
WSANO_DATA : Result := 'Lookup no data record';
else Result := 'WSAError #' + IntToStr(Error); end;
{
if (Error = 0) then Error := 10000;
SetLength(Result, MAX_PATH);
Error := LoadString(HInstance, Error, @Result[1], MAX_PATH);
SetLength(Result, Error);
}
end;
function WinSockInitError: integer;
begin
Result := WSAInit;
end;
function WinSockDescription: string;
begin
Result := StrPas(WSAData.szDescription);
end;
function WinSockStatus: string;
begin
Result := StrPas(WSAData.szSystemStatus);
end;
function WinSockMaxSockets: integer;
begin
Result := WSAData.iMaxSockets;
end;
function WinSockMaxDGSize: integer;
begin
Result := WSAData.iMaxUdpDg;
end;
function WinSockVersion: word;
begin
Result := WSAData.wVersion;
end;
function WinSockVersionStr: string;
begin
Result := IntToStr(Lo(WSAData.wVersion)) + '.' +
IntToStr(Hi(WSAData.wVersion));
end;
function LocalHostName: string;
begin
SetLength(Result, MAX_PATH);
if (GetHostName(@Result[1], MAX_PATH) = 0) then
Result := StrPas(@Result[1])
else Result := EmptyStr;
end;
function GetInterfaces(S: TStrings): string;
var pHE: PHostEnt; pPIA: PaPInAddr; i: integer;
begin
Result := LocalHostName;
if (Result = EmptyStr) then Exit;
if not Assigned(S) then Exit; S.Clear;
pHE := GetHostByName(@Result[1]);
if not Assigned(pHE) then Exit;
pPIA := PaPInAddr(pHE^.h_addr_list); i := 0;
while Assigned(pPIA^[i]) do begin
S.Append(StrPas(inet_ntoa(pPIA^[i]^)));
Inc(i);
end;
end;
{ =========================================================================== }
initialization
begin
IsMultiThread := True;
WSAInit := WSAStartup(MakeWord(1, 1), WSAData);
if (WSAInit = 0) and
(WSAData.wHighVersion <> MakeWord(1, 1)) then begin
WSACleanup;
WSAInit := WSAStartup(WSAData.wHighVersion, WSAData);
end;
end;
finalization
begin
if (WSAInit = 0) then begin
WSACleanup;
WSAInit := WSANOTINITIALISED;
end;
end;
end.
(*
function TSocketConnect.SendFile(FName: string; ChunkSize: integer): integer;
var hFile, hMap: THandle; Dptr, Bptr: PChar;
FileLen, DataPart: integer;
begin
if (ChunkSize <= 0) then ChunkSize := DEF_CHUNK_SIZE;
hFile := CreateFile(NIL, GENERIC_READ, FILE_SHARE_READ, NIL,
OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0);
if (hFile = INVALID_HANDLE_VALUE) then begin
Result := GetLastError; Exit;
end; FileLen := GetFileSize(hFile, NIL);
hMap := CreateFileMapping(hFile, NIL, PAGE_READONLY, 0, 0, NIL);
Result := GetLastError; CloseHandle(hFile); if (hMap = 0) then Exit;
Dptr := MapViewOfFile(hMap, FILE_MAP_READ, 0, 0, 0);
Result := GetLastError; CloseHandle(hMap); if (Dptr = NIL) then Exit;
if (FileLen <= ChunkSize) then begin
Bptr := GlobalAllocPtr(GPTR, FileLen);
Move(Dptr^, Bptr^, FileLen); UnmapViewOfFile(Dptr);
Result := SendBuff(Bptr^, FileLen); GlobalFreePtr(Bptr);
end else begin
while (FileLen > 0) do begin
if (FileLen >= ChunkSize) then DataPart := ChunkSize
else DataPart := FileLen;
Result := SendBuff(Dptr^, DataPart);
if (Result = 0) or (Result = SOCKET_ERROR) then Break;
FileLen := FileLen - DataPart; Dptr := Dptr + DataPart;
end;
UnmapViewOfFile(Dptr);
end;
end;
*)
