aarhin / delphi-iocp-framework Goto Github PK

有几个思路：
1。TIocpTcpSocket 
支持多个端口侦听,是否可以建立一个类似TIocpSocketConnection的
对象TIocpSocketServer,用于抽象Tcp Server， 
由TIocpTcpSocket管理一组TIocpSocketConnection，和一组TIocpSocketServer�
��而TIocpSocketServer有与一组TIocpSocketConnection关联.


2。TIocpTpcSocket 
变成一个独立的IO处理模块,所有的TcpClient和TcpServer都由TIocpTpc
Socket 
来处理IO.这样我们的应用程序只要包含一个TIocpTcpSocket即可实
现所有Server和Client. Http Server可以继承自TIocpSocketServer

3。TIocpTcpSocket.Listen中可以添加一个参数，即：侦听线程数，�
��果侦听线程数为0，则与其它Listen共享线程，如果大于0则为�
��Listen增加多个侦听线程.

学用您的IOCP组件，参考httpTunnel写了个ipTunnel转发的.因为想到
可以做公网上的数据加密通道。从TSimpleIocpTcpServer继承过来。
还能跑起来,只是觉得效率比较慢。
试验您的 SimpleIocpTcpServer 和 PackIocpServer 例子，发现 
PackIocpServer 
快得多，应该是用了线程池的原因吧？(水平不够，看不懂您�
��程序)
TSimpleIocpTcpServer能不能做个更强更快的，带线程池的？因为我
看到您的TIocpDataSnapTransport也是用的TSimpleIocpTcpServer，貌似效��
�不高啊。
把我的 ipTunnel 类发上来让你乐乐

type
  TIocpIpTunnelConnection = class; // 隧道连接 前置申明

  TIocpIpAgentConnection = class(TIocpSocketConnection) // 代理连接
    // 本连接对象用于对被代理端的连接
  protected
    IpTunnelConnection: TIocpIpTunnelConnection; // 客户端请求的连接
    TunnelLocker: TCriticalSection;
  public
    constructor Create(AOwner: TObject); override;
    destructor Destroy; override;
  end;

  TIocpIpTunnelConnection = class(TIocpSocketConnection)
    // TIocpPacketConnection)//隧道连接
    // 本连接对象用于对客户端的连接
  protected
    AgentConnection: TIocpIpAgentConnection; // 连接到目标服务器的连接
    AgentLocker: TCriticalSection;
    DstHost: string;
    DstPort: Word;

  public

    constructor Create(AOwner: TObject); override;
    destructor Destroy; override;
  end;

  TIocpIpAgent = class(TIocpTcpSocket) // 代理
  private
    function NewConnect(IpTunnelConnection: TIocpIpTunnelConnection;iTimeout:integer): Boolean;
    // 打开一个向被代理目标端口的连接，并利用 tag 属性把 客户端连接对象 写进去
    function DoForward(IpTunnelConnection: TIocpIpTunnelConnection;
      buf: pointer; size: integer): Boolean;
    // 转发方法
  protected
    // 重载下面几个方法可以实现在IO事件触发时做相应处理
    // 连接建立时触发
    function TriggerClientConnected(Client: TIocpSocketConnection)
      : Boolean; override;

    // 连接断开时触发
    function TriggerClientDisconnected(Client: TIocpSocketConnection)
      : Boolean; override;

    // 接收到数据时触发
    function TriggerClientRecvData(Client: TIocpSocketConnection; buf: pointer;
      Len: integer): Boolean; override;

    // 发送数据完成时触发
    // 这里Buf只有指针本身是可以安全使用的，它所指向的内存数据很有可能已经被释放了
    // 所以千万不要在这个事件中去尝试访问Buf所指向的数据
    // procedure TriggerClientSentData(Client: TIocpSocketConnection; Buf: Pointer; Len: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  TConfirmForwardEvent = function(Sender: TObject;
    Client: TIocpIpTunnelConnection; out ServerAddr: string;
    out ServerPort: Word): Boolean of object;

  TIocpIPTunnel = class(TSimpleIocpTcpServer) // 隧道服务器
  private

    FIpAgent: TIocpIpAgent;
    FConfirmForward: TConfirmForwardEvent;
  protected
    function TriggerClientConnected(Client: TIocpSocketConnection)
      : Boolean; override;

    function TriggerClientDisconnected(Client: TIocpSocketConnection)
      : Boolean; override;
    function TriggerClientRecvData(Client: TIocpSocketConnection; buf: pointer;
      Len: integer): Boolean; override;
  protected
    fDaemonIP, fProxyIp: string;
    fDaemonPort, fDaemonTimeout, fDaemonClientLife, fDaemonIoThreadsNumber,
      fProxyPort, fProxyTimeout, fProxyClientLife,
      fProxyIOThreadsNumber: integer;
    FisStart, FisCompress, FisEncryption, FisLog: Boolean;
    // 重载这个方法决定是否转发当前请求
    // Result = True, 转发
    // Result = False, 不转发, 可以设置False, 然后自己返回自定义的页面数据
    function TriggerConfirmForward(Client: TIocpIpTunnelConnection;
      out ServerAddr: string; out ServerPort: Word): Boolean; virtual;
  public
    function startTunnel(DaemonIP: string; DaemonPort, DaemonTimeout,
      DaemonClientLife, DaemonIoThreadsNumber: integer; ProxyIP: string;
      ProxyPort, ProxyTimeout, ProxyClientLife, ProxyIOThreadsNumber: integer;
      isCompress, isEncryption, isLog: Boolean): Boolean;
    function stopTunnel():boolean;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ConfirmForward: TConfirmForwardEvent read FConfirmForward
      write FConfirmForward;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Iocp', [TIocpIPTunnel]);
