高性能的socket通讯服务器（完成端口模型--IOCP）
很多人费尽心思，都没有找到一个完美的 I/O CP 例程，甚至跟人于误解，先将本人编写的例程公布出来，希望对那些苦苦寻觅的人带来收获。本例程可以作为初学者的学习之用，亦可以作为大型服务程序的通讯模块。其处理速度可以说，优化到了极点。如果理解了本例程的精髓，加上一个高效的通讯协议，你完全可以用它来构建一个高性能的通讯服务器。 在公布代码前，先谈谈I/O CP。对I/O CP的函数不多做说明了，网上很多，都一样。在此本人仅说一些技术上要注意的问题。 一、如何管理内存 1、IO数据缓冲管理 动态分配内存，是一种灵活的方式。但对于系统资源浪费是巨大的。因此本人采用的是预先分配服务器最大需要的内存，用链表来管理。任何时候分配交还都不需要遍历，仅需要互斥而已。 更巧妙的是，将IO发送信息和内存块有机的结合在一起，减少了链表的管理工作。 //IO操作标志 TIOFlag = (IO_ACCEPT, IO_READ, IO_WRITE); //IO操作信息 PIOInfo =^ TIOInfo; TIOInfo = packed record Overlapped: TOverlapped; //重叠结构 DataBuf: TWSABUF; //IO数据信息 Socket: TSocket; Flag: TIOFlag; TickCountSend: DWord; Next: PIOInfo; Prior: PIOInfo; end; PUNode =^ TUNode; TUNode = record Next: Pointer; end; PIOMem =^ TIOMem; TIOMem = packed record IOInfo: TIOInfo; Data: array[1..IO_MEM_SIZE] of Byte; //申请内存的时候，返回的是Data的地址 end; 2、链路数据管理 采用双向链表结构，减少删除节点时遍历消耗的时间 //每个连接的信息 PLink =^ TLink; TLink = record Socket: TSocket; RemoteIP: string[30]; RemotePort: DWord; //最后收到数据时的系统节拍 TickCountActive: DWord; //处理该连接的当前线程的信息 Worker: PWorker; Data: Pointer; //应用层可以设置这个成员，当OnReceive的时候，就不要每次遍历每个连接对应的数据区了 Section: TRTLCriticalSection; Next: PLink; Prior: PLink; end; 二、如何管理线程 每个工作线程创建的时候，调用：OnWorkerThreadCreateEvt，该函数可以返回这个线程对应的信息，比如为该线程创建的数据库连接控件或对应的类等，在OnReceive的可以从Link的Worker访问该成员Worker^.Data。 //工作线程信息 PWorker =^ TWorker; TWorker = record ID: THandle; CompletionPort: THandle; Data: Pointer; //调用OnWorkerThreadCreateEvt返回的值 //用于反应工作情况的数据 TickCountLong, TickCountActive: DWord; ExecCount: Integer; //线程完成后设置 Finished: THandle; Next: PWorker; end; 同理，服务线程也是具有一样的特点。相见源码。 关于线程同步，一直是众多程序头疼的问题。在本例程中，尽量避免了过多的互斥，并有效地防止了死锁现象。用RTLCriticalSection，稍微不注意，就会造成死锁的灾难。哪怕是两行代码的差别，对多线程而言都是灾难的。在本例程中，对数据同步需要操作的是在维护链路链表方面上。服务线程需要计算哪个连接空闲超时了，工作线程需要处理断线情况，应用层主动发送数据时需要对该链路独占，否则一个在发送，一个在处理断线故障，就会发送冲突，导致灾难后果。 在本人的压力测试中，已经有效的解决了这个问题，应用层部分不需要做什么同步工作，可以安心的收发数据了。同时每个线程都支持了数据库连接。 三、到底要创建多少个工作线程合适 很多文章说，有N个CPU就创建N个线程，也有说N*2+2。最不喜欢说话不负责任的人了，本例程可以让刚入门 I/O CP 的人对它有更深入的了解。 例程测试结果： 四、该不该使用类 有人说，抛弃一切类，对于服务器而言，会为类付出很多代价，从我的观点看，为类付出代价的，主要是动态创建的原因。其实，类成员访问和结构成员访问一样，需要相对地址。如果都是预先创建的，两者没有多大的差别。本例程采用裸奔函数的方式，当然在应用层可以采用类来管理，很难想象，如果没有没有类，需要多做多少工作。 五、缺点 不能发大数据包，只能发不超过固定数的数据包。但对于小数据报而言，它将是优秀的。 时间原因，不能做太多的解释和对代码做太多的注释，需要例程源码的可以和本人联系，免费提供。ＱＱ：４８０９２７８８ 例程源码： http://d.download.csdn.net/down/1546336/guestcode 完成端口通讯服务模块源码： {****************************************************************************** * UCode 系列组件、控件 * * 作者：卢益贵 2003～2009 * * 版权所有 任何未经授权的使用和销售，均保留追究法律责任的权力 * * * * UCode 系列由XCtrls－YCtrls－ICtrls－NCode系列演变而来 * * QQ:48092788 luyigui.blog.gxsky.com * ******************************************************************************} {****************************************************************************** 完成端口模型的socket服务器 ******************************************************************************} unit UTcpServer; interface uses Windows, Classes, UClasses, UWinSock2; const //每个IO缓冲区的大小 IO_MEM_SIZE = 2048; //内存要足够用,可视情况设置 IO_MEM_MAX_COUNT = 1000 * 10; //最大连接数 SOCK_MAX_COUNT = 3000; //连接空闲实现,超过这个时间未收到客户端数据则关闭 SOCK_IDLE_OVERTIME = 60; type //工作线程信息 PWorker =^ TWorker; TWorker = record ID: THandle; CompletionPort: THandle; Data: Pointer; //用于反应工作情况的数据 TickCountLong, TickCountActive: DWord; ExecCount: Integer; //线程完成后设置 Finished: THandle; Next: PWorker; end; //每个连接的信息 PLink =^ TLink; TLink = record Socket: TSocket; RemoteIP: string[30]; RemotePort: DWord; //最后收到数据时的系统节拍 TickCountActive: DWord; //处理该连接的当前线程的信息 Worker: PWorker; Data: Pointer; Section: TRTLCriticalSection; Next: PLink; Prior: PLink; end; TOnLinkIdleOvertimeEvt = procedure(Link: PLink); TOnDisconnectEvt = procedure(Link: PLink); TOnReceiveEvt = function(Link: PLink; Buf: PByte; Len: Integer): Boolean; TOnThreadCreateEvt = function(IsWorkerThread: Boolean): Pointer; //取得链路链表使用情况X% function GetLinkUse(): real; //链路链表所占内存 function GetLinkSize(): Integer; //当前链路数 function GetLinkCount(): Integer; //空闲链路数 function GetLinkFree(): Integer; //IO内存使用情况 function GetIOMemUse(): Real; //IO内存链表占内存数 function GetIOMemSize(): Integer; //IO内存空闲数 function GetIOMemFree(): Integer; //交还一个IO内存 procedure FreeIOMem(Mem: Pointer); //获取一个IO内存区 function GetIOMem(): Pointer; //获取工作线程的工作情况 function GetWorkerExecInfo(Index: Integer; var TickCount: DWord): Integer; //获取工作线程的ID function GetWorkerID(Index: Integer): Integer; //获取工作线程数量 function GetWorkerCount(): Integer; //打开一个IP端口,并监听 function StartTcpServer(RemoteIP: String; RemotePort: DWord): Boolean; //停止并关闭一个IP端口 function StopTcpServer(): Boolean; //设置响应事件的函数指针,在StartTcpServer之前调用 procedure SetEventProc(OnReceive: TOnReceiveEvt; OnDisconnect: TOnDisconnectEvt; OnLinkIdleOvertime: TOnLinkIdleOvertimeEvt; OnServerThreadCreate: TOnThreadCreateEvt; OnWorkerThreadCreate: TOnThreadCreateEvt); //写日志文件 procedure WriteLog(Log: String); function PostRecv(Link: PLink; IOMem: Pointer): Boolean; //抛出一个发送事件 function PostSend(Link: PLink; IOMem: Pointer; Len: Integer): Boolean; //广播数据到所有的链路对方 procedure PostBroadcast(Buf: PByte; Len: Integer); //当前是否打开 function IsTcpServerActive(): Boolean; //获取服务线程最后一次工作所占的时间(MS) function GetServerExecLong(): DWord; //获取服务线程工作次数 function GetServerExecCount(): Integer; //获取本地或对外IP地址 function GetLocalIP(IsIntnetIP: Boolean): String; implementation uses IniFiles, SysUtils, ActiveX; var ExePath: String = ''; const HEAP_NO_SERIALIZE = 1; {非互斥, 此标记可允许多个线程同时访问此堆} HEAP_GENERATE_EXCEPTIONS = 4; {当建立堆出错时, 此标记可激发一个异常并返回异常标识} HEAP_ZERO_MEMORY = 8; {把分配的内存初始化为 0} HEAP_REALLOC_IN_PLACE_ONLY = 16; {此标记不允许改变原来的内存位置} STATUS_ACCESS_VIOLATION = DWORD($C0000005); {参数错误} STATUS_NO_MEMORY = DWORD($C0000017); {内存不足} {=============================================================================== IO内存管理 ================================================================================} type //IO操作标志 TIOFlag = (IO_ACCEPT, IO_READ, IO_WRITE); //IO操作信息 PIOInfo =^ TIOInfo; TIOInfo = packed record Overlapped: TOverlapped; //重叠结构 DataBuf: TWSABUF; //IO数据信息 Socket: TSocket; Flag: TIOFlag; TickCountSend: DWord; Next: PIOInfo; Prior: PIOInfo; end; PUNode =^ TUNode; TUNode = record Next: Pointer; end; PIOMem =^ TIOMem; TIOMem = packed record IOInfo: TIOInfo; Data: array[1..IO_MEM_SIZE] of Byte; end; var IOMemHead: PIOMem = nil; IOMemLast: PIOMem = nil; IOMemUse: Integer = 0; IOMemSec: TRTLCriticalSection; IOMemList: array[1..IO_MEM_MAX_COUNT] of Pointer; function GetIOMem(): Pointer; begin //内存要足够用，如果不够，即使是动态分配，神仙也救不了 EnterCriticalSection(IOMemSec); try try Result := @(IOMemHead^.Data); IOMemHead := PUNode(IOMemHead)^.Next; IOMemUse := IOMemUse + 1; except Result := nil; WriteLog('GetIOMem: error'); end; finally LeaveCriticalSection(IOMemSec); end; end; procedure FreeIOMem(Mem: Pointer); begin EnterCriticalSection(IOMemSec); try try Mem := Pointer(Integer(Mem) - sizeof(TIOInfo)); PUNode(Mem).Next := nil; PUNode(IOMemLast)^.Next := Mem; IOMemLast := Mem; IOMemUse := IOMemUse - 1; except WriteLog('FreeIOMem: error'); end; finally LeaveCriticalSection(IOMemSec); end; end; procedure IniIOMem(); var i: Integer; Heap: THandle; begin InitializeCriticalSection(IOMemSec); IOMemHead := HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(TIOMem)); IOMemLast := IOMemHead; IOMemList[1] := IOMemHead; Heap := GetProcessHeap(); for i := 2 to IO_MEM_MAX_COUNT do begin PUNode(IOMemLast)^.Next := HeapAlloc(Heap, HEAP_ZERO_MEMORY, sizeof(TIOMem)); IOMemList[i] := PUNode(IOMemLast)^.Next; IOMemLast := PUNode(IOMemLast)^.Next; end; PUNode(IOMemLast).Next := nil; end; function GetIOMemFree(): Integer; var IOMems: PUNode; begin EnterCriticalSection(IOMemSec); Result := 0; IOMems := PUNode(IOMemHead); while IOMems <> nil do begin Result := Result + 1; IOMems := IOMems^.Next; end; LeaveCriticalSection(IOMemSec); end; procedure DeleteIOMem(); var i: Integer; Heap: THandle; begin Heap := GetProcessHeap(); for i := 1 to IO_MEM_MAX_COUNT do HeapFree(Heap, HEAP_NO_SERIALIZE, IOMemList[i]); IOMemUse := 0; DeleteCriticalSection(IOMemSec); end; function GetIOMemSize(): Integer; begin Result := IO_MEM_MAX_COUNT * sizeof(TIOMem); end; function GetIOMemUse(): Real; begin Result := (IOMemUse * 100) / IO_MEM_MAX_COUNT; end; {=============================================================================== Socket链路管理 ================================================================================} procedure OnLinkIdleOvertimeDef(Link: PLink); begin end; var LinkHead: PLink = nil; LinkLast: PLink = nil; LinkUse: Integer = 0; LinkCount: Integer = 0; LinkSec: TRTLCriticalSection; LinkList: array[1..SOCK_MAX_COUNT] of PLink; OnLinkIdleOvertimeEvt: TOnLinkIdleOvertimeEvt = OnLinkIdleOvertimeDef; LinksHead: PLink = nil; LinksLast: PLink = nil; function GetLinkFree(): Integer; var Links: PLink; begin EnterCriticalSection(LinkSec); Result := 0; Links := LinkHead; while Links <> nil do begin Result := Result + 1; Links := Links^.Next; end; LeaveCriticalSection(LinkSec); end; function GetLink(): PLink; begin try //内存要足够用，如果不够，即使是动态分配，神仙也救不了 Result := LinkHead; LinkHead := LinkHead^.Next; LinkUse := LinkUse + 1; LinkCount := LinkCount + 1; if LinksHead = nil then begin LinksHead := Result; LinksHead^.Next := nil; LinksHead^.Prior := nil; LinksLast := LinksHead; end else begin Result^.Prior := LinksLast; LinksLast^.Next := Result; LinksLast := Result; LinksLast^.Next := nil; end; with Result^ do begin Socket := INVALID_SOCKET; RemoteIP := ''; RemotePort := 0; TickCountActive := GetTickCount(); Worker := nil; Data := nil; end; except Result := nil; WriteLog('GetLink: error'); end; end; procedure FreeLink(Link: PLink); begin try with Link^ do begin Link^.Worker := nil; if Link = LinksHead then begin LinksHead := Next; if LinksLast = Link then LinksLast := LinksHead else LinksHead^.Prior := nil; end else begin Prior^.Next := Next; if Next <> nil then Next^.Prior := Prior; if Link = LinksLast then LinksLast := Prior; end; Next := nil; LinkLast^.Next := Link; LinkLast := Link; LinkUse := LinkUse - 1; LinkCount := LinkCount - 1; end; except WriteLog('FreeLink: error'); end; end; procedure CloseLink(Link: PLink); begin EnterCriticalSection(LinkSec); with Link^ do begin EnterCriticalSection(Section); if Socket <> INVALID_SOCKET then begin try CloseSocket(Socket); except WriteLog('CloseSocket: error'); end; Socket := INVALID_SOCKET; FreeLink(Link); end; LeaveCriticalSection(Link^.Section); end; LeaveCriticalSection(LinkSec); end; procedure CheckLinkLinkIdleOvertime(Data: Pointer); var TickCount: DWord; Long: Integer; Link: PLink; begin EnterCriticalSection(LinkSec); try TickCount := GetTickCount(); Link := LinksHead; while Link <> nil do with Link^ do begin EnterCriticalSection(Section); if Socket <> INVALID_SOCKET then begin if TickCount > TickCountActive then Long := TickCount - TickCountActive else Long := $FFFFFFFF - TickCountActive + TickCount; if SOCK_IDLE_OVERTIME * 1000 < Long then begin try CloseSocket(Socket); except WriteLog('CloseSocket overtime: error'); end; Socket := INVALID_SOCKET; Worker := Data; try OnLinkIdleOvertimeEvt(Link); except WriteLog('OnLinkIdleOvertimeEvt: error'); end; Worker := nil; FreeLink(Link); LeaveCriticalSection(Section); break; end; end else begin LeaveCriticalSection(Section); break; end; LeaveCriticalSection(Section); Link := Link^.Next; end; except WriteLog('CheckLinkLinkIdleOvertime: error'); end; LeaveCriticalSection(LinkSec); end; procedure IniLink(); var i: Integer; Heap: THandle; begin InitializeCriticalSection(LinkSec); LinkHead := HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(TLink)); InitializeCriticalSection(LinkHead^.Section); LinkLast := LinkHead; LinkList[1] := LinkHead; Heap := GetProcessHeap(); for i := 2 to SOCK_MAX_COUNT do begin LinkLast^.Next := HeapAlloc(Heap, HEAP_ZERO_MEMORY, sizeof(TLink)); LinkLast := LinkLast^.Next; InitializeCriticalSection(LinkLast^.Section); LinkList[i] := LinkLast; end; LinkLast.Next := nil; end; procedure DeleteLink(); var i: Integer; Heap: THandle; begin Heap := GetProcessHeap(); for i := 1 to SOCK_MAX_COUNT do begin DeleteCriticalSection(LinkList[i]^.Section); HeapFree(Heap, HEAP_NO_SERIALIZE, LinkList[i]); end; LinkUse := 0; LinkCount := 0; LinksHead := nil; LinksLast := nil; DeleteCriticalSection(LinkSec); end; function GetLinkSize(): Integer; begin Result := SOCK_MAX_COUNT * sizeof(TLink); end; function GetLinkUse(): real; begin Result := (LinkUse * 100) / SOCK_MAX_COUNT; end; function GetLinkCount(): Integer; begin Result := LinkCount; end; {=============================================================================== 工作线程 ================================================================================} procedure OnDisconnectDef(Link: PLink); begin end; function OnReceiveDef(Link: PLink; Buf: PByte; Len: Integer): Boolean; var IOMem: Pointer; i: Integer; begin Result := True; IOMem := GetIOMem(); CopyMemory(IOMem, Buf, Len); i := 1000000; while i > 0 do i := i - 1; if not PostSend(Link, IOMem, Len) then FreeIOMem(IOMem); end; function OnWorkerThreadCreateDef(IsWorkerThread: Boolean): Pointer; begin Result := nil; end; var WorkerHead: PWorker = nil; WorkerCount: Integer = 0; OnDisconnectEvt: TOnDisconnectEvt = OnDisconnectDef; OnReceiveEvt: TOnReceiveEvt = OnReceiveDef; OnWorkerThreadCreateEvt: TOnThreadCreateEvt = OnWorkerThreadCreateDef; function GetWorkerCount(): Integer; begin Result := WorkerCount; end; function WorkerThread(Worker: PWorker): DWORD; stdcall; var Link: PLink; IOInfo: PIOInfo; Bytes: DWord; CompletionPort: THandle; begin Result := 0; CompletionPort := Worker^.CompletionPort; with Worker^ do begin TickCountActive := GetTickCount(); TickCountLong := 0; ExecCount := 0; end; WriteLog(Format('Worker thread:%d begin', [Worker^.ID])); CoInitialize(nil); try while True do begin try with Worker^ do TickCountLong := TickCountLong + GetTickCount() - TickCountActive; if GetQueuedCompletionStatus(CompletionPort, Bytes, DWORD(Link), POverlapped(IOInfo), INFINITE) = False then begin if (Link <> nil) then with Link^ do begin EnterCriticalSection(LinkSec); EnterCriticalSection(Section); if Link^.Socket <> INVALID_SOCKET then begin try CloseSocket(Socket); except WriteLog(Format('CloseSocket1:%d error', [Worker^.ID])); end; Socket := INVALID_SOCKET; Link^.Worker := Worker; try OnDisconnectEvt(Link); except WriteLog(Format('OnDisconnectEvt1:%d error', [Worker^.ID])); end; Link^.Worker := nil; FreeLink(Link); end; LeaveCriticalSection(Section); LeaveCriticalSection(LinkSec); end; if IOInfo <> nil then FreeIOMem(IOInfo^.DataBuf.buf); WriteLog(Format('GetQueuedCompletionStatus:%d error', [Worker^.ID])); continue; end; with Worker^ do begin TickCountActive := GetTickCount(); ExecCount := ExecCount + 1; end; if (Bytes = 0) then begin if (Link <> nil) then with Link^ do begin EnterCriticalSection(LinkSec); EnterCriticalSection(Section); if Link^.Socket <> INVALID_SOCKET then begin try CloseSocket(Socket); except WriteLog(Format('CloseSocket2:%d error', [Worker^.ID])); end; Socket := INVALID_SOCKET; Link^.Worker := Worker; try OnDisconnectEvt(Link); except WriteLog(Format('OnDisconnectEvt2:%d error', [Worker^.ID])); end; Link^.Worker := nil; FreeLink(Link); end; LeaveCriticalSection(Section); LeaveCriticalSection(LinkSec); if IOInfo.Flag = IO_WRITE then FreeIOMem(IOInfo^.DataBuf.buf) else FreeIOMem(IOInfo^.DataBuf.buf); continue; end else begin if IOInfo <> nil then FreeIOMem(IOInfo^.DataBuf.buf); break; end; end; if IOInfo.Flag = IO_WRITE then begin FreeIOMem(IOInfo^.DataBuf.buf); continue; end; {if IOInfo.Flag = IO_ACCEPT then begin ...... continue; end;} with Link^, IOInfo^.DataBuf do begin Link^.Worker := Worker; try OnReceiveEvt(Link, buf, Bytes); except WriteLog(Format('OnReceiveEvt:%d error', [Worker^.ID])); end; Link^.Worker := nil; TickCountActive := GetTickCount(); if not PostRecv(Link, buf) then begin EnterCriticalSection(LinkSec); EnterCriticalSection(Section); if Socket <> INVALID_SOCKET then begin try CloseSocket(Socket); except WriteLog(Format('CloseSocket3:%d error', [Worker^.ID])); end; Socket := INVALID_SOCKET; Link^.Worker := Worker; try OnDisconnectEvt(Link); except WriteLog(Format('OnDisconnectEvt3:%d error', [Worker^.ID])); end; Link^.Worker := nil; FreeLink(Link); end; LeaveCriticalSection(Section); LeaveCriticalSection(LinkSec); FreeIOMem(buf); end; end; except WriteLog(Format('Worker thread:%d error', [Worker^.ID])); end; end; finally CoUninitialize(); WriteLog(Format('Worker thread:%d end', [Worker^.ID])); SetEvent(Worker^.Finished); end; end; procedure CreateWorkerThread(CompletionPort: THandle); var Worker, Workers: PWorker; i: Integer; SystemInfo: TSystemInfo; ThreadHandle: THandle; begin GetSystemInfo(SystemInfo); Workers := nil; WorkerCount := (SystemInfo.dwNumberOfProcessors * 2 + 2); for i := 1 to WorkerCount do begin Worker := HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(TWorker)); if Workers = nil then begin Workers := Worker; WorkerHead := Workers; end else begin Workers^.Next := Worker; Workers := Worker; end; Worker^.CompletionPort := CompletionPort; Worker^.Data := OnWorkerThreadCreateEvt(False); Worker^.Finished := CreateEvent(nil, True, False, nil); ThreadHandle := CreateThread(nil, 0, @WorkerThread, Worker, 0, Worker^.ID); if ThreadHandle <> 0 then CloseHandle(ThreadHandle); end; Workers^.Next := nil; end; procedure DestroyWorkerThread(); var Worker, Save: PWorker; begin WorkerCount := 0; Worker := WorkerHead; while Worker <> nil do begin PostQueuedCompletionStatus(Worker^.CompletionPort, 0, 0, nil); Worker := Worker^.Next; end; Worker := WorkerHead; while Worker <> nil do begin with Worker^ do begin WaitForSingleObject(Worker^.Finished, INFINITE); CloseHandle(Worker^.Finished); Save := Worker^.Next; end; HeapFree(GetProcessHeap(), HEAP_NO_SERIALIZE, Worker); Worker := Save; end; end; function GetWorkerExecInfo(Index: Integer; var TickCount: DWord): Integer; var Worker: PWorker; Count: Integer; begin Worker := WorkerHead; Count := 0; Result := 0; while Worker <> nil do with Worker^ do begin Count := Count + 1; if Count = Index then begin TickCount := TickCountLong; TickCountLong := 0; Result := Worker^.ExecCount; break; end; Worker := Worker^.Next; end; end; function GetWorkerID(Index: Integer): Integer; var Worker: PWorker; Count: Integer; begin Worker := WorkerHead; Count := 0; while Worker <> nil do begin Count := Count + 1; if Count = Index then begin Count := Worker^.ID; break; end; Worker := Worker^.Next; end; Result := Count; end; {=============================================================================== 服务线程 ================================================================================} function OnServerThreadCreateDef(IsWorkerThread: Boolean): Pointer; begin Result := nil; end; var ListenSocket: TSocket = INVALID_SOCKET; SocketEvent: THandle = WSA_INVALID_EVENT; CompletionPort: THandle = 0; Terminated: Boolean = False; ServerThreadID: DWORD = 0; ServerExecCount: Integer = 0; ServerExecLong: DWord = 0; OnServerThreadCreateEvt: TOnThreadCreateEvt = OnServerThreadCreateDef; ServerFinished: THandle; function GetServerExecCount(): Integer; begin Result := ServerExecCount; end; function GetServerExecLong(): DWord; begin Result := ServerExecLong; ServerExecLong := 0; end; function ServerThread(Param: Pointer): DWORD; stdcall; var AcceptSocket: TSocket; Addr: TSockAddrIn; Len: Integer; Link: PLink; IOMem: Pointer; bNodelay: Boolean; TickCount: DWord; WR: DWord; begin Result := 0; CoInitialize(nil); WriteLog('Server thread begin'); TickCount := GetTickCount(); try while not Terminated do begin try ServerExecLong := ServerExecLong + (GetTickCount() - TickCount); WR := WaitForSingleObject(SocketEvent, 10000); ServerExecCount := ServerExecCount + 1; TickCount := GetTickCount(); if (WAIT_TIMEOUT = WR) then begin CheckLinkLinkIdleOvertime(Param); continue; end else if (WAIT_FAILED = WR) then begin continue; end else begin Len := SizeOf(TSockAddrIn); AcceptSocket := WSAAccept(ListenSocket, @Addr, @Len, nil, 0); if (AcceptSocket = INVALID_SOCKET) then continue; if LinkCount >= SOCK_MAX_COUNT then begin try CloseSocket(AcceptSocket); except WriteLog('Link count over'); end; continue; end; bNodelay := True; if SetSockOpt(AcceptSocket, IPPROTO_TCP, TCP_NODELAY, PChar(@bNodelay), sizeof(bNodelay)) = SOCKET_ERROR then begin try CloseSocket(AcceptSocket); except WriteLog('SetSockOpt: error'); end; continue; end; EnterCriticalSection(LinkSec); Link := GetLink(); with Link^ do begin EnterCriticalSection(Section); RemoteIP := inet_ntoa(Addr.sin_addr); RemotePort := Addr.sin_port; TickCountActive := GetTickCount(); Socket := AcceptSocket; IOMem := GetIOMem(); if (CreateIoCompletionPort(AcceptSocket, CompletionPort, DWORD(Link), 0) = 0) or (not PostRecv(Link, IOMem)) then begin try CloseSocket(Socket); except WriteLog('CreateIoCompletionPort or PostRecv: error'); end; Socket := INVALID_SOCKET; FreeLink(Link); FreeIOMem(IOMem); end; LeaveCriticalSection(Section); end; LeaveCriticalSection(LinkSec); end; except WriteLog('Server thread error'); end; end; finally CoUninitialize(); WriteLog('Server thread end'); SetEvent(ServerFinished); end; end; function StartTcpServer(RemoteIP: String; RemotePort: DWord): Boolean; var NonBlock: Integer; bNodelay: Boolean; Addr: TSockAddrIn; ThreadHandle: THANDLE; begin Result := ListenSocket = INVALID_SOCKET; if not Result then exit; IniIOMem(); IniLink(); ListenSocket := WSASocket(AF_INET, SOCK_STREAM, 0, nil, 0, WSA_FLAG_OVERLAPPED); Result := ListenSocket <> INVALID_SOCKET; if not Result then begin DeleteLink(); DeleteIOMem(); exit; end; bNodelay := True; NonBlock := 1; Addr.sin_family := AF_INET; Addr.sin_addr.s_addr := inet_addr(PChar(RemoteIP)); Addr.sin_port := htons(RemotePort); Result := (SetSockOpt(ListenSocket, IPPROTO_TCP, TCP_NODELAY, PChar(@bNodelay), sizeof(bNodelay)) <> SOCKET_ERROR) and (ioctlsocket(ListenSocket, Integer(FIONBIO), NonBlock) <> SOCKET_ERROR) and (Bind(ListenSocket, @Addr, SizeOf(TSockAddrIn)) <> SOCKET_ERROR) and (Listen(ListenSocket, SOMAXCONN) <> SOCKET_ERROR); if not Result then begin ListenSocket := INVALID_SOCKET; DeleteLink(); DeleteIOMem(); exit; end; SocketEvent := CreateEvent(nil, FALSE, FALSE, nil); Result := (SocketEvent <> WSA_INVALID_EVENT); if (not Result) then begin CloseSocket(ListenSocket); ListenSocket := INVALID_SOCKET; DeleteLink(); DeleteIOMem(); exit; end; Result := (WSAEventSelect(ListenSocket, SocketEvent, FD_ACCEPT) <> SOCKET_ERROR); if not Result then begin CloseSocket(ListenSocket); ListenSocket := INVALID_SOCKET; WSACloseEvent(SocketEvent); SocketEvent := WSA_INVALID_EVENT; DeleteLink(); DeleteIOMem(); exit; end; CompletionPort := CreateIoCompletionPort(INVALID_HANDLE_value, 0, 0, 0); Result := CompletionPort <> 0; if not Result then begin CloseSocket(ListenSocket); ListenSocket := INVALID_SOCKET; WSACloseEvent(SocketEvent); SocketEvent := WSA_INVALID_EVENT; DeleteLink(); DeleteIOMem(); exit; end; WriteLog('Server Start'); CreateWorkerThread(CompletionPort); ServerFinished := CreateEvent(nil, True, False, nil); Result := ServerFinished <> 0; if not Result then begin CloseSocket(ListenSocket); ListenSocket := INVALID_SOCKET; WSACloseEvent(SocketEvent); SocketEvent := WSA_INVALID_EVENT; DeleteLink(); DeleteIOMem(); exit; end; Terminated := False; ThreadHandle := CreateThread(nil, 0, @ServerThread, OnServerThreadCreateEvt(False), 0, ServerThreadID); if (ThreadHandle = 0) then begin StopTcpServer(); exit; end; CloseHandle(ThreadHandle); end; function StopTcpServer(): Boolean; begin Result := ListenSocket <> INVALID_SOCKET; if not Result then exit; WriteLog('Server Stop'); Terminated := True; if ServerFinished <> 0 then begin WaitForSingleObject(ServerFinished, INFINITE); CloseHandle(ServerFinished); ServerFinished := 0; end; if SocketEvent <> 0 then WSACloseEvent(SocketEvent); SocketEvent := 0; DestroyWorkerThread(); if ListenSocket <> INVALID_SOCKET then CloseSocket(ListenSocket); ListenSocket := INVALID_SOCKET; if CompletionPort <> 0 then CloseHandle(CompletionPort); CompletionPort := 0; ServerExecCount := 0; ServerExecLong := 0; DeleteLink(); DeleteIOMem(); end; function GetLocalIP(IsIntnetIP: Boolean): String; type TaPInAddr = Array[0..10] of PInAddr; PaPInAddr = ^TaPInAddr; var phe: PHostEnt; pptr: PaPInAddr; Buffer: Array[0..63] of Char; I: Integer; begin Result := '0.0.0.0'; try GetHostName(Buffer, SizeOf(Buffer)); phe := GetHostByName(buffer); if phe = nil then Exit; pPtr := PaPInAddr(phe^.h_addr_list); if IsIntnetIP then begin I := 0; while pPtr^[I] <> nil do begin Result := inet_ntoa(pptr^[I]^); Inc(I); end; end else Result := inet_ntoa(pptr^[0]^); except end; end; procedure SetEventProc(OnReceive: TOnReceiveEvt; OnDisconnect: TOnDisconnectEvt; OnLinkIdleOvertime: TOnLinkIdleOvertimeEvt; OnServerThreadCreate: TOnThreadCreateEvt; OnWorkerThreadCreate: TOnThreadCreateEvt); begin OnReceiveEvt := OnReceive; OnDisconnectEvt := OnDisconnect; OnLinkIdleOvertimeEvt := OnLinkIdleOvertime; OnServerThreadCreateEvt := OnServerThreadCreate; OnWorkerThreadCreateEvt := OnWorkerThreadCreate; end; function PostRecv(Link: PLink; IOMem: Pointer): Boolean; var Flags: DWord; Bytes: DWord; IOInfo: PIOInfo; begin Result := Link^.Socket <> INVALID_SOCKET; if Result then try Flags := 0; Bytes := 0; IOInfo := PIOInfo(Integer(IOMem) - sizeof(TIOInfo)); with IOInfo^ do begin ZeroMemory(IOInfo, sizeof(TIOInfo)); DataBuf.buf := IOMem; DataBuf.len := IO_MEM_SIZE; Socket := Link^.Socket; Flag := IO_READ; Result := (WSARecv(Socket, @DataBuf, 1, @Bytes, @Flags, @Overlapped, nil) <> SOCKET_ERROR) or (WSAGetLastError() = ERROR_IO_PENDING); end; except Result := False; WriteLog('PostRecv: error'); end; end; function PostSend(Link: PLink; IOMem: Pointer; Len: Integer): Boolean; var Bytes: DWord; IOInfo: PIOInfo; begin Result := Link^.Socket <> INVALID_SOCKET; if Result then try Bytes := 0; IOInfo := PIOInfo(Integer(IOMem) - sizeof(TIOInfo)); with IOInfo^ do begin ZeroMemory(IOInfo, sizeof(TIOInfo)); DataBuf.buf := IOMem; DataBuf.len := Len; Socket := Link^.Socket; Flag := IO_WRITE; Result := (WSASend(Socket, @(DataBuf), 1, @Bytes, 0, @(Overlapped), nil) <> SOCKET_ERROR) or (WSAGetLastError() = ERROR_IO_PENDING); end; except Result := False; WriteLog('PostSend: error'); end; end; procedure PostBroadcast(Buf: PByte; Len: Integer); var IOMem: Pointer; Link: PLink; begin EnterCriticalSection(LinkSec); Link := LinksHead; while Link <> nil do with Link^ do begin if Socket <> INVALID_SOCKET then begin IOMem := GetIOMem(); CopyMemory(IOMem, Buf, Len); if not PostSend(Link, IOMem, Len) then FreeIOMem(IOMem); end; Link := Link^.Next; end; LeaveCriticalSection(LinkSec); end; function IsTcpServerActive(): Boolean; begin Result := ListenSocket <> INVALID_SOCKET; end; {=============================================================================== 日志管理 ================================================================================} var LogSec: TRTLCriticalSection; Inifile: TIniFile; LogCount: Integer = 0; LogName: String = ''; procedure WriteLog(Log: String); begin EnterCriticalSection(LogSec); try LogCount := LogCount + 1; IniFile.WriteString(LogName, 'Index' + IntToStr(LogCount), DateTimeToStr(Now()) + ':' + Log); finally LeaveCriticalSection(LogSec); end; end; {=============================================================================== 初始化Window Socket ================================================================================} var WSAData: TWSAData; procedure Startup; var ErrorCode: Integer; begin ErrorCode := WSAStartup( {$SK_blogItemTitle$} {$SK_ItemBody$} {$SK_blogDiary$}{$SK_blogItemLink$} {$SK_blogItemComm$} {$SK_blogItemQuote$} {$SK_blogItemVisit$} 01, WSAData); if ErrorCode <> 0 then WriteLog('Window Socket init Error!'); end; procedure Cleanup; var ErrorCode: Integer; begin ErrorCode := WSACleanup; if ErrorCode <> 0 then WriteLog('Window Socket cleanup error!'); end; function GetExePath(): String; var ModuleName: array[0..1024] of char; begin GetModuleFileName(MainInstance, ModuleName, SizeOf(ModuleName)); Result := ExtractFilePath(ModuleName); end; initialization LogName := DateTimeToStr(Now()); InitializeCriticalSection(LogSec); ExePath := GetExePath(); IniFile := TIniFile.Create(ExePath + 'Logs.Ini'); Startup(); finalization Cleanup(); DeleteCriticalSection(LogSec); IniFile.Destroy(); end. 主窗口单元源码： unit uMainTcpServerIOCP; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ComCtrls, UTcpServer, Sockets, Grids; type TfrmMainUTcpServerIOCP = class(TForm) Label1: TLabel; Label2: TLabel; edtIP: TEdit; edtPort: TEdit; btn: TButton; Timer1: TTimer; Label3: TLabel; lbIO: TLabel; Label5: TLabel; lbIOU: TLabel; Label7: TLabel; lbL: TLabel; Label9: TLabel; lbLU: TLabel; Label11: TLabel; lbLS: TLabel; Label13: TLabel; lbW: TLabel; Info: TStringGrid; Label4: TLabel; lbWC: TLabel; Label8: TLabel; lbWU: TLabel; Label12: TLabel; lbLF: TLabel; Label15: TLabel; lbLFL: TLabel; Label6: TLabel; lbIOF: TLabel; lbIOFL: TLabel; Label16: TLabel; Timer2: TTimer; procedure btnClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Timer2Timer(Sender: TObject); private { Private declarations } FTickCount: DWord; public { Public declarations } end; var frmMainUTcpServerIOCP: TfrmMainUTcpServerIOCP; implementation {$R *.dfm} { TfrmMainUTcpServerIOCP } procedure TfrmMainUTcpServerIOCP.btnClick(Sender: TObject); var i: Integer; C1: Integer; C2: DWord; DT: TDateTime; begin if btn.Caption = 'Open' then begin StartTcpServer(edtIP.Text, StrToInt(edtPort.Text)); if IsTcpServerActive() then begin FTickCount := GetTickCount(); Info.RowCount := GetWorkerCount() + 1; DT := Now(); for i := 1 to Info.RowCount - 1 do begin Info.Cells[0, i] := IntToStr(i); Info.Cells[1, i] := IntToStr(GetWorkerID(i)); C1 := GetWorkerExecInfo(i, C2); Info.Cells[2, i] := IntToStr(C1); Info.Cells[3, i] := '0'; Info.Cells[4, i] := IntToStr(C2); Info.Cells[5, i] := '0'; Info.Cells[6, i] := DateTimeToStr(DT); end; Timer1.Enabled := True; end; end else begin Timer1.Enabled := False; StopTcpServer(); end; if IsTcpServerActive() then btn.Caption := 'Close' else btn.Caption := 'Open'; end; procedure TfrmMainUTcpServerIOCP.FormCreate(Sender: TObject); begin edtIP.Text := GetLocalIP(False); Info.ColCount := 7; Info.RowCount := 2; Info.ColWidths[0] := 30; Info.ColWidths[1] := 30; Info.ColWidths[2] := 40; Info.ColWidths[3] := 40; Info.ColWidths[4] := 30; Info.ColWidths[5] := 40; Info.ColWidths[6] := 110; Info.Cells[0, 0] := '序号'; Info.Cells[1, 0] := 'ID'; Info.Cells[2, 0] := '计数'; Info.Cells[3, 0] := '次／S'; Info.Cells[4, 0] := '时长'; Info.Cells[5, 0] := '使用率'; Info.Cells[6, 0] := '时间'; end; procedure TfrmMainUTcpServerIOCP.Timer1Timer(Sender: TObject); var i: Integer; Count1, Count2, Count3, TC, TCC: DWord; begin if not IsTcpServerActive() then begin Timer1.Enabled := False; exit; end; TC := GetTickCount(); TCC := TC - FTickCount; if TCC = 0 then TCC := $FFFFFFFF; lbWC.Caption := IntToStr(GetServerExecCount()); lbWU.Caption := FloatToStrF(GetServerExecLong() / TCC * 100, ffFixed, 10, 3) + '%'; for i := 1 to Info.RowCount - 1 do begin Count1 := GetWorkerExecInfo(i, Count2); TC := GetTickCount(); TCC := TC - FTickCount; if TCC = 0 then TCC := $FFFFFFFF; Count3 := StrToInt(Info.Cells[2, i]); if Count1 <> Count3 then begin Info.Cells[2, i] := IntToStr(Count1); Info.Cells[3, i] := IntToStr(Count1 - Count3); Info.Cells[4, i] := IntToStr(Count2); Info.Cells[5, i] := FloatToStrF(Count2 / TCC * 100, ffFixed, 10, 1) + '%'; Info.Cells[6, i] := DateTimeToStr(Now()); end; end; FTickCount := TC; lbIO.Caption := IntToStr(GetIOMemSize()); lbIOU.Caption := FloatToStrF(GetIOMemUse(), ffFixed, 10, 3) + '%'; Count1 := GetIOMemFree(); lbIOF.Caption := IntToStr(Count1); lbIOFL.Caption := FloatToStrF(Count1 / IO_MEM_MAX_COUNT * 100, ffFixed, 10, 3) + '%'; lbW.Caption := IntToStr(GetWorkerCount()); lbL.Caption := IntToStr(GetLinkSize()); Count1 := GetLinkFree(); lbLF.Caption := IntToStr(Count1); lbLFL.Caption := FloatToStrF(Count1 / SOCK_MAX_COUNT * 100, ffFixed, 10, 3) + '%'; lbLU.Caption := FloatToStrF(GetLinkUse(), ffFixed, 10, 3) + '%'; lbLS.Caption := IntToStr(GetLinkCount()); end; procedure TfrmMainUTcpServerIOCP.FormDestroy(Sender: TObject); begin StopTcpServer(); end; procedure TfrmMainUTcpServerIOCP.Timer2Timer(Sender: TObject); begin if not IsTcpServerActive() then begin Timer1.Enabled := False; exit; end; PostBroadcast(PByte(PChar('这是来自服务器的数据!')), 21); end; end.