本文整理自网络,侵删。
网上Delphi的Socket服务器优良代码,实在少见,索性写个简化的异步Socket服务器,虽然代码较少,但却该有的都有了,使用的是异步选择WSAAsyncSelect,减少了编写线程的繁琐。可能会问,性能如何?当然使用窗体消息通知,占用的是主线程,侦听、发送、多个客户端的接收都一个线程,大量数据时,性能当然是差强人意的,编写这个代码目的也不在于此。但是在实际的项目中,大数据量的情况也不多,以下是代码:(Delphi7编译)
{ 最简化的消息异步Socket 异步选择WSAAsyncSelect, 没有64的限制}
program SocketDemo;
{$APPTYPE CONSOLE}
uses Windows, WinSock;
const ListenPort : Word = 12345; BufferSize : DWORD = 1024;
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), 0);end;
//--------- 以下不要修改 -----------const wcName : PChar = 'THrWndClass'; WM_SOCKET = {WM_USER}$0400 + 101; // 自定义消息
var AddrInLen: Integer = SizeOf(TSockAddr);
var FConns: array of TConn;
function GetFreeConn: Integer;var i: Integer;begin Result:= -1; for i:=0 to High(FConns) do if FConns[i]=nil then begin Result:= i; Break; end; if Result<0 then begin Result:= Length(FConns); SetLength(FConns, Result+1); end; FConns[Result]:= New(TConn); GetMem(FConns[Result].Buffer, BufferSize+1); FConns[Result].BufLen:= BufferSize;end;
function GetCltConn(S: TSocket): Integer;var i: Integer;begin for i:=0 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=0) 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, 0); if (BufLen<0) or (BufLen>Buflen) then FreeConn(sock) else begin Buffer[BufLen]:= #0; 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), 0); wc.lpfnWndProc := WndProc; wc.hInstance := HInstance; wc.lpszClassName:= wcName; Windows.RegisterClass(wc); Result:= CreateWindow(wcName,'HrWnd',0,0,0,0,0,0,0,HInstance,nil);end;
function SrvListen(Port: Word): Boolean;var Wnd: HWND; S: TSocket; Addr: TSockAddrIn; WSAData: TWSAData;begin WSAStartup($0202, WSAData); Addr.sin_family := AF_INET; Addr.sin_port := Swap(Port); Addr.sin_addr.S_addr := 0; 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, 5);end;
procedure SysFina;begin Windows.UnregisterClass(wcName, HInstance); WSACleanup;end;
procedure Stay;var msg: TMsg;begin while GetMessage(msg, 0, 0, 0) do begin TranslateMessage(msg); DispatchMessage (msg); end; PostQuitMessage(0);end;
begin //if InitProc <> nil then TProcedure(InitProc); SrvListen(ListenPort); Stay; SysFina; Halt(0);end.
相关阅读 >>
Delphi 如何通过代码控制打开键盘数字锁定numlock
Delphi xe5 android 使用system.zip单元释放资源文件
Delphi winapi: flashwindow - 闪烁窗口
更多相关阅读请进入《Delphi》频道 >>