end;

function PortStr(const Port: Word): string;
begin
  if (Port <> 80) then
    Result := ':' + IntToStr(Port)
  else
    Result := '';
end;

{ TIocpIpAgent }

constructor TIocpIpAgent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ConnectionClass := TIocpIpAgentConnection;
  // 指定连接的类型
end;

function TIocpIpAgent.DoForward(IpTunnelConnection: TIocpIpTunnelConnection;
  buf: pointer; size: integer): Boolean;
var
  i: integer;
begin
  with IpTunnelConnection do
    try
      AgentLocker.Enter;
      if (AgentConnection = nil) then
      begin
        AppendLog('ER - 隧道连接%s:%s 转发时，代理连接不存在', [IpTunnelConnection.PeerIP,
          IpTunnelConnection.Socket.ToString]);
        Exit(False);
      end;
      i := AgentConnection.Send(buf, size);
      if (i < size) then
      begin
        AppendLog('ER - 隧道连接%s:%s  的代理连接%s:%s 转发失败,原始长度/转发长度:%d/%d',
          [IpTunnelConnection.PeerIP, IpTunnelConnection.Socket.ToString,
          AgentConnection.PeerIP, AgentConnection.Socket.ToString, size, i]);
        Exit(False);
      end;
      {AppendLog('OK - 隧道连接%s:%s  的代理连接%s:%s 转发成功,原始长度/转发长度:%d/%d',
        [IpTunnelConnection.PeerIP, IpTunnelConnection.Socket.ToString,
        AgentConnection.PeerIP, AgentConnection.Socket.ToString, size, i]);}
      Result := True;
    finally
      AgentLocker.Leave;
    end;
end;

function TIocpIpAgent.NewConnect(IpTunnelConnection
  : TIocpIpTunnelConnection;iTimeout:integer): Boolean;
var
  tempConn: TIocpSocketConnection;
begin
  tempConn :=self.Connect(IpTunnelConnection.DstHost,
    IpTunnelConnection.DstPort, IpTunnelConnection,itimeout);
  // AsyncConnect(IpTunnelConnection.DstHost,
  //  IpTunnelConnection.DstPort, IpTunnelConnection);
  Result := not tempConn.IsClosed;
  if Result then
    AppendLog('OK - 隧道%s:%s 的代理连接创建成功，socket : %s ', [IpTunnelConnection.PeerIP,
      IpTunnelConnection.Socket.ToString, tempConn.Socket.ToString])
  else
    AppendLog('ER - 隧道%s:%s 的代理连接创建失败', [IpTunnelConnection.PeerIP,
      IpTunnelConnection.Socket.ToString]);

  // 类中缺省 self 即 self.AsyncConnect
end;

function TIocpIpAgent.TriggerClientConnected
  (Client: TIocpSocketConnection): Boolean;
var
  TunnelConn: TIocpIpTunnelConnection;
  AgConn: TIocpIpAgentConnection;
begin
  TunnelConn := Client.Tag;
  if (TunnelConn = nil) then
    Exit;
  // if not assigned(TunnelConn) then exit;
  // 代理连接由隧道服务器在创建与客户端的隧道连接时调用
  //代理对象的 newconnect方法创建连接
  AgConn := TIocpIpAgentConnection(Client);
  // 给双方赋值。那就是说，是在server之外管理这些连接？？？
  try
    TunnelConn.AgentLocker.Enter;
    TunnelConn.AgentConnection := AgConn;
    AgConn.IpTunnelConnection := TunnelConn;
    AppendLog('OK - 代理连接%s:%s 成功，给隧道%s:%s 与代理双方赋值：',
      [AgConn.PeerIP, AgConn.Socket.ToString, AgConn.IpTunnelConnection.PeerIP,
      AgConn.IpTunnelConnection.Socket.ToString]);
  finally
    TunnelConn.AgentLocker.Leave;
  end;
end;

function TIocpIpAgent.TriggerClientDisconnected
  (Client: TIocpSocketConnection): Boolean;
begin
  with TIocpIpAgentConnection(Client) do
    try
      TunnelLocker.Enter;
      if (IpTunnelConnection = nil) then
      begin
        AppendLog('ER - 代理连接%s:%s 关闭时，隧道链接为空',
          [Client.PeerIP, Client.Socket.ToString]);
        Exit;
      end;
      AppendLog('OK - 代理连接%s:%s 断开，隧道链接%s:%s 断开',
        [Client.PeerIP, Client.Socket.ToString, IpTunnelConnection.PeerIP,
        IpTunnelConnection.Socket.ToString]);
      IpTunnelConnection.AgentLocker.Enter;
      IpTunnelConnection.AgentConnection := nil;
      IpTunnelConnection.AgentLocker.Leave;
      IpTunnelConnection.Disconnect;
      IpTunnelConnection := nil;
    finally
      TunnelLocker.Leave;
    end;
end;

function TIocpIpAgent.TriggerClientRecvData(Client: TIocpSocketConnection;
  buf: pointer; Len: integer): Boolean;
var
  i: integer;
