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