网上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(@Wnd