begin
  with TIocpIpAgentConnection(Client) do
    try
      TunnelLocker.Enter; // or (IpTunnelConnection.IsClosed)
      if (IpTunnelConnection = nil) then
      begin
        AppendLog('ER - 代理连接%s:%s  收到数据时，隧道链接为空',
          [Client.PeerIP, Client.Socket.ToString]);
        Exit;
      end;
      i := IpTunnelConnection.Send(buf, Len);
      if i = Len then

       { AppendLog('OK - 代理连接%s:%s 收到数据进行转发，隧道链接为 %s %s，原始长度/转发长度：%d/%d',
          [Client.PeerIP, Client.Socket.ToString, IpTunnelConnection.PeerIP,
          IpTunnelConnection.Socket.ToString, Len, i])
          }
      else
        AppendLog('ER - 代理连接%s:%s 收到数据进行转发，隧道链接为 %s %s，原始长度/转发长度：%d/%d',
          [Client.PeerIP, Client.Socket.ToString, IpTunnelConnection.PeerIP,
          IpTunnelConnection.Socket.ToString, Len, i]);

    finally
      TunnelLocker.Leave;
    end;
end;

{ TIocpIpTunnel }

constructor TIocpIPTunnel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ConnectionClass := TIocpIpTunnelConnection;
  FIpAgent := TIocpIpAgent.Create(nil);
end;

destructor TIocpIPTunnel.Destroy;
begin
  FreeAndNil(FIpAgent);
  inherited Destroy;
end;

function TIocpIPTunnel.startTunnel(DaemonIP: string;
  DaemonPort, DaemonTimeout, DaemonClientLife, DaemonIoThreadsNumber: integer;
  ProxyIP: string; ProxyPort, ProxyTimeout, ProxyClientLife,
  ProxyIOThreadsNumber: integer; isCompress, isEncryption,
  isLog: Boolean): Boolean;
begin
  if FisStart then
    self.stop;
  fDaemonIP := DaemonIP;
  fProxyIp := ProxyIP;
  fDaemonPort := DaemonPort;
  fDaemonTimeout := DaemonTimeout;
  fDaemonClientLife := DaemonClientLife;
  fDaemonIoThreadsNumber := DaemonIoThreadsNumber;
  fProxyPort := ProxyPort;
  fProxyTimeout := ProxyTimeout;
  fProxyClientLife := ProxyClientLife;
  fProxyIOThreadsNumber := ProxyIOThreadsNumber;
  // 正则搜索字符串 f(.+)$  替换字符串 f\1:=\1;

  // with self do
  begin
    IoThreadsNumber := DaemonIoThreadsNumber;
    ClientLife := DaemonClientLife * 1000;
    Timeout := DaemonTimeout * 1000;
    Port := DaemonPort;
    Addr := DaemonIP;
  end;
  FisCompress := isCompress;
  FisEncryption := isEncryption;
  FisLog := isLog;
  FisStart := self.Start;
  if FisStart then
    AppendLog('OK 隧道服务器启动')
  else
    AppendLog('ER 隧道服务器启动失败');
  Result := FisStart;
end;

function TIocpIPTunnel.stopTunnel: boolean;
begin
result:=stop;
if result then  AppendLog('OK 隧道服务器停止')
else  AppendLog('ER 隧道服务器停止失败')

end;

function TIocpIPTunnel.TriggerClientConnected
  (Client: TIocpSocketConnection): Boolean;
var
  RequestForward: Boolean;
  IpTunnelConnection: TIocpIpTunnelConnection;
  Success: Boolean;
begin
  IpTunnelConnection := TIocpIpTunnelConnection(Client);
  with IpTunnelConnection do
    try
      AgentLocker.Enter;
      if (AgentConnection = nil) then // or (AgentConnection.IsClosed)
      begin
        // 获取转发的目标服务器地址及端口
        // RequestForward := TriggerConfirmForward(IpTunnelConnection, DstHost, DstPort);
        // if not RequestForward then Exit;
        // 新建代理连接，并在代理连接建立后(FIpAgent.TriggerClientConnected)开始转发
        DstHost := fProxyIp;
        DstPort := fProxyPort;
        with FIpAgent do
        begin
          IoThreadsNumber := fProxyIOThreadsNumber;
          ClientLife := fProxyClientLife * 1000;
          Timeout := fProxyTimeout * 1000;
          Success := NewConnect(IpTunnelConnection,timeout);
        end;
      end;
      if Success then
        AppendLog('OK - 隧道连接%s:%s 准备打开代理连接 to %s:%d',
          [Client.PeerIP, Client.Socket.ToString, DstHost, DstPort])
      else begin
        AppendLog('ER - 隧道连接%s:%s 打开代理连接失败 %s:%d',
          [Client.PeerIP, Client.Socket.ToString, DstHost, DstPort]);
        client.Disconnect;
       end;//if Success
    finally
      AgentLocker.Leave;
    end;
end;

function TIocpIPTunnel.TriggerClientDisconnected
  (Client: TIocpSocketConnection): Boolean;
begin
  with TIocpIpTunnelConnection(Client) do
    try
      AgentLocker.Enter;
      if (AgentConnection = nil) then
      begin
        AppendLog('ER - 隧道连接%s:%s 关闭时，代理连接不存在 %s:%d',
          [Client.PeerIP, Client.Socket.ToString, DstHost, DstPort]);
        Exit;
      end;

      AppendLog('OK - 隧道连接%s:%s关闭时，关闭代理连接%s:%s to %s:%d',
        [Client.PeerIP, Client.Socket.ToString, AgentConnection.PeerIP,
        AgentConnection.Socket.ToString, DstHost, DstPort]);
      AgentConnection.TunnelLocker.Enter;
      AgentConnection.IpTunnelConnection := nil;
      AgentConnection.TunnelLocker.Leave;
      AgentConnection.Disconnect;
      AgentConnection := nil;
    finally
      AgentLocker.Leave;
    end;
