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 = http://www.mamicode.com/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 begin101           BufLen:= Recv(sock, Buffer^, BufferSize, 0);102           if (BufLen<0) or (BufLen>Buflen) then FreeConn(sock) else103           begin104             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 begin116   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 begin127   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 begin142   Windows.UnregisterClass(wcName, HInstance);143   WSACleanup;144 end;145 146 procedure Stay;147 var msg: TMsg;148 begin149   while GetMessage(msg, 0, 0, 0) do begin150     TranslateMessage(msg);151     DispatchMessage (msg);152   end;153   PostQuitMessage(0);154 end;155 156 begin157   //if InitProc <> nil then TProcedure(InitProc);158   SrvListen(ListenPort);159   Stay;160   SysFina;161   Halt(0);162 end.