IOCP For Delphi XE3

program IOCPServer;

uses
  System.SysUtils,
  Winapi.Windows,
  Winapi.WinSock2;

const
 DATA_BUFSIZE = 8192;

type

  LPPER_IO_OperaTION_DATA = ^ PER_IO_OPERATION_DATA ;
  PER_IO_OPERATION_DATA = packed record
    Overlapped: OVERLAPPED;
    DataBuf: TWSABUF;
    Buffer: array [0..DATA_BUFSIZE] of AnsiCHAR;
    BytesSEND: DWord;
    BytesRECV: DWORD;
    dwFlags: DWORD;
  end;

  LPPER_HANDLE_DATA = ^ PER_HANDLE_DATA;
  PER_HANDLE_DATA = packed record
    Socket: TSocket;
    ClientAddr: SOCKADDR_STORAGE;
  end;

function ServerWorkerThread(IpParam: LPVOID): DWORD; stdcall;
var
   CompletionPort: THANDLE;
   BytesTransferred: DWORD ;
   PerHandleData: LPPER_HANDLE_DATA ;
   PerIoData: LPPER_IO_OPERATION_DATA ;
   ClientAddr:SOCKADDR_IN;
   SendByte:DWORD;
begin
   CompletionPort := THANDLE(IpParam);

   Result:= 0;

   while(TRUE) do
   begin
      if (GetQueuedCompletionStatus(CompletionPort,BytesTransferred,
          ULONG_PTR(PerHandleData),POverlapped(PerIoData),INFINITE) = False) then
      begin
        WriteLn( Format('GetQueuedCompletionStatus failed with error %d', [GetLastError]) );
      end;

      // First check to see if an error has occured on the socket and if so
      // then close the socket and cleanup the SOCKET_INFORMATION structure
      // associated with the socket.

      if (BytesTransferred = 0) then
      begin
        WriteLn( Format('Closing socket %d\', [PerHandleData.Socket]) );

         if (closesocket(PerHandleData.Socket) = SOCKET_ERROR) then
         begin
           WriteLn( Format('closesocket failed with error %d', [WSAGetLastError]) );
            exit;
         end;
         GlobalFree(DWORD(PerHandleData));
         GlobalFree(DWORD(PerIoData));
         continue;
      end;

      // Check to see if the BytesRECV field equals zero. If this is so, then
      // this means a WSARecv call just completed so update the BytesRECV field
      // with the BytesTransferred value from the completed WSARecv() call.

      if (PerIoData.BytesRECV = 0) then
      begin
         PerIoData.BytesRECV := BytesTransferred;
         PerIoData.BytesSEND := 0;
      end
      else
      begin
         PerIoData.BytesSEND := PerIoData.BytesSEND + BytesTransferred;
      end;

      if (PerIoData.BytesRECV > PerIoData.BytesSEND) then
      begin
         // Display Client IP and Send Msg
         CopyMemory(@ClientAddr, @PerHandleData^.ClientAddr,  Sizeof(ClientAddr));
         WriteLn( Format('Client %s Say :%s',[inet_ntoa(ClientAddr.sin_addr),PerIoData.DataBuf.buf]));

         // Post another WSASend() request.
         // Since WSASend() is not gauranteed to send all of the bytes requested,
         // continue posting WSASend() calls until all received bytes are sent.

         ZeroMemory(@(PerIoData.Overlapped), sizeof(OVERLAPPED));

         PerIoData.DataBuf.buf := PerIoData.Buffer + PerIoData.BytesSEND;
         PerIoData.DataBuf.len := PerIoData.BytesRECV - PerIoData.BytesSEND;

         if (WSASend(PerHandleData.Socket, @(PerIoData.DataBuf), 1, PerIoData.BytesSEND, 0,
            @(PerIoData.Overlapped), nil) = SOCKET_ERROR) then
         begin
            if (WSAGetLastError() <> ERROR_IO_PENDING) then
            begin
               Exit;
            end;
         end;
      end
      else
      begin
         PerIoData.BytesRECV := 0;

         // Now that there are no more bytes to send post another WSARecv() request.

         ZeroMemory(@(PerIoData.Overlapped), sizeof(OVERLAPPED));

         PerIoData.DataBuf.len := DATA_BUFSIZE;
         PerIoData.DataBuf.buf := @PerIoData.Buffer;

         if (WSARecv(PerHandleData.Socket, @(PerIoData.DataBuf), 1, PerIoData.BytesRECV, PerIoData.dwFlags,
            @(PerIoData.Overlapped), nil) = SOCKET_ERROR) then
         begin
            if (WSAGetLastError() <> ERROR_IO_PENDING) then
            begin
               exit;
            end;
         end;
      end;
   end;
end;

unction ServerStar(nPort:Integer):Integer;
var
  InternetAddr: SOCKADDR_IN;
  saRemote:SOCKADDR_IN;
  RemoteLen: Integer;
  Listen: TSOCKET;
  Accept: TSOCKET;
  CompletionPort:THandle;
  SystemInfo: SYSTEM_INFO ;
  PerHandleData: LPPER_HANDLE_DATA ;
  PerIoData: LPPER_IO_OPERATION_DATA ;
  i: Integer;
  ThreadID: DWORD ;
  wsaData: TWSADATA ;
  ThreadHandle: THANDLE;
begin
  // init socket
  Result := WSAStartup($0202, wsaData);
  if (Result <> 0) then
    begin
      WriteLn( Format('WSAStartup failed with error %d', [Result]) );
      Exit;
    end;

  // Setup an I/O completion port.
  CompletionPort := CreateIoCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
  if (CompletionPort = 0) then
    begin
      WriteLn( Format('CreateIoCompletionPort failed with error: %d', [GetLastError]) );
      Exit;
    end;

  // Determine how many processors are on the system.

  GetSystemInfo(SystemInfo);

  // Create worker threads based on the number of processors available on the
  // system. Create two worker threads for each processor.

  for i:= 0 to SystemInfo.dwNumberOfProcessors * 2 - 1 do
    begin
      // Thread Count Cpu * 2
      // Create a server worker thread and pass the completion port to the thread.
      ThreadHandle := CreateThread(nil, 0, @ServerWorkerThread, Pointer(CompletionPort),
         0, ThreadID);
      if (ThreadHandle = 0) then
      begin
        WriteLn( Format('CreateThread() failed with error %d', [GetLastError]) );
        Exit;
      end;
      // Close the thread handle
      CloseHandle(ThreadHandle);
    end;

   // Create a listening socket
   Listen := WSASocket(AF_INET, SOCK_STREAM, 0, nil, 0, WSA_FLAG_OVERLAPPED);
   if (Listen = INVALID_SOCKET) then
   begin
      WriteLn( Format('WSASocket() failed with error %d', [WSAGetLastError]) );
      exit;
   end;

   InternetAddr.sin_family := AF_INET;
   InternetAddr.sin_addr.s_addr := htonl(INADDR_ANY);
   InternetAddr.sin_port := htons(nPORT);

   if (bind(Listen, sockaddr(InternetAddr), sizeof(InternetAddr)) = SOCKET_ERROR) then
   begin
      WriteLn( Format('bind() failed with error %d', [WSAGetLastError]) );
      exit;
   end;

   // Prepare socket for listening
   // 5:max number of connect request | SOMAXCONN

   if (Winapi.WinSock2.listen(Listen, 5) = SOCKET_ERROR) then
   begin
      WriteLn( Format('listen() failed with error %d', [WSAGetLastError]) );
      exit;
   end
   else
   begin
      WriteLn( Format('Server listen on port = %d ...', [nPORT]) );
   end;

   // Accept connections and assign to the completion port.
   while(TRUE) do
   begin
      RemoteLen:=Sizeof(saRemote);
      Accept:= WSAAccept(Listen, @saRemote, @RemoteLen, nil, 0);

      //Accept := WSAAccept(Listen, nil, nil, nil, 0);
      if (Accept = SOCKET_ERROR) then
     begin
        WriteLn( Format('WSAAccept() failed with error %d', [WSAGetLastError]) );
        exit;
     end;

      // Create a socket information structure to associate with the socket
      PerHandleData := LPPER_HANDLE_DATA (GlobalAlloc(GPTR, sizeof(PER_HANDLE_DATA)));
      if (PerHandleData = nil) then
      begin
        WriteLn( Format('GlobalAlloc() failed with error %d', [WSAGetLastError]) );
        exit;
      end;

       // Associate the accepted socket with the original completion port.
      WriteLn( Format('Socket number %d connected', [Accept]) );
      PerHandleData.Socket := Accept;
      // Copy the accepted socket to ClientAddr
      CopyMemory(@PerHandleData^.ClientAddr, @saRemote, RemoteLen);
      // Associate the accepted socket with the IP.
      WriteLn( Format('Socket number %s connected', [inet_ntoa(saRemote.sin_addr)]) );

      if (CreateIoCompletionPort(Accept, CompletionPort, DWORD(PerHandleData), 0) = 0) then
      begin
        WriteLn( Format('CreateIoCompletionPort() failed with error %d', [WSAGetLastError]) );
        exit;
      end;

      // Create per I/O socket information structure to associate with the
      // WSARecv call below.

      PerIoData := LPPER_IO_OPERATION_DATA(GlobalAlloc(GPTR, sizeof(PER_IO_OPERATION_DATA)));
      if (PerIoData = nil) then
      begin
        WriteLn( Format('GlobalAlloc() failed with error %d', [WSAGetLastError]) );
        exit;
      end;
      CreateIoCompletionPort(PerHandleData.Socket, completionPort, DWORD(PerHandleData), 0);

      ZeroMemory( @PerIoData.Overlapped, sizeof(OVERLAPPED));
      PerIoData.dwFlags := 0;
      PerIoData.BytesSEND := 0;
      PerIoData.BytesRECV := 0;
      PerIoData.DataBuf.len := DATA_BUFSIZE;
      PerIoData.DataBuf.buf := @PerIoData.Buffer;

      if (WSARecv(Accept, @(PerIoData.DataBuf), 1, PerIoData.BytesRECV, PerIoData.dwFlags,
         @(PerIoData.Overlapped), nil) = SOCKET_ERROR) then
      begin
         if (WSAGetLastError() <> ERROR_IO_PENDING) then
         begin
           WriteLn( Format('WSARecv() failed with error %d', [WSAGetLastError]) );
           exit;
         end
      end;

    end;

end;

begin
  ServerStar(6000);
end.