end;

function TIocpIPTunnel.TriggerConfirmForward(Client: TIocpIpTunnelConnection;
  out ServerAddr: string; out ServerPort: Word): Boolean;
begin
  if Assigned(FConfirmForward) then
    Result := FConfirmForward(self, Client, ServerAddr, ServerPort)
  else
    Result := False;
end;

function TIocpIPTunnel.TriggerClientRecvData(Client: TIocpSocketConnection;
  buf: pointer; Len: integer): Boolean;
begin
{  AppendLog('OK - 隧道连接%s:%s 收到数据，开始转发，长度 : %d',
    [Client.PeerIP, Client.Socket.ToString, Len]);}
  Result := FIpAgent.DoForward(TIocpIpTunnelConnection(Client), buf, Len);
end;

{ TIocpIpTunnelConnection }

constructor TIocpIpTunnelConnection.Create(AOwner: TObject);
begin
  inherited Create(AOwner);
  AgentLocker := TCriticalSection.Create;
end;

destructor TIocpIpTunnelConnection.Destroy;
begin
  AgentLocker.Free;
  inherited Destroy;
end;

{ TIocpIpAgentConnection }

constructor TIocpIpAgentConnection.Create(AOwner: TObject);
begin
  inherited Create(AOwner);
  TunnelLocker := TCriticalSection.Create;
end;

destructor TIocpIpAgentConnection.Destroy;
begin
  TunnelLocker.Free;
  inherited Destroy;
end;

procedure TIocpTcpSocket.RequestAcceptComplete(PerIoData: PIocpPerIoData);
var
  .....
begin
.....
FConnectionList[PerIoData.ClientSocket] := Connection;
FIdleConnectionList.Delete(Connection.FSocket);
Connection.FConnectionSource:=csConnect;
......
end;


procedure TIocpTcpSocket.FreeConnection(Connection: TIocpSocketConnection);
begin
  try
    FConnectionListLocker.Enter;
    if not Connection.FConnectionSource=csConnect then FConnectionList.Delete(Connection.FSocket) 
else
      FIdleConnectionList.Delete(Connection.FSocket);
    FConnectionPool.FreeObject(Connection);
  finally
    FConnectionListLocker.Leave;
  end;
end;

感谢作者的努力，创作这么好的IOCP的DELPHI框架，
希望作者继续更新，支持XE6以上，谢谢！

At iocp.TcpSocket.pas

    // 生成新的连接对象并绑定到IOCP
    Connection := AllocConnection(ClientSocket);
    if not AssociateSocketWithCompletionPort(ClientSocket, Connection) then
    begin
      Iocp.Winsock2.CloseSocket(ClientSocket);
      FConnectionPool.FreeObject(Connection);
      Exit;
    end;

    if (Connection.AddRef = 1) then Exit;

    Connection.FIsIPv6 := (POutAddrInfo.ai_family = AF_INET6);
    Connection.Tag := Tag;

建议改为：（防止用户通过tag传递对象，但是Socket创建失败��
�，会直接调用TriggerClientDisconnected中,而此时用户程序可能访��
�Tag

    // 生成新的连接对象并绑定到IOCP
    Connection := AllocConnection(ClientSocket);
    Connection.Tag := Tag;
    if not AssociateSocketWithCompletionPort(ClientSocket, Connection) then
    begin
      Iocp.Winsock2.CloseSocket(ClientSocket);
      FConnectionPool.FreeObject(Connection);
      Exit;
    end;

    if (Connection.AddRef = 1) then Exit;

    Connection.FIsIPv6 := (POutAddrInfo.ai_family = AF_INET6);

I'd like to study this project for another big project, but I cannot understand 
demos...

at Iocp.TimerQueue.Pas, you called
  DeleteTimerQueueEx(FTimerQueueHandle, 0);

I think may be changed to :
  DeleteTimerQueueEx(FTimerQueueHandle, INVALID_HANDLE_VALUE);


http://technet.microsoft.com/zh-cn/subscriptions/ms682568.aspx

Demo

最近SVN下载不了codeGoogle的东西了，不知道如何是好，大哥是�
��考虑将项目迁移其他的地方呀

when run program in win64, the memory size may overflow 32bits integer, so 
please replace integer to NativeInt
1.
Iocp.TcpSocket.Pas:

    property PerIoUsedMemory: NativeInt read GetPerIoUsedMemory;
    property PerIoFreeMemory: NativeInt read GetPerIoFreeMemory;
    property IoCacheUsedMemory: NativeInt read GetIoCacheUsedMemory;
    property IoCacheFreeMemory: NativeInt read GetIoCacheFreeMemory;

2. Replace Integer to NativeInt at Iocp.ObjectPool.pas

3.....

When TIocpTcpSocket is used in DLL, the IO thread and TCacheFileStream can not 
be freed successfully.

I Modified the Iocp.Logger.pas and Iocp.TcpSocket.pas, and upload in attach 
file.

At Iocp.TcpSocket.Pas, the TIocpTcpSocket.Listen function may cause resource 
leak, when WSASocket or bind or Iocp.Winsock2.listen or 
AssociateSocketWithCompletionPort return is failed.

May Change as:

function TIocpTcpSocket.Listen(const Host: string; Port: Word; InitAcceptNum: 
Integer): Boolean;
const
  IPV6_V6ONLY = 27;
