{unit IOCPComp;}
function TCustomSocket.Read(var Buf; Count: Integer): Integer;
begin
raise ESocketError.Create('Error');
end;
function TCustomSocket.Write(var Buf; Count: Integer): Integer;
begin
raise ESocketError.Create('Error');
end;
{ TCustomerServerSocket }
function TCustomerServerSocket.DoClientRead(ASocket: TCustomSocket;
AData: Pointer; ACount: Integer): Integer;
begin
if not Assigned(FOnClientRead) then
Result := 0 else
Result := FOnClientRead(ASocket, AData, ACount);
end;
procedure TCustomerServerSocket.ClientSocketError(ASocket: TCustomSocket;
ErrorEvent: TErrorEvent; var ErrCode: Integer);
begin
if Assigned(FOnClientError) then
FOnClientError(ASocket, ErrorEvent, ErrCode);
end;
procedure TCustomerServerSocket.ClientSocketEvent(ASocket: TCustomSocket;
SocketEvent: TSocketEvent);
begin
if Assigned(FOnClientEvent) then
FOnClientEvent(ASocket, SocketEvent);
end;
{ TServerSocket }
procedure TServerSocket.Accept(ASocket: TSocket; ACompletionPort: THandle);
var
Addr: TSockAddrIn;
AddrLen, Ret, ErrCode: Integer;
ClientWinSocket: TSocket;
ClientSocket: TServerClientSocket;
begin
AddrLen := SizeOf(Addr);
ClientWinSocket := WinSock2.accept(ASocket, Addr, AddrLen);
if ClientWinSocket <> INVALID_SOCKET then
begin
if not Active and not IsAccept(ClientWinSocket) then
begin
closesocket(ClientWinSocket);
Exit;
end;
try
Event(seAccept);
ClientSocket := nil;
if Assigned(FOnGetSocket) then
FOnGetSocket(ClientWinSocket, ClientSocket);
if not Assigned(ClientSocket) then
ClientSocket := TServerClientSocket.Create(Self, ClientWinSocket);
except
closesocket(ClientWinSocket);
ErrCode := GetLastError;
Error(eeAccept, ErrCode);
Exit;
end;
Ret := CreateIoCompletionPort(ClientWinSocket, ACompletionPort, DWORD(ClientSocket), 0);
if Ret = 0 then
ClientSocket.Free;
end;
end;
constructor TServerSocket.Create;
begin
inherited Create(INVALID_SOCKET);
FBuffer := TMemoryBuffer.Create(Self);
FClients := TList.Create;
FThreads := TList.Create;
FPort := 211;
FAcceptThread := nil;
FCompletionPort := 0;
IsMultiThread := True;
FHandle := Classes.AllocateHWnd(WndProc);
end;
destructor TServerSocket.Destroy;
begin
SetActive(False);
FThreads.Free;
FClients.Free;
Classes.DeallocateHWnd(FHandle);
FBuffer.Free;
inherited Destroy;
end;
function TServerSocket.FindClientSocket(ASocket: TSocket): TCustomSocket;
var
I: Integer;
begin
Lock;
try
for I := 0 to FClients.Count - 1 do
begin
Result := FClients[I];
if ASocket = Result.SocketHandle then Exit;
end;
Result := nil;
finally
UnLock;
end;
end;
function TServerSocket.GetClientCount: Integer;
begin
Result := FClients.Count;
end;
function TServerSocket.GetClients(const Index: Integer): TServerClientSocket;
begin
Result := FClients[Index];
end;
procedure TServerSocket.InternalClose;
procedure CloseObject(var Handle: THandle);
begin
if Handle <> 0 then
begin
CloseHandle(Handle);
Handle := 0;
end;
end;
var
I: Integer;
Thread: TThread;
begin
Lock;
try
while FClients.Count > 0 do
TObject(FClients.Last).Free;
FClients.Clear;
for I := FThreads.Count - 1 downto 0 do
begin
Thread := FThreads[I];
PostQueuedCompletionStatus(FCompletionPort, 0, 0, Pointer(SHUTDOWN_FLAG));
Thread.Terminate;
end;
FThreads.Clear;
if FSocket <> INVALID_SOCKET then
begin
Event(seDisconnect);
closesocket(FSocket);
FSocket := INVALID_SOCKET;
end;
FAcceptThread.Terminate;
CloseObject(FCompletionPort);
finally
UnLock;
end;
end;
procedure TServerSocket.InternalOpen;
var
I: Integer;
Thread: TThread;
SystemInfo: TSystemInfo;
begin
Lock;
try
try
FCompletionPort := CreateIoCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
if FCompletionPort = 0 then
raise ESocketError.Create(SysErrorMessage(GetLastError));
Event(seInitIOPort);
GetSystemInfo(SystemInfo);
for I := 0 to SystemInfo.dwNumberOfProcessors * 2 - 1 do
begin
Thread := TWorkerThread.Create(Self);
FThreads.Add(Thread);
end;
FSocket := WSASocket(PF_INET, SOCK_STREAM, 0, nil, 0, WSA_FLAG_OVERLAPPED);
if FSocket = INVALID_SOCKET then
raise ESocketError.Create(SysErrorMessage(GetLastError));
Event(seInitSocket);
FillChar(FAddr, SizeOf(FAddr), 0);
FAddr.sin_family := AF_INET;
FAddr.sin_port := htons(FPort);
FAddr.sin_addr.S_addr := INADDR_ANY;
CheckError(bind(FSocket, @FAddr, SizeOf(FAddr)), 'bind');
Event(seListen);
CheckError(listen(FSocket, SOMAXCONN), 'listen');
FAcceptThread := TAcceptThread.Create(Self);
except
InternalClose;
raise;
end;
finally
UnLock;
end;
end;
function TServerSocket.IsAccept(Socket: TSocket): Boolean;
begin
Result := True;
end;
procedure TServerSocket.RegisterClient(ASocket: TCustomSocket);
begin
Lock;
try
if FClients.IndexOf(ASocket) = -1 then
begin
FClients.Add(ASocket);
WSAAsyncSelect(ASocket.SocketHandle, FHandle, WM_CLIENTSOCKET, FD_CLOSE);
end;
finally
UnLock;
end;
end;
procedure TServerSocket.RemoveClient(ASocket: TCustomSocket);
var
Index: Integer;
begin
Lock;
try
Index := FClients.IndexOf(ASOcket);
if Index <> -1 then
FClients.Delete(Index);
finally
UnLock;
end;
end;
procedure TServerSocket.SetActive(Value: Boolean);
begin
if FActive = Value then Exit;
if Value then
InternalOpen
else
InternalClose;
FActive := Value;
end;
procedure TServerSocket.SetPort(Value: Integer);
begin
if Active then
raise ESocketError.Create('Cann''t change port');
FPort := Value;
end;
procedure TServerSocket.WMClientClose(var Message: TCMSocketMessage);
var
ClientSocket: TCustomSocket;
begin
ClientSocket := FindClientSocket(Message.Socket);
if Assigned(ClientSocket) then
ClientSocket.Free;
end;
procedure TServerSocket.WndProc(var Message: TMessage);
begin
try
Dispatch(Message);
except
if Assigned(ApplicationHandleException) then
ApplicationHandleException(Self);
end;
end;
{ TServerClientSocket }
