源代码最先是barton大侠作品，太长就不贴了，csdn，delphibbs都有，也可查“封装完成端口的类及测试例子”，其中有完全测试例子，这是网上能找到的最全可用性最好的delphi iocp代码，其他的如iocpclass有网友测试有问题，FISHIOCP我测试也有问题，剩下的要不代码不全（我实在不会补全），要不只有dcu，所以只看这份IOCPComp了。
我修改了几处如下：
1.unit ServerMainUnit;
修改：以前没显示
function TServerMainForm.OnClientRead(ASocket: TCustomSocket;
AData: Pointer; ACount: Integer): Integer;
begin
FLock.Enter; // Enter
try
Inc(FRequestCount);
msgmemo.Lines.add(StrPas(AData)); ///add
ASocket.write(AData^, ACount);
finally
FLock.Leave; //Leave
end;
{ 接收到后，再发送回去 }
Result := 0;
end;修改：以前不能给client发送
procedure TServerMainForm.Button1Click(Sender: TObject);
var
a:pchar;
I, Count: Integer;
begin
a:=pchar(ClientMsgEdit.Text);
Count := length(a);
for I := 0 to FServerSocket.ClientCount - 1 do
FServerSocket.Clients[I].Write(a^, Count);
end;
2.unit IOCPComp;
增加：以前只有AllocBlock
function TServerClientSocket.RemovBlock(Block:PBlock):Boolean;
begin
if Block.Data.IsUse then
begin
Block.Data.IsUse := false;
Block.IsUse := False;
Exit;
end;
FBlock.remove(Block);
FBuffer.RemoveBlock(Block);
Block.Data.IsUse := false;
Result:=true;
end;修改：以前用带的客户端测试一旦断开连接则不能接受数据
procedure TServerSocket.WMClientClose(var Message: TCMSocketMessage);
var
ClientSocket: TCustomSocket;
begin
ClientSocket := FindClientSocket(Message.Socket);
if (Assigned(ClientSocket)) then
begin
FClients.Remove(ClientSocket); //增加，断开出错，但能继续接受数据
// ClientSocket.Free;//以前
end;
end;修改：之前每接受一条数据，内存就增加几k
function TServerClientSocket.PrepareRecv(Block: PBlock = nil): Boolean;
前面没变省略
RemovBlock(Block);//最后加了一句
end;
3、下面是问题：
(用带的客户端测试)
并发连接几百个，内存就增加几M，断开后并不减少，这很成问题，希望找到原因，继续改进此代码4.ps
为了比较，我试了dxsock，用以上的客户端测试，并发连接几百个就死掉，不知为什么，还是我不会用
我修改了几处如下：
1.unit ServerMainUnit;
修改：以前没显示
function TServerMainForm.OnClientRead(ASocket: TCustomSocket;
AData: Pointer; ACount: Integer): Integer;
begin
FLock.Enter; // Enter
try
Inc(FRequestCount);
msgmemo.Lines.add(StrPas(AData)); ///add
ASocket.write(AData^, ACount);
finally
FLock.Leave; //Leave
end;
{ 接收到后，再发送回去 }
Result := 0;
end;修改：以前不能给client发送
procedure TServerMainForm.Button1Click(Sender: TObject);
var
a:pchar;
I, Count: Integer;
begin
a:=pchar(ClientMsgEdit.Text);
Count := length(a);
for I := 0 to FServerSocket.ClientCount - 1 do
FServerSocket.Clients[I].Write(a^, Count);
end;
2.unit IOCPComp;
增加：以前只有AllocBlock
function TServerClientSocket.RemovBlock(Block:PBlock):Boolean;
begin
if Block.Data.IsUse then
begin
Block.Data.IsUse := false;
Block.IsUse := False;
Exit;
end;
FBlock.remove(Block);
FBuffer.RemoveBlock(Block);
Block.Data.IsUse := false;
Result:=true;
end;修改：以前用带的客户端测试一旦断开连接则不能接受数据
procedure TServerSocket.WMClientClose(var Message: TCMSocketMessage);
var
ClientSocket: TCustomSocket;
begin
ClientSocket := FindClientSocket(Message.Socket);
if (Assigned(ClientSocket)) then
begin
FClients.Remove(ClientSocket); //增加，断开出错，但能继续接受数据
// ClientSocket.Free;//以前
end;
end;修改：之前每接受一条数据，内存就增加几k
function TServerClientSocket.PrepareRecv(Block: PBlock = nil): Boolean;
前面没变省略
RemovBlock(Block);//最后加了一句
end;
3、下面是问题：
(用带的客户端测试)
并发连接几百个，内存就增加几M，断开后并不减少，这很成问题，希望找到原因，继续改进此代码4.ps
为了比较，我试了dxsock，用以上的客户端测试，并发连接几百个就死掉，不知为什么，还是我不会用
class function TMemoryPool.Attach( lpMemoryPool: TMemoryPool
): TMemoryPool;
var
ManagementCount : Integer;
begin
Result := nil; if Not Assigned(lpMemoryPool) then
Exit; ManagementCount := lpMemoryPool.Attach ;
if ManagementCount = 1 then
begin
lpMemoryPool.Detach;
Exit;
end; Result := lpMemoryPool;
end;
procedure TMemoryPool.InternalFreeBuffer( lpBuffer : TDataBuffer
);begin
if Not (lpBuffer <> nil) then
Exit;
HeapFreeEx(lpBuffer)；
end;function TMemoryPool.CreateNewBuffer( dwBytes : DWORD
) : TDataBuffer;
var
DFBufferSize : DWORD;
LocalBytes : DWORD;
lpDataBuffer : TDataBuffer;
begin
Result := nil;
LocalBytes := dwBytes;
try
if FDefaultBufferSize < 512 then
DFBufferSize := SystemInfo.dwPageSize
else
DFBufferSize := FDefaultBufferSize; if LocalBytes = 0 then
LocalBytes := DFBufferSize;
if LocalBytes < sizeof(_DataBuffer) then
LocalBytes := DFBufferSize;
lpDataBuffer := HeapAllocEx(LocalBytes); if lpDataBuffer = nil then
Exit;
Result := lpDataBuffer;
Result^.Owner := self;
Result^.BufferLen := LocalBytes - sizeof(_BaseDataBuffer); except
on E: Exception do
begin
WriteLog( 'Exception: TMemoryPool.CreateNewBuffer'
+ '('+IntToStr(LocalBytes)+')'
{$ifdef DEBUG}
+ '(Thread ID='+IntToStr(GetCurrentThreadID)+',Pool=$'+IntToHex(Integer(self),8)+')'
{$endif}
+ E.Message);
end;
end;
end;procedure TMemoryPool.Init(const newPoolSize: Integer
);
var
I : Integer;
lpBuffer : TDataBuffer;
begin
if Attach = 1 then
begin
Detach;
Exit;
end;
try
with FMemoryList.LockList do
try
for I := Count to newPoolSize do
begin
lpBuffer := CreateNewBuffer;
if lpBuffer = nil then
break;
lpBuffer^.Using := false;
lpBuffer^.WhereXY := Add(Pointer(lpBuffer));
Inc(FLastMember);
end;
finally
FMemoryList.UnlockList;
end;
finally
Free;
end;
end;function TMemoryPool.CreateBuffer:TDataBuffer;
var
dwSize : DWORD;
begin
dwSize := 0;
Result := CreateBuffer(dwSize);
end;function TMemoryPool.CreateBuffer(var dwBytes: DWORD
):TDataBuffer;
var
lpBuffer : TDataBuffer;
LocalBytes : DWORD;
begin
Result := nil;
try
if Not Assigned(FMemoryList) then
Exit;
LocalBytes := dwBytes;
if LocalBytes <> 0 then
LocalBytes := LocalBytes + sizeof(_BaseDataBuffer);
if Attach = 1 then
begin
Detach;
Exit;
end;
try
with FMemoryList.LockList do
try
if (FLastMember<>FFirstMember) and (FLastUsing<>FLastMember) then
begin
Inc(FLastUsing);
lpBuffer := Items[FLastUsing];
Result := lpBuffer;
end;
if Result = nil then
begin
lpBuffer := CreateNewBuffer(LocalBytes);
if lpBuffer = nil then
Exit;
lpBuffer^.WhereXY := Add(Pointer(lpBuffer));
Result := lpBuffer;
Inc(FLastMember);
FLastUsing := FLastMember; end; Result^.Using := true;
Result^.DataLength := 0;
Result^.CompletedLength := 0;
Result^.NextFuffer := nil;
dwBytes := Result^.BufferLen;
Attach; finally
FMemoryList.UnlockList;
end;
finally
Free;
end;
except
on E: Exception do
begin
WriteLog('Exception: TMemoryPool.CreateBuffer; '+ E.Message);
end;
end;end;procedure TMemoryPool.FreeBuffer( lpBuffer : TDataBuffer
);
var
lpTempBuffer : TDataBuffer;begin
if Not (lpBuffer <> nil) then
Exit;
if Not Assigned(lpBuffer^.Owner) then
Exit;
if lpBuffer^.Owner <> self then
begin
lpBuffer^.Owner.FreeBuffer(lpBuffer);
Exit;
end;
if Attach = 1 then
begin
Detach;
Exit;
end;
try
with FMemoryList.LockList do
try
if Not lpBuffer^.Using then Exit;
lpBuffer^.Using := false;
if FLastUsing >= 0 then
begin
lpTempBuffer := Items[FLastUsing];
if lpTempBuffer <> lpBuffer then
begin
lpTempBuffer^.WhereXY := lpBuffer^.WhereXY;
lpBuffer^.WhereXY := FLastUsing;
Items[FLastUsing] := lpBuffer;
Items[lpTempBuffer^.WhereXY] := lpTempBuffer;
end;
Dec(FLastUsing); end;
finally
FMemoryList.UnlockList;
self.Free;
end;
finally
Free;
end;
end;procedure TMemoryPool.FreeMultiBuffers( lpBuffer : TDataBuffer
);
var
lpTmpBuffer, lpTmpBuffer_Free : TDataBuffer;
begin
lpTmpBuffer := lpBuffer;
if Not (lpTmpBuffer <> nil) then
Exit;
while (lpTmpBuffer <> nil) do
begin
lpTmpBuffer_Free := lpTmpBuffer;
lpTmpBuffer := lpTmpBuffer^.NextFuffer;
FreeBuffer(lpTmpBuffer_Free);
end;end;procedure TMemoryPool.RemoveBufferNode(lpBuffer: TDataBuffer);
var
I : Integer;
begin
if Not (lpBuffer <> nil) then
Exit;
if Not Assigned(lpBuffer^.Owner) then
Exit;
if lpBuffer^.Owner <> self then
begin
lpBuffer^.Owner.RemoveBufferNode(lpBuffer);
Exit;
end;
if Attach = 1 then
begin
Detach;
Exit;
end;
try
with FMemoryList.LockList do
try
for I := Count - 1 downto 0 do
begin
if lpBuffer = Items[I] then
begin
Delete(I);
InternalFreeBuffer(lpBuffer);
Dec(FLastMember);
break;
end;
end;
finally
FMemoryList.UnlockList;
end;
finally
Free;
end;
end;function TMemoryPool.Attach:Integer;
begin
Result := InterlockedIncrement(FManagementCount);
end;function TMemoryPool.Detach:Integer;
begin
Result := InterlockedDecrement(FManagementCount);
end;constructor TMemoryPool.Create;
begin
Inherited Create;
FManagementCount := 1;
FLastMember := FFirstMember;
FLastUsing := FFirstMember;
FDefaultBufferSize:= DEFAULT_BUFFER_SIZE;
FMemoryList := TThreadList.Create;
end;destructor TMemoryPool.Destroy;
var
I : Integer;
begin
with FMemoryList.LockList do
try
for I := 0 to Count - 1 do
begin
InternalFreeBuffer(Items[I]);
end;
finally
FMemoryList.UnlockList;
FMemoryList.Free;
end;end;procedure TMemoryPool.Free;
begin
if Detach>0 then
Exit;
Inherited Free;
end;
最新代码用 cvs checkout
-----------------------------------------------------------------------------------------------------------------------------
www.sourceforge.net/projects/uvc
uvc is a socket1.1 compatible delphi/kylix component
support multiple threading module, request/fdset/socket per thread, 10k tcp connection on request per thread model, and socks
是这样么？
又发现一点问题
unit IOCPComp;
function TMemoryBuffer.AllocBlock: PBlock;
var
I: Integer;
begin
FSocket.Lock;
try
Result := nil;
for I := 0 to FList.Count - 1 do
begin
Result := FList[I];
if Result.IsUse = false then
break; //应该为exit,当改过后又有问题
end;
New(Result);
FList.Add(Result);
FillChar(Result.Data, SizeOf(Result^.Data), 0);
Result.IsUse := True;
finally
FSocket.UnLock;
end;
end;如哪位有更多改进，可发布在这
function TMemoryBuffer.AllocBlock: PBlock;
var
I: Integer;
begin
FSocket.Lock;
try
Result := nil;
for I := 0 to FList.Count - 1 do
begin
Result := FList[I];
if not Result.IsUse then
break;
end;
if not Assigned(Result) or Result.IsUse then
begin
New(Result);
FList.Add(Result);
end;
FillChar(Result^.Data, SizeOf(Result^.Data), 0);
Result^.IsUse := True;
finally
FSocket.UnLock;
end;
end;
socket 原生库是 BSD 3.4 提供的 1.1 版, 之后产生大量应用, windows 同样也是用的这个改过来的
Overlapped & IOCP 是在 windows 对普通 IO 操作上做的一次改进,也同样适用于socket实不实用的不说, 这个会被人骂死, 但既然 windows 能实现, 我们同样也能实现一个高效的, 巨大连接数的组件UVC 的 request per thread 能支持非常大数量的连接, 现在已经有几个应用达到了 1w+, 效率也不低于完成端口(当然跟程序质量有一定关系,没什么可比性,作为测试是有过的)另外说 fastMM4 在多线程上的确有非常大的提升(有时有几十倍的差别, 线程多非常明显, 人为感觉得到), 服务器程序嘛, 单线处理能力并不重要, 关键还是多线的, 从结论上看 fastmm 的确对碎片问题有极大的改进(OS运行时间更长), 多线内存分配时间上基本不会因为运行时间变化而有改变(App性能最大化), 这个也不用吹, fastmm4 在 sourceforget.net 上的历史也可以证明了, 另外开发也不是不对, 作为学习嘛
但作为服务稳定考虑, 我是绝对不会随便找一个代码就用的, 也不会自已介入这种无法确定结果的项目
并且可能在 Lazarus(基于 freepascal) 运行, 目前语法上都兼容, 但 Lazarus 组件机制还不了解
function TMemoryBuffer.AllocBlock: PBlock;
var
I: Integer;
begin
FSocket.Lock;
try
Result := nil;
for I := 0 to FList.Count - 1 do
begin
Result := FList[I];
if Result.IsUse = false then begin
Result.IsUse := True;//加上这一句
Exit; //应该为exit,当改过后又有问题
end
end;
New(Result);
FList.Add(Result);
FillChar(Result.Data, SizeOf(Result^.Data), 0);
Result.IsUse := True;
finally
FSocket.UnLock;
end;
end; 不要每次都是for i := 0 to FList.Count-1，否则当存在几百上千甚至上万之后，每次都从头做一次扫描，那效率还有吗？其实当初我也是这样写的。后来想想，这样子写的目的，不过是释放的时候，比较方便，但是对于申请，这样子一次扫描，远比直接的内存管理要慢得多，那这个内存池就完全失去了意义。虽然他在实现上成分离到Socket上(存在的问题暂时不分析)，但是这还是几个几十个的扫描还是存在的。换而言之，象我上面的实现方法，每次都把空闲的放在最后面，只是在释放内存的时候，比直接修改IsUse标志位要消耗大一点，但是申请的效率高得多了，只是一个指针的转移，比扫描要好得多。另外，这个每一个Socket上面都排一个内存池，这个对于都是频繁使用并且长时间在线（长连接）的Socket当然并没有什么太大问题，但是实际应用当中对于不同的应用环境这个就有一个相当大的差异。一般的应用，活动用户一般占全部在线用户当中的2%~30%不等，对于那些间歇性忙录的Socket，很有忙的时候分配了几十个单位，而实际应用当中则只有几个。这是很明显的内存浪费。
break; //这里不Exit,主要是为了执行后面的FillChar和IsUse := True,有没有用就要自己决定了
end;
New(Result);
FList.Add(Result);
FillChar(Result.Data, SizeOf(Result^.Data), 0);
Result.IsUse := True;
var
I: Integer;
begin
FSocket.Lock;
try
Result := nil;
for I := 0 to FList.Count - 1 do
if not PBlock(FList[I])^.IsUse then
begin
Result := FList[I];
Break;
end;//if
if Result = nil then
begin
New(Result);
FList.Add(Result);
end;//if
FillChar(Result.Data, SizeOf(Result^.Data), 0);
Result.IsUse := True;
finally
FSocket.UnLock;
end;
end;
目的是代替原来的一个版本, 刚调稳300~500左右终端, 目前cpu占用(4核xeon) < 0.1%, 实际终端, 所以数据量也不是很大, 300终端左右执行拍照, 平均i/o 10~15k/s非要用完成端口做的就不要考虑我了, 完成端口虽然我也做过, 但对调稳信心就不是很足..可能是能力上的问题以下是条款，接受的可以联系内存管理用原始的或 fastmm4, 目前其它也不打算试, 性能你不用当心开发用就是用 uvc 组件, 因为在形成组件前有很长时间的积累, 所以用着习惯, 这个因为放在 sf, 所以也是全开放, 目前大容量程序终止得很慢(有线网没这方面问题)gps/gis server 部分不参与, 这个工程量巨大, 要一个小组上百工作日才能完成, 人在深圳合作另说, 但不排除不接受可能性程序的模式由我界定(就是输出界面)，理由可以解释, 但不能商量, 做过太多这类, 好处你以后自然知道收费在 10-15k 视情况, 一般为10工作日以内完成代码, 30工作日左右试运行因为目前一个同类项目正在进行中, 要知道你的公司名等, 不存在竞争的, 要得到合作方同意才能参与, 答复是3天联系方式是 [email protected] msn or mail;
代码用 cvs 共同所有, 版权共有, 但本人不用于商业用途, 本人之后在不直接使用你版本的代码的前提下, 不受竞业约束
我现在做的这个程序简直就是一个大杂烩,终端通讯,GIS客户端通讯,数据存储,全包了,刚刚看了其中一个服务器,800+GPRS终端,20左右GIS客户端,跑了424个小时,平均每秒接收终端数据才2K(主要这些终端大多不带摄像头),每小时执行10W条SQL,酷睿2双核2.0G,占CPU20%左右,除了偶尔发生内存飙升的问题以外,还算正常...
至于说gis server开发需要很多时间,站在我的角度是没法理解,只是把终端数据转发一下,没那么困难吧,呵呵