var
  PHost: PWideChar;
  ListenSocket: TSocket;
  InAddrInfo: TAddrInfoW;
  POutAddrInfo, Ptr: PAddrInfoW;
  ListenCount: Integer;
  LastErr: Integer;
  SocketList:TList<TSocket>;
begin
  Result := False;
  if not Assigned(FAcceptThread) then Exit;  

  try
    // 如果传递了一个有效地址则监听该地址
    // 否则监听所有本地地址
    if (Host = '') then
      PHost := nil
    else
      PHost := PWideChar(Host);

    FillChar(InAddrInfo, SizeOf(TAddrInfoW), 0);
    InAddrInfo.ai_flags := AI_PASSIVE;
    InAddrInfo.ai_family := AF_UNSPEC;
    InAddrInfo.ai_socktype := SOCK_STREAM;
    InAddrInfo.ai_protocol := IPPROTO_TCP;
    if (getaddrinfo(PHost, PWideChar(IntToStr(Port)), @InAddrInfo, @POutAddrInfo) <> 0) then
    begin
      LastErr := WSAGetLastError;
      AppendLog('%s.Listen.getaddrinfo, ERROR %d=%s', [ClassName, LastErr, SysErrorMessage(LastErr)], ltWarning);
      Exit;
    end;

        SocketList:=TList<TSocket>.Create;
        try
        try
          {$region '检查监听个数是否已达上限'}
          Ptr := POutAddrInfo;
          ListenCount := FAcceptThread.ListenCount;
          while (Ptr <> nil) do
          begin
            Inc(ListenCount);
            Ptr := Ptr.ai_next;
          end;
          if (ListenCount > FAcceptThread.MAX_LISTEN_SOCKETS) then Exit;
          {$endregion}

            Ptr := POutAddrInfo;  
          while (Ptr <> nil) do
          begin
            ListenSocket := WSASocket(Ptr.ai_family, Ptr.ai_socktype, Ptr.ai_protocol, nil, 0, WSA_FLAG_OVERLAPPED);
            if (ListenSocket = INVALID_SOCKET) then Exit;

    //        no := 0;
    //        setsockopt(ListenSocket, IPPROTO_IPV6, IPV6_V6ONLY, PAnsiChar(@no), sizeof(no));

            if (bind(ListenSocket, Ptr.ai_addr, Ptr.ai_addrlen) = SOCKET_ERROR) then
            begin
              LastErr := WSAGetLastError;
              Iocp.Winsock2.closesocket(ListenSocket);
              AppendLog('%s.Listen.bind(Port=%d, Socket=%d), ERROR %d=%s', [ClassName, Port, ListenSocket, LastErr, SysErrorMessage(LastErr)], ltWarning);
              Exit;
            end;

            if (Iocp.Winsock2.listen(ListenSocket, SOMAXCONN) = SOCKET_ERROR) then
            begin
              LastErr := WSAGetLastError;
              Iocp.Winsock2.closesocket(ListenSocket);
              AppendLog('%s.Listen.listen(Port=%d, Socket=%d), ERROR %d=%s', [ClassName, Port, ListenSocket, LastErr, SysErrorMessage(LastErr)], ltWarning);
              Exit;
            end;

            if not AssociateSocketWithCompletionPort(ListenSocket, nil) then
            begin
              Iocp.Winsock2.closesocket(ListenSocket);
              AppendLog('%s.Listen.AssociateSocketWithCompletionPort(Port=%d, Socket=%d) failed', [ClassName, Port, ListenSocket], ltWarning);
              Exit;
            end;

            if not FAcceptThread.NewListen(ListenSocket, Ptr.ai_family, InitAcceptNum) then
            begin
              Iocp.Winsock2.closesocket(ListenSocket);
              Exit;
            end;
                    SocketList.Add(ListenSocket);
            Ptr := Ptr.ai_next;
          end;
        finally
          freeaddrinfo(POutAddrInfo);
        end;

        Result := True;
      except
        on e: Exception do
        begin
            for i:=0 to SocketList.Count-1 do
            begin
                FAcceptThread.StopListen(SocketList[i]);
            end; 
          AppendLog('%s.Listen ERROR %s=%s', [ClassName, e.ClassName, e.Message], ltException);
        end;
      end;
    finally
    SocketList.Free;
  end;
end;

destructor TIocpTimerQueue.Destroy;
var
  Timer: TIocpTimerQueueTimer;
begin
  DeleteTimerQueueEx(FTimerQueueHandle, 0);

  try
    FLocker.Enter;
    for Timer in FTimerList do
      Timer.Cancel;
  finally
    FLocker.Leave;
  end;
  ..........
end;

建议改为：

destructor TIocpTimerQueue.Destroy;
var
  Timer, Bak: TIocpTimerQueueTimer;
  i:Integer;
begin
  DeleteTimerQueueEx(FTimerQueueHandle, 0);
  i:=0; Timer:=nil;
  try
    FLocker.Enter;
    while (i<FTimerList.Count) do
    begin
      Bak:=FTimerList[0]; Timer:=Bak;
      Timer.Cancel;  //调用Cancel可能会在FTimerList中删除Timer
      if Bak=FTimerList[0] then Inc(i);
    end;
  finally
    FLocker.Leave;
  end;
  ..........
end;

unit Iocp.TimerQueue;

{基于Win32系统的时钟队列
主要用于检测IOCP连接是否超时
}

interface

uses
  Windows, Classes, SysUtils, SyncObjs, System.Generics.Collections, Iocp.Logger;

