Delphi最简化异步选择TCP服务器

网上Delphi的Socket服务器优良代码，实在少见，索性写个简化的异步Socket服务器，虽然代码较少，但却该有的都有了，使用的是异步选择WSAAsyncSelect，减少了编写线程的繁琐。可能会问，性能如何？当然使用窗体消息通知，占用的是主线程，侦听、发送、多个客户端的接收都一个线程，大量数据时，性能当然是差强人意的，编写这个代码目的也不在于此。但是在实际的项目中，大数据量的情况也不多，以下是代码：(Delphi7编译)

{
   最简化的消息异步Socket 异步选择WSAAsyncSelect, 没有64的限制
}

program SocketDemo;

{$APPTYPE CONSOLE}

uses Windows, WinSock;

const
  ListenPort : Word  = ;
  BufferSize : DWORD = ;

type
  TConn = ^TConnData;
  TConnData = record
    FSocket: TSocket;
    FAddrIn: TSockAddr;
    Buffer : PChar;
    BufLen : Integer;
  end;

procedure DoSocketData(Conn: TConn);
var S: string;
begin
  Writeln(Conn.Buffer);
  //这里插入业务处理代码
  S:= 'Server echo';
  send(Conn.FSocket, PChar(S)^, Length(S), );
end;

//--------- 以下不要修改 -----------
const
  wcName : PChar = 'THrWndClass';
  WM_SOCKET = {WM_USER}$ + ;        // 自定义消息

var
  AddrInLen: Integer = SizeOf(TSockAddr);

var FConns: array of TConn;

function GetFreeConn: Integer;
var i: Integer;
begin
  Result:= -;
  for i:= to High(FConns) do
  if FConns[i]=nil then begin
    Result:= i; Break;
  end;
  if Result< then begin
    Result:= Length(FConns); SetLength(FConns, Result+);
  end;
  FConns[Result]:= New(TConn);
  GetMem(FConns[Result].Buffer, BufferSize+);
  FConns[Result].BufLen:= BufferSize;
end;

function GetCltConn(S: TSocket): Integer;
var i: Integer;
begin
  for i:= to High(FConns) do
  if Assigned(FConns[i]) and (FConns[i].FSocket=S) then begin
    Result:= i;  Break;
  end;
end;

procedure FreeConn(S: TSocket);
var id: Integer;
var Conn: TConn;
begin
  id:= GetCltConn(S);
  Conn:= FConns[id];
  if not Assigned(Conn) then Exit;
  FreeMem(Conn.Buffer);
  CloseSocket(Conn.FSocket);
  Dispose(Conn);
  FConns[id]:= nil;
end;

function WndProc(wnd, msg, sock, wm: DWORD): Integer; stdcall;
var id, AddrLen: Integer;
begin
  Result:= DefWindowProc(wnd, msg, sock, wm);
  if (msg<>WM_SOCKET) or (wm=) then Exit;
  case LoWord(wm) of
    FD_ACCEPT:
      begin
        id:= GetFreeConn;
        with FConns[id]^ do begin
          FSocket:= Accept(sock, @FAddrIn, @AddrInLen);
          WSAAsyncSelect(FSocket, wnd, WM_SOCKET, FD_READ or FD_CLOSE);
        end;
      end;
    FD_READ:
      begin
        id:= GetCltConn(sock);
        with FConns[id]^ do begin
          BufLen:= Recv(sock, Buffer^, BufferSize, );
          if (BufLen<) or (BufLen>Buflen) then FreeConn(sock) else
          begin
            Buffer[BufLen]:= #;
            try DoSocketData(FConns[id]) except end;
          end;
        end;
      end;
    FD_CLOSE: FreeConn(sock);
  end;
end;

function MakeWndHandle(WndProc: Pointer; wcName: PChar): HWND;
var wc: TWndClass;
begin
  FillChar(wc, SizeOf(wc), );
  wc.lpfnWndProc  := WndProc;
  wc.hInstance    := HInstance;
  wc.lpszClassName:= wcName;
  Windows.RegisterClass(wc);
  Result:= CreateWindow(wcName,'HrWnd',,,,,,,,HInstance,nil);
end;

function SrvListen(Port: Word): Boolean;
var Wnd: HWND; S: TSocket; Addr: TSockAddrIn; WSAData: TWSAData;
begin
  WSAStartup($, WSAData);
  Addr.sin_family      := AF_INET;
  Addr.sin_port        := Swap(Port);
  Addr.sin_addr.S_addr := ;
  S:= Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
  Bind(S, Addr, AddrInLen);

  Wnd:= MakeWndHandle(@WndProc, wcName);
  WSAAsyncSelect(S, Wnd, WM_SOCKET, FD_ACCEPT or FD_CLOSE);
  //Writeln(SysErrorMessage(WSAGetLastError()), ' Wnd: ', Wnd);
  Listen(S, );
end;

procedure SysFina;
begin
  Windows.UnregisterClass(wcName, HInstance);
  WSACleanup;
end;

procedure Stay;
var msg: TMsg;
begin
  while GetMessage(msg, , , ) do begin
    TranslateMessage(msg);
    DispatchMessage (msg);
  end;
  PostQuitMessage();
end;

begin
  //if InitProc <> nil then TProcedure(InitProc);
  SrvListen(ListenPort);
  Stay;
  SysFina;
  Halt();
end.