網上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.