type
  TIocpTimerQueueTimer = class;
  TIocpTimerQueueTimerList = TList<TIocpTimerQueueTimer>;
  TIocpTimerQueue = class
  private
    FRefCount: Integer;
    FTimerQueueHandle: THandle;
    FTimerList: TIocpTimerQueueTimerList;
    FLocker: TCriticalSection;
  protected
  public
    constructor Create; virtual;
    destructor Destroy; override;

    function AddRef: Integer;
    function Release: Boolean;

    property Handle: THandle read FTimerQueueHandle;
    property RefCount: Integer read FRefCount;
  end;

  TIocpTimerQueueTimer = class
  private
    FTimerQueue: TIocpTimerQueue;
    FTimerHandle: THandle;
    FInterval: DWORD;
    FRefCount: Integer;
    FOnTimer: TNotifyEvent;
    FOnCancel: TNotifyEvent;

    procedure SetInterval(const Value: DWORD);
  protected
    procedure Execute; virtual;
    procedure Cancel; virtual;
  public
    constructor Create(TimerQueue: TIocpTimerQueue; Interval: DWORD); virtual;
    destructor Destroy; override;

    function AddRef: Integer;
    function Release: Boolean;

    property Interval: DWORD read FInterval write SetInterval;
    property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
    property OnCancel: TNotifyEvent read FOnCancel write FOnCancel;
  end;

implementation

procedure WaitOrTimerCallback(Timer: TIocpTimerQueueTimer; TimerOrWaitFired: 
ByteBool); stdcall;
begin
  try
    Timer.Execute;
  except
  end;
end;

{ TIocpTimerQueue }

constructor TIocpTimerQueue.Create;
begin
  FTimerQueueHandle := CreateTimerQueue();
  FTimerList := TIocpTimerQueueTimerList.Create;
  FLocker := TCriticalSection.Create;
  FRefCount := 1;
end;

destructor TIocpTimerQueue.Destroy;
var
  Timer, Bak: TIocpTimerQueueTimer;
  i:Integer;
begin
  DeleteTimerQueueEx(FTimerQueueHandle, 0);
  i:=0;
  try
    FLocker.Enter;
//    for Timer in FTimerList do
//      Timer.Cancel;
    while (i< FTimerList.Count) do
    begin
      Timer:=FTimerList[i]; Bak:=Timer;
      Timer.Cancel;
      if (i<FTimerList.Count) and (Bak=FTimerList[i]) then Inc(i);
    end;
  finally
    FLocker.Leave;
  end;


  FTimerList.Free;
  FLocker.Free;

  inherited Destroy;
end;

function TIocpTimerQueue.AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TIocpTimerQueue.Release: Boolean;
begin
  Result := (InterlockedDecrement(FRefCount) = 0);
  if not Result then Exit;

  Free;
end;

{ TIocpTimerQueueTimer }

constructor TIocpTimerQueueTimer.Create(TimerQueue: TIocpTimerQueue; Interval: 
DWORD);
begin
  FTimerQueue := TimerQueue;
  FInterval := Interval;
  FRefCount := 1;

  // 参数DueTime设置为100，表示100毫秒后才启动Timer
  // 这样做是为了让Timer等待对象创建完成，否则可能会出现Timer中访问对象，但是对象尚未创建成功
  if not CreateTimerQueueTimer(FTimerHandle, FTimerQueue.Handle, @WaitOrTimerCallback, Pointer(Self), 100, FInterval, 0) then
  begin
    raise Exception.Create('CreateTimerQueueTimer failed');
  end;

  try
    FTimerQueue.AddRef;
    FTimerQueue.FLocker.Enter;
    FTimerQueue.FTimerList.Add(Self);
  finally
    FTimerQueue.FLocker.Leave;
  end;
end;

destructor TIocpTimerQueueTimer.Destroy;
begin
  DeleteTimerQueueTimer(FTimerQueue.Handle, FTimerHandle, 0);

  try
    FTimerQueue.FLocker.Enter;
    FTimerQueue.FTimerList.Remove(Self);
  finally
    FTimerQueue.FLocker.Leave;
    FTimerQueue.Release;
  end;

  inherited Destroy;
end;

function TIocpTimerQueueTimer.AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TIocpTimerQueueTimer.Release: Boolean;
begin
  Result := (InterlockedDecrement(FRefCount) = 0);

  if not Result then Exit;

  Free;
end;

procedure TIocpTimerQueueTimer.Execute;
begin
  if Assigned(FOnTimer) then
    FOnTimer(Self);
end;

procedure TIocpTimerQueueTimer.Cancel;
begin
  if Assigned(FOnCancel) then
    FOnCancel(Self);
end;

procedure TIocpTimerQueueTimer.SetInterval(const Value: DWORD);
begin
  FInterval := Value;
  ChangeTimerQueueTimer(FTimerQueue.Handle, FTimerHandle, 0, FInterval)
end;

end.

soulawing:
  很高兴看到你增加了一个线程侦听多个端口功能，但限制了62个端口，
这是我的一个程序，目的是能过侦听多个〉62端口，希望能合
并这个功能到你的版本中：

  TIocpMultiAcceptEventType = (etAdd, etDel, etShutdown);

  TIocpMultiAcceptThread = class(TIocpAcceptThread)
  private
    FOwner: TTcpConnectionServerFactory;
    // FListenSocket: array of TIocpMultiSocket;
    FServers: array [0..62] of TTcpConnectionServer;
    FAcceptEvents: array [0..63] of THandle;
    FServerCount:Integer;
