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

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

  1 {
  2    最简化的消息异步Socket 异步选择WSAAsyncSelect, 没有64的限制
  3 }
  4
  5 program SocketDemo;
  6
  7 {$APPTYPE CONSOLE}
  8
  9 uses Windows, WinSock;
 10
 11 const
 12   ListenPort : Word  = 12345;
 13   BufferSize : DWORD = 1024;
 14
 15 type
 16   TConn = ^TConnData;
 17   TConnData = record
 18     FSocket: TSocket;
 19     FAddrIn: TSockAddr;
 20     Buffer : PChar;
 21     BufLen : Integer;
 22   end;
 23
 24 procedure DoSocketData(Conn: TConn);
 25 var S: string;
 26 begin
 27   Writeln(Conn.Buffer);
 28   //这里插入业务处理代码
 29   S:= ‘Server echo‘;
 30   send(Conn.FSocket, PChar(S)^, Length(S), 0);
 31 end;
 32
 33
 34
 35 //--------- 以下不要修改 -----------
 36 const
 37   wcName : PChar = ‘THrWndClass‘;
 38   WM_SOCKET = {WM_USER}$0400 + 101;        // 自定义消息
 39
 40 var
 41   AddrInLen: Integer = SizeOf(TSockAddr);
 42
 43 var FConns: array of TConn;
 44
 45 function GetFreeConn: Integer;
 46 var i: Integer;
 47 begin
 48   Result:= -1;
 49   for i:=0 to High(FConns) do
 50   if FConns[i]=nil then begin
 51     Result:= i; Break;
 52   end;
 53   if Result<0 then begin
 54     Result:= Length(FConns); SetLength(FConns, Result+1);
 55   end;
 56   FConns[Result]:= New(TConn);
 57   GetMem(FConns[Result].Buffer, BufferSize+1);
 58   FConns[Result].BufLen:= BufferSize;
 59 end;
 60
 61 function GetCltConn(S: TSocket): Integer;
 62 var i: Integer;
 63 begin
 64   for i:=0 to High(FConns) do
 65   if Assigned(FConns[i]) and (FConns[i].FSocket=S) then begin
 66     Result:= i;  Break;
 67   end;
 68 end;
 69
 70 procedure FreeConn(S: TSocket);
 71 var id: Integer;
 72 var Conn: TConn;
 73 begin
 74   id:= GetCltConn(S);
 75   Conn:= FConns[id];
 76   if not Assigned(Conn) then Exit;
 77   FreeMem(Conn.Buffer);
 78   CloseSocket(Conn.FSocket);
 79   Dispose(Conn);
 80   FConns[id]:= nil;
 81 end;
 82
 83 function WndProc(wnd, msg, sock, wm: DWORD): Integer; stdcall;
 84 var id, AddrLen: Integer;
 85 begin
 86   Result:= DefWindowProc(wnd, msg, sock, wm);
 87   if (msg<>WM_SOCKET) or (wm=0) then Exit;
 88   case LoWord(wm) of
 89     FD_ACCEPT:
 90       begin
 91         id:= GetFreeConn;
 92         with FConns[id]^ do begin
 93           FSocket:= Accept(sock, @FAddrIn, @AddrInLen);
 94           WSAAsyncSelect(FSocket, wnd, WM_SOCKET, FD_READ or FD_CLOSE);
 95         end;
 96       end;
 97     FD_READ:
 98       begin
 99         id:= GetCltConn(sock);
100         with FConns[id]^ do begin
101           BufLen:= Recv(sock, Buffer^, BufferSize, 0);
102           if (BufLen<0) or (BufLen>Buflen) then FreeConn(sock) else
103           begin
104             Buffer[BufLen]:= #0;
105             try DoSocketData(FConns[id]) except end;
106           end;
107         end;
108       end;
109     FD_CLOSE: FreeConn(sock);
110   end;
111 end;
112
113 function MakeWndHandle(WndProc: Pointer; wcName: PChar): HWND;
114 var wc: TWndClass;
115 begin
116   FillChar(wc, SizeOf(wc), 0);
117   wc.lpfnWndProc  := WndProc;
118   wc.hInstance    := HInstance;
119   wc.lpszClassName:= wcName;
120   Windows.RegisterClass(wc);
121   Result:= CreateWindow(wcName,‘HrWnd‘,0,0,0,0,0,0,0,HInstance,nil);
122 end;
123
124 function SrvListen(Port: Word): Boolean;
125 var Wnd: HWND; S: TSocket; Addr: TSockAddrIn; WSAData: TWSAData;
126 begin
127   WSAStartup($0202, WSAData);
128   Addr.sin_family      := AF_INET;
129   Addr.sin_port        := Swap(Port);
130   Addr.sin_addr.S_addr := 0;
131   S:= Socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
132   Bind(S, Addr, AddrInLen);
133
134   Wnd:= MakeWndHandle(@WndProc, wcName);
135   WSAAsyncSelect(S, Wnd, WM_SOCKET, FD_ACCEPT or FD_CLOSE);
136   //Writeln(SysErrorMessage(WSAGetLastError()), ‘ Wnd: ‘, Wnd);
137   Listen(S, 5);
138 end;
139
140 procedure SysFina;
141 begin
142   Windows.UnregisterClass(wcName, HInstance);
143   WSACleanup;
144 end;
145
146 procedure Stay;
147 var msg: TMsg;
148 begin
149   while GetMessage(msg, 0, 0, 0) do begin
150     TranslateMessage(msg);
151     DispatchMessage (msg);
152   end;
153   PostQuitMessage(0);
154 end;
155
156 begin
157   //if InitProc <> nil then TProcedure(InitProc);
158   SrvListen(ListenPort);
159   Stay;
160   SysFina;
161   Halt(0);
162 end.