//    FInitAcceptNum: Integer;
    FAiFamily: Integer;
    FAcceptEventServer: TTcpConnectionServer;
    FAcceptEventType: TIocpMultiAcceptEventType;
    FAcceptEventSocketContext: Pointer;
    FAcceptEvent: THandle;
    FAcceptEventLocker: TCriticalSection;
  protected
    procedure Execute; override;
    procedure DoAddListen;
    procedure DoDelListen;
    procedure DoShutDown;
    procedure DoDelAllListen;
  public
    constructor Create(IocpSocket: TTcpConnectionServerFactory; AiFamily, InitAcceptNum: Integer); reintroduce;
    destructor Destroy; override;
    function AddListen(aServer: TTcpConnectionServer): Boolean;
    procedure DelListen(aServer: TTcpConnectionServer);
    procedure Quit; override;
  end;

procedure TIocpMultiAcceptThread.Execute;
var
  N, i: Integer;
  aSocket: TSocket;
  LastErr: Integer;
  RetEvents: TWSANetworkEvents;
  dwRet: DWORD;
begin
  FServerCount:=0;
  FAcceptEvents[0] := CreateEvent(nil, True, False, nil);
  try
    try
      while not Terminated do
      begin
        // 等待退出或者ACCEPT事件
        dwRet := WSAWaitForMultipleEvents(FServerCount+1, @FAcceptEvents[0], False, INFINITE, True);
        if (dwRet = WSA_WAIT_FAILED) or Terminated then
          Break;

        // 收到事件通知
        N := dwRet - WSA_WAIT_EVENT_0;
        if (N = Length(FAcceptEvents)) then
        begin
          case FAcceptEventType of
            etAdd:
              DoAddListen;
            etDel:
              DoDelListen;
            etShutdown:
              DoShutDown;
          end;
          Continue;
        end;

        aSocket := FServers[N].FListenSocket;
        // 读取事件状态
        if (WSAEnumNetworkEvents(aSocket, FAcceptEvents[N], @RetEvents) = SOCKET_ERROR) then
        begin
          LastErr := WSAGetLastError;
          AppendLog('%s.WSAEnumNetworkEvents失败, ERROR %d=%s', [ClassName, LastErr, SysErrorMessage(LastErr)], ltWarning);
          DelListen(FServers[N]);
          Continue;
        end;

        // 如果ACCEPT事件触发，则投递新的Accept套接字
        // 每次投递32个
        if (RetEvents.lNetworkEvents and FD_ACCEPT = FD_ACCEPT) then
        begin
          if (RetEvents.iErrorCode[FD_ACCEPT_BIT] <> 0) then
          begin
            LastErr := WSAGetLastError;
            AppendLog('%s.WSAEnumNetworkEvents失败, ERROR %d=%s', [ClassName, LastErr, SysErrorMessage(LastErr)], ltWarning);
            DelListen(FServers[N]);
            Continue;
          end;
          for i := 1 to FServers[N].FParam.InitAcceptNum do
          begin
            if not FOwner.PostNewAcceptEx2(FServers[N], FAiFamily) then
              Break;
          end;
        end;
      end; // End of While
      DoDelAllListen;
    finally
      CloseHandle(FAcceptEvents[0]);
    end;
  except
    on e: Exception do
      AppendLog('%s.Execute, %s=%s', [ClassName, e.ClassName, e.Message], ltException);
  end;
end;

下面是添加侦听：
function TTcpConnectionServerFactory.AddListen(const 
Param:ITcpConnectionServerParam): TTcpConnectionServer;
const
  IPV6_V6ONLY = 27;
var
  PHost: PWideChar;
  ListenSocket: TSocket;
  InAddrInfo: TAddrInfoW;
  POutAddrInfo, Ptr: PAddrInfoW;
  LastErr: Integer;
  B: Boolean;
  i: Integer;
  T: TIocpMultiAcceptThread;
begin
  Result := nil;

  try
    // 如果传递了一个有效地址则监听该地址
    // 否则监听所有本地地址
    if (Param.ListenAddress = '') then
      PHost := nil
    else
      PHost := PWideChar(WideString(AnsiString(Param.ListenAddress)));

    FillChar(InAddrInfo, SizeOf(TAddrInfoW), 0);
    InAddrInfo.ai_flags    := AI_PASSIVE;
    InAddrInfo.ai_family   := AF_UNSPEC;
    InAddrInfo.ai_socktype := SOCK_STREAM;
    InAddrInfo.ai_protocol := IPPROTO_TCP;
    if (getaddrinfo(PHost, PWideChar(IntToStr(Param.ListenPort)), @InAddrInfo, @POutAddrInfo) <> 0) then
    begin
      LastErr := WSAGetLastError;
      AppendLog('%s.getaddrinfo失败, ERR=%d,%s', [ClassName, LastErr, SysErrorMessage(LastErr)], ltWarning);
      Exit;
    end;

    try
      Ptr := POutAddrInfo;
      while (Ptr <> nil) do
      begin
        ListenSocket := WSASocket(Ptr.ai_family, Ptr.ai_socktype, Ptr.ai_protocol, nil, 0, WSA_FLAG_OVERLAPPED);
        if (ListenSocket = INVALID_SOCKET) then
          Exit;

        // no := 0;
        // setsockopt(ListenSocket, IPPROTO_IPV6, IPV6_V6ONLY, PAnsiChar(@no), sizeof(no));

        if (bind(ListenSocket, Ptr.ai_addr, Ptr.ai_addrlen) = SOCKET_ERROR) then
        begin
          LastErr := WSAGetLastError;
          Iocp.Winsock2.CloseSocket(ListenSocket);
          AppendLog('%s.绑定监听端口(%d)失败, ERR=%d,%s', [ClassName, Param.ListenPort, LastErr, SysErrorMessage(LastErr)], ltWarning);
          Exit;
        end;

        if (Iocp.Winsock2.listen(ListenSocket, SOMAXCONN) = SOCKET_ERROR) then
        begin
          LastErr := WSAGetLastError;
          Iocp.Winsock2.CloseSocket(ListenSocket);
          AppendLog('%s.启动监听端口(%d)失败, ERR=%d,%s', [ClassName, Param.ListenPort, LastErr, SysErrorMessage(LastErr)], ltWarning);
          Exit;
        end;

        Result := TTcpConnectionServer.Create;
        if not AssociateSocketWithCompletionPort2(ListenSocket, Result) then
        begin
          Result.Free;
          Iocp.Winsock2.CloseSocket(ListenSocket);
          AppendLog('%s.绑定监听端口(%d)到IOCP失败', [ClassName, Param.ListenPort], ltWarning);
          Exit;
        end;

        Result.FTcpSocket          := Self;
        Result.FListenSocket       := ListenSocket;
        Result.FContext            := Param.Context;
        Result.FInfo.FStartTime    := Now;
        Result.FInfo.FLocalAddress := Param.ListenAddress;
        Result.FInfo.FLocalPort    := Param.ListenPort;
        try
          FListenThreadsLocker.Enter;
          for i := 0 to FListenThreads.Count - 1 do
          begin
            B := TIocpMultiAcceptThread(FListenThreads[i]).AddListen(Result);
            if B then
              Break;
          end;
          if not B then
          begin
            T := TIocpMultiAcceptThread.Create(Self, Ptr.ai_family, Param.InitAcceptNum);
            FListenThreads.Add(T);
            T.AddListen(Result);
          end;
        finally
          FListenThreadsLocker.Leave;
        end;

        Ptr := Ptr.ai_next;
      end;
    finally
      freeaddrinfo(POutAddrInfo);
    end;

    // Result := True;
  except
    on e: Exception do
      AppendLog('%s.Listen ERROR %s=%s', [ClassName, e.ClassName, e.Message], ltException);
  end;
end;

I can't compile IocpHttpTunnelSvc because it lacks the VaniConfig.pas unit.

Iocp.TcpSocket.Pas

function TIocpAcceptThread.NewListen(ListenSocket: TSocket; AiFamily,
  InitAcceptNum: Integer): Boolean;
var
  ListenData: TIocpListenData;
  i: Integer;
begin
  FLocker.Enter;
  try
    if (FListenList.Count >= MAX_LISTEN_SOCKETS) then Exit(False);

    ListenData.Socket := ListenSocket;
    ListenData.AiFamily := AiFamily;
    ListenData.InitAcceptNum := InitAcceptNum;
    for i := 1 to InitAcceptNum do
      FOwner.PostNewAcceptEx(ListenSocket, AiFamily);

    ListenData.AcceptEvent := WSACreateEvent;
    WSAEventSelect(ListenSocket, ListenData.AcceptEvent, FD_ACCEPT);
    FListenList.Add(ListenData);
  finally
    FLocker.Leave;
  end;

  Reset;
  Result := True;
end;




May Change To:




function TIocpAcceptThread.NewListen(ListenSocket: TSocket; AiFamily,
  InitAcceptNum: Integer): Boolean;
var
  ListenData: ^TIocpListenData;
  i: Integer;
begin
  FLocker.Enter;
  try
    if (FListenList.Count >= MAX_LISTEN_SOCKETS) then Exit(False);
    GetMem(ListenData, sizeof(TIocpListenData);
    ListenData.Socket := ListenSocket;
    ListenData.AiFamily := AiFamily;
    ListenData.InitAcceptNum := InitAcceptNum;
    for i := 1 to InitAcceptNum do
      FOwner.PostNewAcceptEx(ListenSocket, AiFamily);

    ListenData.AcceptEvent := WSACreateEvent;
    WSAEventSelect(ListenSocket, ListenData.AcceptEvent, FD_ACCEPT);
    FListenList.Add(ListenData);
  finally
    FLocker.Leave;
  end;

  Reset;
  Result := True;
end;

TIocpAcceptThread.Destroy may call FreeMem for each item os FListenList

Delphi IOCP Framework 是个很好的框架，
我有两个小建议：
1.在Socket关闭后经常出现Timer的导致的
内存访问错误。是否可以交由TIocpTcpSocket统一管理所有Timer的�
��命周期，而不是有Connection管理，这样应该可以避免Timer导致
的访问错误。

2.将TIocpTcpSocket和TIocpSocketConnection的Private成员改为Protected成员
，便于继承扩展的类可以访问。

3.是否可以建立一个TIocpTcpServerSocket的对象，可以同时打开侦�
��多个Port,这样就在需要打开众多端口的程序中，可以不用为�
��个Port创建一个TIocpTcpSocket，进而导致多个线程被创建。

另外，本人想参与您这个项目的维护与开发。

What steps will reproduce the problem?
1. Using FastMM with FullDebug there where a lot of "double-free" calls
2. There was a problem with the log writer (do not write until some log where 
in the streams)

Tested on XE4 and VERY HIGH concurrent env

And no documentation on site in English.

Even some would do good, non native English speaker I know it is not easy, but 
would do good for the project. And even smalles Commets on SVN commits would 
make easier to follow the project.

Just mu 0.02€

Hope this will help this project being widely adopted ;-)