Delphi异步socket通讯组件

一直很烦恼delphi附带的socket控件都不能满足我的设计逻辑需要，无奈只好自己动手封装了API，并且得到实践的证明（至少有两个服务器能稳定运行至今），本socket组件的多线程机制是安全的稳定的。

 

    在服务器端，创建线程池，对于每个客户连接对应一个独立的线程类，可以在线程内处理客户数据，并可以线程间采用同步机制交换数据，为通讯服务器的建立提供了技术实现的基础。

 

    U版本的经过了缺陷优化，虽然仅是经过了测试也还没有得到实践运行，但从以往成熟的结构演变而来的，问题应该不大！

 

附socket组件及相关单元源码：

 

 

{******************************************************************************
*                      UCode 系列组件、控件                                   *
*                   作者：卢益贵         2003～2008                           *
*       版权所有    任何未经授权的使用和销售，均保留追究法律责任的权力        *
*                                                                             *
*      UCode 系列由XCtrls－YCtrls－ICtrls－NCode系列演变而来                  *
* 2008-11-12                                                                  *
******************************************************************************}

{******************************************************************************
     2008-11-18 根据以前系列版本的优劣，重新设计了异步Tcp通讯组件。服务器可以在
     独立的线程对象TUTcpLink的OnReceive里面独立处理响应客户端数据。
     
类拓扑：
  TUThread---TUTcp---|---TUTcpClientBasic---|---TUTcpLink
                     |                      |---TUTcpClient
                     |---TUTcpServer
******************************************************************************}

unit UTcp;

interface

uses
  Windows, Messages, SysUtils, Dialogs, Classes, UWinSock2, UClasses;

const
  WM_UTCP                   = WM_USER + 1000;

{******************************************************************************
  线程和窗体控件的信息交换的Windows消息定义
  TUTcpServer和TUTcpClient线程有socket事件发生时，给FHWnd窗口句柄发送消息，
  OnMsgProc解析消息，从而达到了线程不直接访问窗体控件的要求
******************************************************************************}
  WM_UTCP_MESSAGE           = DWord(WM_UTCP + 1);
  WM_UTCP_OPEN              = DWord(WM_UTCP + 2);
  WM_UTCP_CLOSE             = DWord(WM_UTCP + 3);
  WM_UTCP_CONNECT           = DWord(WM_UTCP + 4);
  WM_UTCP_DISCONNECT        = DWord(WM_UTCP + 5);
  WM_UTCP_RECEIVE           = DWord(WM_UTCP + 6);
  WM_UTCP_ERROR             = DWord(WM_UTCP + 7);

  WM_UTCP_USER              = DWord(WM_UTCP + 100);

type

{******************************************************************************
  TUTcp实现了异步Tcp的基本功能：获得Socket句柄，关闭socket，创建socket事件，
  响应socket事件
******************************************************************************}
  { TUTcp }
  TUTcp = class(TUThread)
  private
    FSocket: TSocket;
    //异步socket事件句柄
    FSocketEvent: THandle;
    //响应的socket事件的标志位
    FSocketEventType: DWord;

    FActive: Boolean;
    FSizeSocketRevcBuf: Integer;
    FSizeSocketSendBuf: Integer;
    FSizeRevcBuf: Integer;
  protected
    procedure OnExecute(); override;
    procedure Execute(); override;

    function SetSockOpt(const OptionName: Integer;
                        const Optionvalue: PChar;
                        const OptionLen: Integer;
                        const Level: Integer = SOL_SOCKET): Boolean;
    procedure CloseSocketEvent();
    procedure CreateSocketEvent();
    function GetSocketAddr(IP: String; Port: Integer): TSockAddrIn;

    //响应socket事件的函数，可以重写本函数，在函数体内解析socket事件标志
    procedure OnThreadSocketEvent(const NWE: PWSANETWORKEVENTS); virtual; abstract;
    //为继承者提供的虚方法
    procedure DoError(Sender: TUTcp; ErrorMsg: String); virtual; abstract;
    procedure DoOpen(); virtual;
    procedure DoClose(); virtual;
    procedure DoActive(); virtual;
  public
    constructor Create(); virtual;
    destructor Destroy(); override;

    function GetLocalIP(IsIntnetIP: Boolean): String;

    //线程接收缓冲大小，默认1024，必须Open之前设置
    property SizeRevcBuf: Integer read FSizeRevcBuf write FSizeRevcBuf;
    //套接口接收缓冲大小，默认8192，必须Open之前设置
    property SizeSocketRevcBuf: Integer read FSizeSocketRevcBuf write FSizeSocketRevcBuf;
    //套接口发送缓冲大小，默认8192，必须Open之前设置
    property SizeSocketSendBuf: Integer read FSizeSocketSendBuf write FSizeSocketSendBuf;
    //Socket Open以后的标志，True：TUTcpServer代表监听成功，TUTcpClient代表Open成功，不代表Connect成功
    property Active: Boolean read FActive;
  end;

{******************************************************************************
  为TUTcpLink和TUTcpClient设计的基类，完成接收、连接、发送的功能
******************************************************************************}
  { TUTcpClientBasic }
  TUTcpClientBasic = class(TUTcp)
  private
    FBufRevc: PByte;
    FRemoteIP: String;
    FRemotePort: Word;
    FAllowWrite: Boolean;
  protected
    procedure DoConnect(); virtual; abstract;
    procedure DoDisconnect(); virtual; abstract;
    procedure DoReceive(const Buf: PByte; const Len: Integer); virtual; abstract;
    
    procedure DoActive(); override;
    procedure OnThreadSocketEvent(const NWE: PWSANETWORKEVENTS); override;
    //当有数据接收，在线程内处理数据的虚函数
    procedure OnReceive(const Buf: PByte; const Len: Integer); virtual;
  public
    constructor Create(); override;
    destructor Destroy(); override;

    //同步直接发送，返回值参见winSock的Send
    function Send(Buf: PByte; Len: Integer): Integer; virtual;
    property RemoteIP: String read FRemoteIP write FRemoteIP;
    property RemotePort: Word read FRemotePort write FRemotePort;
  end;

  TUTcpServer = class;

{******************************************************************************
   TUTcpServer响应客户连接负责和客户端交换的链接对象，
   TUTcpLink一旦和客户端断开连接，立即终止线程
******************************************************************************}
  { TUTcpLink }
  TUTcpLink = class(TUTcpClientBasic)
  private
    FServer: TUTcpServer;
  protected
    procedure DoActive(); override;
    procedure DoConnect(); override;
    procedure DoDisconnect(); override;
    procedure DoError(Sender: TUTcp; ErrorMsg: String); override;
    procedure DoReceive(const Buf: PByte; const Len: Integer); override;
  public
    Data: Pointer;
    //如果不想继承本类的话，可以设置本事件函数，达到在线程内处理数据的功能
    OnDisconnectInThreadEvt: procedure(const Sender: TUTcpLink) of object;
    //如果不想继承本类的话，可以设置本事件函数，达到在线程内处理数据的功能
    OnReceiveInThreadEvt: procedure(const Sender: TUTcpLink; const Buf: PByte; const Len: Integer) of object;

    constructor Create(); override;
    destructor Destroy(); override;

    property Server: TUTcpServer read FServer;
  end;

{*****************************************************************************
   TUTcpServer的事件函数定义和使用方法
******************************************************************************}
  {
  //定义事件函数
    procedure OnOpenrEvt(const Sender: TUTcpServer);
    procedure OnCloserEvt(const Sender: TUTcpServer);
    procedure OnConnectEvt(const Sender: TUTcpLink);
    procedure OnDisconnectEvt(const Sender: TUTcpLink);
    procedure onErrorEvt(const Sender: TUTcp; const ErrorMsg: String);
    procedure OnMessageEvt(const Sender: TUTcp; const Msg: String);
    procedure OnReceiveEvt(const Sender: TUTcpLink; const Buf: PByte; const Len: Integer);

  FTcpServer := TUTcpServer.Create();

  //所有属性都必须在Open之前设置完毕
  //设置事件函数
  FTcpServer.OnOpenEvt := OnOpenEvt;
  FTcpServer.OnCloseEvt := OnCloseEvt;
  FTcpServer.OnConnectEvt := OnConnectEvt;
  FTcpServer.OnDisconnectEvt := OnDisconnectEvt;
  FTcpServer.OnMessageEvt := OnMessageEvt;
  FTcpServer.onErrorEvt := onErrorEvt;
  FTcpServer.OnReceiveEvt := OnReceiveEvt;

  FTcpServer.LocalIP := '192.168.10.220';
  FTcpServer.LocalPort := 20029;
  FTcpServer......
  ................

  FTcpServer.Open();
  }

{*****************************************************************************
   TUTcpServer完成了响应客户连接请求，和负责管理客户链接对象，
   以及负责管理线程池
******************************************************************************}
  { TUTcpServer}
  TUTcpServer = class(TUTcp)
  private
    FLocalIP: String;
    FLocalPort: Word;
    FLinks: TUObjects;
    FReadys: TUObjects;
    FReadyLinkCount: Integer;
    FHWnd: HWnd;
    FTickCountAutoOpen: DWord;
    FMaxLinks: Integer;
    FAutoOpenTime: Integer;
    
    procedure OnMsgProc(var Msg: TMessage);
    procedure CheckReadyLink();
    function GetReadyLink(): TUTcpLink;
    procedure CheckAutoOpen;
    function GetLinkCount: Integer;
    function GetLink(Index: Integer): TUTcpLink;
  protected
    //为继承者提供的从链接队列里面删除某个链接对象的函数
    procedure DeleteLink(Link: TUTcpLink);
    //负责解析Window消息的函数
    procedure OnWndMsg(var Msg: TMessage); virtual;
    //发送Window消息的函数
    function PostMsgToOwner(Msg, wParam, lParam: DWord): Boolean; overload;
    //发送文本Window消息的函数
    function PostMsgToOwner(Sender: TUTcp; Msg: DWord; StrMsg: String): Boolean; overload;
    procedure OnThreadSocketEvent(const NWE: PWSANETWORKEVENTS); override;
    
    procedure DoOpen(); override;
    procedure DoClose(); override;
    procedure DoError(Sender: TUTcp; ErrorMsg: String); override;
    procedure DoConnect(const Sender: TUTcpLink); virtual;
    procedure DoDisconnect(const Sender: TUTcpLink); virtual;
    procedure DoReceive(const Sender: TUTcpLink; const Buf: PByte; const Len: Integer); virtual;

    //可以在本函数里面统一接收处理客户端的数据
    procedure OnReceive(const Sender: TUTcpLink; const Buf: PByte; const Len: Integer);
    //创建一个客户端链接对象，可以为继承者提供的虚函数
    function CreateLinkObject(): TUTcpLink; virtual;
    procedure OnExecute(); override;
  public
    //和窗体控件交换的事件函数定义
    OnOpenEvt: procedure(const Sender: TUTcpServer) of object;
    OnCloseEvt: procedure(const Sender: TUTcpServer) of object;
    OnConnectEvt: procedure(const Sender: TUTcpLink) of object;
    OnDisconnectEvt: procedure(const Sender: TUTcpLink) of object;
    OnMessageEvt: procedure(const Sender: TUTcp; const Msg: String) of object;
    OnReceiveEvt: procedure(const Sender: TUTcpLink; const Buf: PByte; const Len: Integer) of object;
    onErrorEvt: procedure(const Sender: TUTcp; const ErrorMsg: String) of object;
    //如果不想继承本类的话，可以设置本事件函数，达到在线程内处理数据的功能
    OnReceiveInThreadEvt: procedure(const Sender: TUTcpLink; const Buf: PByte; const Len: Integer) of object;
    
    constructor Create(); override;
    destructor Destroy(); override;

    procedure Open(); virtual;
    procedure Close(); virtual;

    //发送文本Window消息的函数
    procedure PostMsg(Sender: TUTcp; Msg: String);
    
    //广播发送
    function Send(const Buf: PByte; const Len: Integer): Boolean;
    //发送到某个指定的链接
    function SendTo(const Link: TUTcpLink; const Buf: PByte; const Len: Integer): Boolean;

    property LocalIP: String read FLocalIP write FLocalIP;
    property LocalPort: Word read FLocalPort write FLocalPort;
    //线程池的链接对象数量，默认20
    property ReadyLinkCount: Integer read FReadyLinkCount write FReadyLinkCount;
    //服务端最大的连接熟练，默认为最大
    property MaxLinks: Integer read FMaxLinks write FMaxLinks;
    //当非调用Close时发生的关闭Socket之后，自动连接的间隔时间
    property AutoOpenTime: Integer read FAutoOpenTime write FAutoOpenTime;
    //链接对象的数量
    property LinkCount: Integer read GetLinkCount;
    //链接对象
    property Links[Index: Integer]: TUTcpLink read GetLink;
  end;

{*****************************************************************************
   TUTcpClient的事件函数定义和使用方法
******************************************************************************}
  {
    procedure OnOpenEvt(const Sender: TUTcpClient);
    procedure OnCloseEvt(const Sender: TUTcpClient);
    procedure OnConnectEvt(const Sender: TUTcpClient);
    procedure OnDisconnectEvt(const Sender: TUTcpClient);
    procedure OnMessageEvt(const Sender: TUTcpClient; const Msg: String);
    procedure OnReceiveEvt(const Sender: TUTcpClient; const Buf: PByte; const Len: Integer);
    procedure onErrorEvt(const Sender: TUTcpClient; const ErrorMsg: String);

  FTcpClient := TUTcpClient.Create();
  
  //所有属性都必须在Open之前设置完毕
  //设置事件函数
  FTcpClient.OnOpenEvt := OnOpenEvt;
  FTcpClient.OnCloseEvt := OnCloseEvt;
  FTcpClient.OnConnectEvt := OnConnectEvt;
  FTcpClient.OnDisconnectEvt := OnDisconnectEvt;
  FTcpClient.OnMessageEvt := OnMessageEvt;
  FTcpClient.onErrorEvt := onErrorEvt;
  FTcpClient.OnReceiveEvt := OnReceiveEvt;

  FTcpClient.RemoteIP := '192.168.10.220';
  FTcpClient.RemotePort := 20029;
  FTcpClient......
  ......

  FTcpClient.Open();

  }

{*****************************************************************************
   Tcp客户端组件
******************************************************************************}
  { TUTcpClient }
  TUTcpClient = class(TUTcpClientBasic)
  private
    FTickCountAutoConnect: DWord;
    FAutoConnectTime: Integer;
    FHWnd: HWnd;
    FConnected: Boolean;
    procedure OnMsgProc(var Msg: TMessage);
  protected
    procedure CheckAutoConnect();
    procedure OnWndMsg(var Msg: TMessage); virtual;
    function PostMsgToOwner(Msg, wParam, lParam: DWord): Boolean; overload;
    function PostMsgToOwner(Sender: TUTcp; Msg: DWord; StrMsg: String): Boolean; overload;

    procedure OnExecute(); override;
    procedure DoOpen(); override;
    procedure DoClose(); override;
    procedure DoConnect(); override;
    procedure DoDisconnect(); override;
    procedure DoError(Sender: TUTcp; ErrorMsg: String); override;
    procedure DoReceive(const Buf: PByte; const Len: Integer); override;
  public
    //和窗体控件交换的事件函数定义
    OnOpenEvt: procedure(const Sender: TUTcpClient) of object;
    OnCloseEvt: procedure(const Sender: TUTcpClient) of object;
    OnConnectEvt: procedure(const Sender: TUTcpClient) of object;
    OnDisconnectEvt: procedure(const Sender: TUTcpClient) of object;
    OnMessageEvt: procedure(const Sender: TUTcpClient; const Msg: String) of object;
    OnReceiveEvt: procedure(const Sender: TUTcpClient; const Buf: PByte; const Len: Integer) of object;
    onErrorEvt: procedure(const Sender: TUTcpClient; const ErrorMsg: String) of object;
    //如果不想继承本类的话，可以设置本事件函数，达到在线程内处理数据的功能
    OnReceiveInThreadEvt: procedure(const Sender: TUTcpClient; const Buf: PByte; const Len: Integer) of object;
    
    constructor Create(); override;
    destructor Destroy(); override;

    procedure Open(); virtual;
    procedure Close(); virtual;

    procedure PostMsg(Msg: String);
    
    //当非调用Close时发生的关闭Socket之后，自动连接的间隔时间
    property AutoConnectTime: Integer read FAutoConnectTime write FAutoConnectTime;
    //连接服务器的标志
    property Connected: Boolean read FConnected; 
  end;

implementation

uses
  USysFunc;

function GetErrorMsg(const AErrorCode: Integer): String;
begin
  case (AErrorCode and $0000FFFF) of
    WSAEACCES:
      Result := '对套接口的访问方式非法！';
    WSAEADDRINUSE:
      Result := '试图将套接口捆绑到正在使用的地址或端口！';
    WSAEADDRNOTAVAIL:
      Result := '指定的地址或端口非法！';
    WSAEAFNOSUPPORT:
      Result := '地址同目前协议不兼容！';
    WSAEALReadY:
      Result := '当前操作正在执行！';
    WSAECONNABORTED:
      Result := '同服务器的连接中断！';
    WSAECONNREFUSED:
      Result := '同服务器的连接被拒绝！';
    WSAECONNRESET:
      Result := '同服务器的连接被服务器强行中断！';
    WSAEDESTADDRREQ:
      Result := '没有指明目标地址！';
    WSAEFAULT:
      Result := '错误的地址！';
    WSAEHOSTDOWN:
      Result := '服务器死锁！';
    WSAEHOSTUNREACH:
      Result := '试图同无法到达的服务器相连接！';

    WSAEINPROGRESS:
      Result := '只允许有一个阻塞的函数调用！';
    WSAEINTR:
      Result := '阻塞函数调用被终止！';
    WSAEINVAL:
      Result := '参数无效！';
    WSAEISCONN:
      Result := '套接口处于连接状态中！';
    WSAEMfile:
      Result := '被打开的套接口太多！';
    WSAEMSGSIZE:
      Result := '数据报套接口中传送的信息太长！';
    WSAENETDOWN :
      Result := '网络系统死锁！';
    WSAENETRESET :
      Result := '操作过程出错，连接中断！';
    WSAENETUNREACH :
      Result := '无法连接到网络！';
    WSAENOBUFS :
      Result := '缓冲区已满，无法进行操作！';
    WSAENOPROTOOPT :
      Result := '无效的套接口选项！';
    WSAENOTCONN :
      Result := '无法进行读写操作！';
    WSAENOTSOCK :
      Result := '试图对非套接口类型的变量进行操作！';
    WSAEOPNOTSUPP :
      Result := '不支持这种操作！';
    WSAEPFNOSUPPORT :
      Result := '不支持当前协议族！';
    WSAEPROCLIM :
      Result := '使用Windows Sock的应用程序太多！';
    WSAEPROTONOSUPPORT :
      Result := '当前协议不被支持！';
    WSAEPROTOTYPE :
      Result := '当前协议不支持指定的套接口类型！';
    WSAESHUTDOWN :
      Result := '套接口已经关闭，无法发送数据！';
    WSAESOCKTNOSUPPORT :
      Result := '指定的套接口类型不被支持！';
    WSAETIMEDOUT :
      Result := '连接超时！';
    10109:
      Result := '无法找到指定的类！';
    WSAEWOULDBLOCK :
      Result := '资源暂时无法使用！';
    WSAHOST_NOT_FOUND :
      Result := '找不到服务器！';
    WSANOTINITIALISED:
      Result := '没有调用WSAStartup（）初始化！';
    WSANO_DATA:
      Result := '指定的机器名称存在，但相应的数据不存在！';
    WSANO_RECOVERY:
      Result := '无法恢复的错误（同机器名称的查找相关）！';
    WSASYSNOTReadY :
      Result := 'Windows Socket 系统不能工作！';
    WSATRY_AGAIN :
      Result := '主机名解析时没有发现授权服务器！';
    WSAVERNOTSUPPORTED:
      Result := '无法初始化服务提供者！';
    WSAEDISCON:
      Result := '服务器已经\"文明地\"关闭了！';
  else
    Result := '产生未知网络错误！';
  end;
end;

{ Init }
var
  WSAData: TWSAData;

procedure Startup;
var
  ErrorCode: Integer;
begin
  ErrorCode := WSAStartup($0101, WSAData);
  if ErrorCode <> 0 then
    ShowMessage('Init Error!');
end;

procedure Cleanup;
var
  ErrorCode: Integer;
begin
  ErrorCode := WSACleanup;
  if ErrorCode <> 0 then
    ShowMessage('Socket init error!');
end;

{ TUTcp }

constructor TUTcp.Create();
begin
  FActive := False;
  FSocket := INVALID_SOCKET;
  FSocketEvent := 0;
  FSocketEventType := 0;
  FSizeSocketRevcBuf := 8192;
  FSizeSocketSendBuf := 8192;
  FSizeRevcBuf := 1024;
  
  inherited Create(False);
end;

destructor TUTcp.Destroy;
begin
  inherited;

end;

procedure TUTcp.DoOpen();
var
  NonBlock: Integer;
  bNodelay: Integer;
begin
  if (FSocket = INVALID_SOCKET) then
  try
    FSocket := Socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
    bNodelay := 1;
    NonBlock := 1;
    if (Not SetSockOpt(TCP_NODELAY, @bNodelay, sizeof(bNodelay))) or
       (ioctlsocket(FSocket, Integer(FIONBIO), NonBlock) = SOCKET_ERROR) then
      DoError(Self, '套接口选项设置错误：' + GetErrorMsg(WSAGetLastError()));
  except
    DoError(Self, '套接口打开异常：' + GetErrorMsg(WSAGetLastError()));
  end;
end;

procedure TUTcp.DoClose();
var
  Socket: TSocket;
begin
  FActive := False;
  Socket := FSocket;
  FSocket := INVALID_SOCKET;

  if Socket <> INVALID_SOCKET then
  try
    closesocket(Socket);
  except
    DoError(Self, '套接口关闭异常：' + GetErrorMsg(WSAGetLastError()));
  end;
end;

function TUTcp.SetSockOpt(const OptionName: Integer;
                             const Optionvalue: PChar;
                             const OptionLen: Integer;
                             const Level: Integer): Boolean;
begin
  try
    Result := UWinSock2.SetSockOpt(FSocket, Level, OptionName,
                                   Optionvalue, OptionLen) <> SOCKET_ERROR;
    if Not Result then
      DoClose();
  except
    DoClose();
    Result := False;
  end;
end;

function TUTcp.GetSocketAddr(IP: String; Port: Integer): TSockAddr;
begin
  Result.sin_family := AF_INET;
  Result.sin_addr.s_addr := inet_addr(PChar(IP));
  Result.sin_port := htons(Port);
end;

procedure TUTcp.CreateSocketEvent();
begin
  if FSocket <> INVALID_SOCKET then
  begin
    CloseSocketEvent();
    FSocketEvent := WSACreateEvent();
    WSAEventSelect(FSocket, FSocketEvent, FSocketEventType);
  end;
end;

procedure TUTcp.CloseSocketEvent();
begin
  if FSocketEvent <> 0 then
  begin
    WSACloseEvent(FSocketEvent);
    FSocketEvent := 0;
  end;
end;

procedure TUTcp.Execute();
begin
  while not Terminated do
  begin
    try
      TickCountExec := GetTickCount();
      OnExecute();
      if Assigned(OnThreadExecuteEvt) then
        OnThreadExecuteEvt(Self);
    except
    end;
  end;
end;

procedure TUTcp.OnExecute();
var
  NWE: TWSANETWORKEVENTS;
  Index: DWord;
begin
  try
    if (Not Terminated) and FActive then
    begin
      try
        //以SleepTime的时间来等待事件，完成空闲时的Sleep功能同时达到更快的响应事件
        Index := WSAWaitForMultipleEvents(1, @FSocketEvent, False, SleepTime, True);
        if (Index <> WSA_WAIT_FAILED) and (Index <> WSA_WAIT_TIMEOUT) then
        begin
          FillChar(NWE, sizeof(TWSANETWORKEVENTS), 0);
          if WSAEnumNetworkEvents(FSocket, FSocketEvent, @NWE) <> SOCKET_ERROR then
            OnThreadSocketEvent(@NWE);
        end;
      except
        DoError(Self, '套接口获取事件异常：' + GetErrorMsg(WSAGetLastError()));
      end;
    end else
    //如果Socket无效，那么1秒钟唤醒10次
      Sleep(100);
  except
  end;
end;

procedure TUTcp.DoActive();
begin
  SetSockOpt(SO_RCVBUF, PChar(@FSizeSocketRevcBuf), sizeof(FSizeSocketRevcBuf));
  SetSockOpt(SO_SNDBUF, PChar(@FSizeSocketSendBuf), sizeof(FSizeSocketSendBuf));
  
  CreateSocketEvent();
  FActive := True;
end;

function TUTcp.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;

{ TUTcpClientBasic }

constructor TUTcpClientBasic.Create();
begin
  FAllowWrite := False;
  inherited;

  FSocketEventType :=  FD_READ or FD_WRITE or FD_CLOSE or FD_CONNECT;
end;

destructor TUTcpClientBasic.Destroy();
begin
  inherited;

end;

procedure TUTcpClientBasic.DoActive;
begin
  if FBufRevc <> nil then
    FreeMem(Pointer(FBufRevc));
  GetMem(Pointer(FBufRevc), FSizeRevcBuf);
  inherited;
end;

function TUTcpClientBasic.Send(Buf: PByte; Len: Integer): Integer;
begin
  try
    Result := UWinSock2.Send(FSocket, Buf^, Len, 0);
    if (Result = SOCKET_ERROR) or (Result <> Len) then
    begin
      Result := SOCKET_ERROR;
      DoError(Self, '套接口写数据错误：' + GetErrorMsg(WSAGetLastError()));
      DoDisconnect();
      DoClose();
    end;
  except
    Result := SOCKET_ERROR;
    DoError(Self, '套接口写数据异常：' + GetErrorMsg(WSAGetLastError()));
    DoDisconnect();
    DoClose();
  end;
end;

procedure TUTcpClientBasic.OnThreadSocketEvent(const NWE: PWSANETWORKEVENTS);
var
  Len: Integer;
begin
  with NWE^ do
  try
    if (DWord(lNetworkEvents) and FD_READ) = FD_READ then
    begin
      if iErrorCode[FD_READ_BIT] <> 0 then
      begin
        DoError(Self, '套接口读数据错误：' + GetErrorMsg(iErrorCode[FD_READ_BIT]));
        DoDisconnect();
        DoClose();
      end else
      try
        Len := UWinSock2.recv(FSocket, FBufRevc^, FSizeRevcBuf, 0);
        if (Len <> SOCKET_ERROR) and (Len > 0) then
          DoReceive(FBufRevc, Len);
      except
        DoError(Self, '套接口读数据异常：' + GetErrorMsg(WSAGetLastError()));
        DoDisconnect();
        DoClose();
      end;
    end;

    if (DWord(lNetworkEvents) and FD_WRITE) = FD_WRITE then
    begin
      if iErrorCode[FD_WRITE_BIT] <> 0 then
      begin
        DoError(Self, '套接口写数据错误：' + GetErrorMsg(iErrorCode[FD_WRITE_BIT]));
        DoDisconnect();
        DoClose();
      end;
    end;

    if (DWord(lNetworkEvents) and FD_CLOSE) = FD_CLOSE then
    begin
      {if iErrorCode[FD_CLOSE_BIT] = 0 then
      begin

      end;}
      
      DoError(Self, '套接口远程连接断开：' + GetErrorMsg(iErrorCode[FD_CLOSE_BIT]));
      DoDisconnect();
      DoClose();
    end;

    if (DWord(lNetworkEvents) and FD_CONNECT) = FD_CONNECT then
    begin
      if iErrorCode[FD_CONNECT_BIT] <> 0 then
      begin
        DoError(Self, '套接口远程连接失败：' + GetErrorMsg(iErrorCode[FD_CONNECT_BIT]));
        DoDisconnect();
        DoClose();
      end else
        DoConnect();
    end;
  except
  end;
end;

procedure TUTcpClientBasic.OnReceive(const Buf: PByte; const Len: Integer);
begin
end;

{ TUTcpLink }

constructor TUTcpLink.Create();
begin
  Data := nil;

  inherited;

  Suspend();
end;

destructor TUTcpLink.Destroy();
begin
  DoDisconnect();
  DoClose();
  
  inherited;  
end;

procedure TUTcpLink.DoActive();
begin
  inherited;
  DoConnect();
end;

procedure TUTcpLink.DoConnect();
begin
  inherited;
  if FServer <> nil then
    FServer.DoConnect(Self);
end;

procedure TUTcpLink.DoDisconnect();
begin
  Terminate();
  inherited;
  if FServer <> nil then
    FServer.DoDisconnect(Self);
  if Assigned(OnDisconnectInThreadEvt) then
    OnDisconnectInThreadEvt(Self);
end;

procedure TUTcpLink.DoError(Sender: TUTcp; ErrorMsg: String);
begin
  inherited;
  if FServer <> nil then
    FServer.DoError(Sender, ErrorMsg);
end;

procedure TUTcpLink.DoReceive(const Buf: PByte; const Len: Integer);
begin
  OnReceive(Buf, Len);
  if Assigned(OnReceiveInThreadEvt) then
    OnReceiveInThreadEvt(Self, Buf, Len);
  if FServer <> nil then
    FServer.DoReceive(Self, Buf, Len);
end;

{ TUTcpServer }

constructor TUTcpServer.Create();
begin
  FLinks := TUObjects.Create();
  FReadys := TUObjects.Create();
  ReadyLinkCount := 20;
  FHWnd := AllocateHWnd(OnMsgProc);
  FMaxLinks := SOMAXCONN;
  FTickCountAutoOpen := 0;
  FAutoOpenTime := 5;
  SleepTime := 100;
  
  inherited;

  FSocketEventType := FD_ACCEPT;
end;

function TUTcpServer.CreateLinkObject(): TUTcpLink;
begin
  Result := TUTcpLink.Create();
  Result.FreeOnTerminated := True;
end;

destructor TUTcpServer.Destroy();
begin
  FHWnd := 0;
  DoClose();
  
  inherited;

  FLinks.Destroy();
  FReadys.Destroy();
  DeallocateHWnd(FHWnd);
end;

function TUTcpServer.GetReadyLink(): TUTcpLink;
begin
  FReadys.Lock();
  Result := TUTcpLink(FReadys.Items[0]);
  try
    if Result = nil then
      Result := CreateLinkObject()
    else
      FReadys.Delete(0);
  finally
    FReadys.Unlock();
  end;
end;

procedure TUTcpServer.CheckAutoOpen();
begin
  if (FTickCountAutoOpen <> 0) and (FAutoOpenTime <> 0) and
     (DecTickCount(FTickCountAutoOpen, GetTickCount()) > DWord(FAutoOpenTime * 1000)) then
  begin
    FTickCountAutoOpen := GetTickCount();
    DoOpen();
  end;
end;

procedure TUTcpServer.CheckReadyLink();
begin
  while FReadys.Count < ReadyLinkCount do
    FReadys.Add(CreateLinkObject());
end;

procedure TUTcpServer.OnExecute();
begin
  inherited;
  CheckReadyLink();
  CheckAutoOpen();
end;

procedure TUTcpServer.OnReceive(const Sender: TUTcpLink; const Buf: PByte; const Len: Integer);
begin
end;

procedure TUTcpServer.DoReceive(const Sender: TUTcpLink; const Buf: PByte;
  const Len: Integer);
var
  pBuf: PByte;
begin
  OnReceive(Sender, Buf, Len);

  if Assigned(OnReceiveInThreadEvt) then
    OnReceiveInThreadEvt(Sender, Buf, Len);
  if Assigned(OnReceiveEvt) then
  begin
    GetMem(Pointer(pBuf), Len + sizeof(Integer));
    PInteger(pBuf)^ := Len;
    CopyMemory(PByte(Integer(pBuf) + sizeof(Integer)), Buf, Len);
    if not PostMsgToOwner(WM_UTCP_RECEIVE, DWord(pBuf), DWord(Sender)) then
      FreeMem(Pointer(pBuf));
  end;
end;

procedure TUTcpServer.DoOpen();
  function Bind(): Boolean;
  var
    Addr: TSockAddrIn;
  begin
    PostMsg(Self, '正在绑定端口......');
    Result := False;
    try
      Addr := GetSocketAddr(FLocalIP, FLocalPort);
      if UWinSock2.Bind(FSocket, @Addr, SizeOf(TSockAddrIn)) = SOCKET_ERROR then
      begin
        DoError(Self, '套接口绑定错误：' + GetErrorMsg(WSAGetLastError()));
      end else
      begin
        Result := True;
      end;
    except
      DoError(Self, '套接口绑定：' + GetErrorMsg(WSAGetLastError()));
    end;
  end;
begin
  inherited;

  if (FSocket <> INVALID_SOCKET) and Bind() then
  try
    PostMsg(Self, '正在监听端口......');
    if UWinSock2.Listen(FSocket, FMaxLinks) <> SOCKET_ERROR then
    begin
      FTickCountAutoOpen := 0;
      DoActive();
    end else
    begin
      DoError(Self, '套接口监听错误：' + GetErrorMsg(WSAGetLastError()));
      DoClose();
    end;
  except
    DoError(Self, '套接口监听异常：' + GetErrorMsg(WSAGetLastError()));
    DoClose();
  end;
end;

procedure TUTcpServer.DoClose();
  procedure CloseLink();
  begin
    FLinks.Lock();
    try
      while FLinks.Count > 0 do
      begin
        with TUTcpLink(FLinks.Items[0]) do
        begin
          FServer := nil;
          Destroy();
        end;
        FLinks.Delete(0);
      end;
    finally
      FLinks.Unlock();
    end;
  end;
begin
  CloseLink();
    
  inherited;

  if FAutoOpenTime <> 0 then
    FTickCountAutoOpen := GetTickCount();
end;

procedure TUTcpServer.DoError(Sender: TUTcp; ErrorMsg: String);
begin
  if Assigned(onErrorEvt) then
    PostMsgToOwner(Sender, WM_UTCP_ERROR, ErrorMsg);
end;

procedure TUTcpServer.DoConnect(const Sender: TUTcpLink);
begin
  FLinks.Add(Sender);
  PostMsg(Sender, Format('远程客户连接（%s：%d）', [Sender.RemoteIP, Sender.RemotePort]));
  if Assigned(OnConnectEvt) then
    PostMsgToOwner(WM_UTCP_CONNECT, 0, DWord(Sender));
end;

procedure TUTcpServer.DoDisconnect(const Sender: TUTcpLink);
begin
  FLinks.Delete(Sender);
  PostMsg(Sender, Format('远程客户断开（%s：%d）', [Sender.RemoteIP, Sender.RemotePort]));
  if Assigned(OnDisconnectEvt) then
    PostMsgToOwner(WM_UTCP_DISCONNECT, 0, DWord(Sender));
end;

procedure TUTcpServer.Close();
  procedure CloseReady();
  begin
    FReadys.Lock();
    try
      while FReadys.Count > 0 do
      begin
        with TUTcpLink(FReadys.Items[0]) do
        begin
          FServer := nil;
          Destroy();
        end;
        FReadys.Delete(0);
      end;
    finally
      FReadys.Unlock();
    end;
  end;
var
  Save: Boolean;
begin
  Save := Active;
  DoClose();
  FTickCountAutoOpen := 0;
  CloseReady();
  if Save and Assigned(OnCloseEvt) then
    PostMsgToOwner(WM_UTCP_CLOSE, 0, 0);
end;

procedure TUTcpServer.Open();
begin
  DoOpen();
  if (FSocket <> INVALID_SOCKET) and Assigned(OnOpenEvt) then
    PostMsgToOwner(WM_UTCP_OPEN, 0, 0);
end;

procedure TUTcpServer.OnMsgProc(var Msg: TMessage);
begin
  try
    OnWndMsg(Msg);
  except
  end;
end;

procedure TUTcpServer.OnWndMsg(var Msg: TMessage);
var
  p: PChar;
begin
  with Msg do
  case Msg of
    WM_UTCP_MESSAGE:
    begin
      p := PChar(wParam);
      try
        if FHWnd <> 0 then
          OnMessageEvt(TUTcp(lParam), P);
      finally
        FreeMem(Pointer(p));
      end;
    end;
    WM_UTCP_OPEN:
      if FHWnd <> 0 then
        OnOpenEvt(Self);
    WM_UTCP_CLOSE:
      if FHWnd <> 0 then
        OnCloseEvt(Self);
    WM_UTCP_CONNECT:
      if FHWnd <> 0 then
        OnConnectEvt(TUTcpLink(lParam));
    WM_UTCP_DISCONNECT:
      if FHWnd <> 0 then
        OnDisconnectEvt(TUTcpLink(lParam));
    WM_UTCP_RECEIVE:
      if FHWnd <> 0 then
        OnReceiveEvt(TUTcpLink(lParam), PByte(wParam + sizeof(Integer)), PInteger(wParam)^);
    WM_UTCP_ERROR:
    begin
      p := PChar(wParam);
      try
        if FHWnd <> 0 then
          onErrorEvt(TUTcp(lParam), p);
      finally
        FreeMem(Pointer(p));
      end;
    end;
  end;
end;

function TUTcpServer.PostMsgToOwner(Msg, wParam, lParam: DWord): Boolean;
begin
  Result := FHWnd <> 0;
  if Result then
    PostMessage(FHWnd, Msg, wParam, lParam);
end;

function TUTcpServer.PostMsgToOwner(Sender: TUTcp; Msg: DWord; StrMsg: String): Boolean;
var
  pMsg: PChar;
begin
  GetMem(Pointer(pMsg), Length(StrMsg) + 1);
  StrPCopy(pMsg, StrMsg);
  Result := PostMsgToOwner(Msg, DWord(pMsg), DWord(Sender));
  if not Result then
    FreeMem(Pointer(pMsg));
end;

procedure TUTcpServer.PostMsg(Sender: TUTcp; Msg: String);
begin
  if Assigned(OnMessageEvt) then
    PostMsgToOwner(Sender, WM_UTCP_MESSAGE, Msg);
end;

procedure TUTcpServer.OnThreadSocketEvent(const NWE: PWSANETWORKEVENTS);
var
  Link: TUTcpLink;
  AcceptSocket: TSocket;
  Addr: TSockAddrIn;
  Len: Integer;
begin
  with NWE^ do
  try
    if (DWord(lNetworkEvents) and FD_ACCEPT) = FD_ACCEPT then
    begin
      if iErrorCode[FD_ACCEPT_BIT] <> 0 then
      begin
        DoError(Self, '套接口接受连接错误：' + GetErrorMsg(iErrorCode[FD_ACCEPT_BIT]));
        DoClose();
      end else
      begin
        Len := SizeOf(TSockAddrIn);
        AcceptSocket := Accept(FSocket, @Addr, Len);
        if (AcceptSocket <> INVALID_SOCKET) then
        begin
          Link := GetReadyLink();
          with Link do
          begin
            FServer := Self;
            FSocket := AcceptSocket;
            FRemoteIP := inet_ntoa(Addr.sin_addr);
            FRemotePort := Addr.sin_port;
            FSizeRevcBuf := Self.FSizeRevcBuf;
            FSizeSocketRevcBuf := Self.FSizeSocketRevcBuf;
            FSizeSocketSendBuf := Self.FSizeSocketSendBuf;
            DoActive();
            Link.Resume();
          end;
        end else
        begin
          DoError(Self, '套接口接受连接错误：' + GetErrorMsg(iErrorCode[FD_ACCEPT_BIT]));
          DoClose();
        end;
      end;
    end;
  except
  end;
end;

function TUTcpServer.GetLinkCount(): Integer;
begin
  Result := FLinks.Count;
end;

function TUTcpServer.Send(const Buf: PByte; const Len: Integer): Boolean;
var
  i: Integer;
begin
  FLinks.Lock();
  Result := FLinks.Count > 0;
  try
    for i := 0 to FLinks.Count - 1 do
      TUTcpLink(FLinks.Items[i]).Send(Buf, Len);
  finally
    FLinks.Unlock();
  end;
end;

function TUTcpServer.SendTo(const Link: TUTcpLink; const Buf: PByte;
  const Len: Integer): Boolean;
begin
  FLinks.Lock();
  Result := FLinks.IndexOf(Link) <> - 1;
  try
    if Result then
      Link.Send(Buf, Len);
  finally
    FLinks.Unlock();
  end;
end;

function TUTcpServer.GetLink(Index: Integer): TUTcpLink;
begin
  Result := TUTcpLink(FLinks.Items[Index]);
end;

procedure TUTcpServer.DeleteLink(Link: TUTcpLink);
begin
  FLinks.Delete(Link);
end;

{ TUTcpClient }

constructor TUTcpClient.Create();
begin
  FTickCountAutoConnect := 0;
  FHWnd := AllocateHWnd(OnMsgProc);
  FAutoConnectTime := 5;
  FConnected := False;

  inherited;
end;

destructor TUTcpClient.Destroy();
begin
  FHWnd := 0;
  DoClose();
  
  inherited;
  DeallocateHWnd(FHWnd);
end;

procedure TUTcpClient.Open();
begin
  DoOpen();

  if (FSocket <> INVALID_SOCKET) and Assigned(OnOpenEvt) then
    PostMsgToOwner(WM_UTCP_OPEN, 0, 0);
end;

procedure TUTcpClient.Close();
var
  Save: Boolean;
begin
  Save := Active;
  DoClose();
  DoDisconnect();
  FTickCountAutoConnect := 0;
  if Save and Assigned(OnCloseEvt) then
    PostMsgToOwner(WM_UTCP_CLOSE, 0, 0);
end;

procedure TUTcpClient.CheckAutoConnect();
begin
  if (FTickCountAutoConnect <> 0) and (FAutoConnectTime <> 0) and
     (DecTickCount(FTickCountAutoConnect, GetTickCount()) > DWord(FAutoConnectTime * 1000)) then
  begin
    FTickCountAutoConnect := GetTickCount();
    DoOpen();
  end;
end;

procedure TUTcpClient.DoError(Sender: TUTcp; ErrorMsg: String);
begin
  if Assigned(onErrorEvt) then
    PostMsgToOwner(Sender, WM_UTCP_ERROR, ErrorMsg);
end;

procedure TUTcpClient.DoOpen();
var
  Addr: TSockAddrIn;
begin
  DoClose();

  inherited;

  if (FSocket <> INVALID_SOCKET) then
  try
    Addr := GetSocketAddr(FRemoteIP, FRemotePort);
    PostMsg('正在连接服务器......');
    connect(FSocket, @Addr, Sizeof(TSockAddrIn));
    DoActive();
  except
    DoError(Self, '套接口远程连接异常：' + GetErrorMsg(WSAGetLastError()));
  end;
end;

procedure TUTcpClient.DoClose();
begin
  FConnected := False;
  inherited;
end;

procedure TUTcpClient.DoConnect();
begin
  FTickCountAutoConnect := 0;
  if Assigned(OnconnectEvt) then
    PostMsgToOwner(WM_UTCP_CONNECT, 0, 0);
end;

procedure TUTcpClient.DoDisconnect();
begin
  FConnected := False;
  
  if FAutoConnectTime <> 0 then
    FTickCountAutoConnect := GetTickCount();
    
  if Assigned(OnDisconnectEvt) then
    PostMsgToOwner(WM_UTCP_DISCONNECT, 0, 0);
end;

procedure TUTcpClient.DoReceive(const Buf: PByte; const Len: Integer);
var
  pBuf: PByte;
begin
  OnReceive(Buf, Len);

  if Assigned(OnReceiveInThreadEvt) then
    OnReceiveInThreadEvt(Self, Buf, Len);
  if Assigned(OnReceiveEvt) then
  begin
    GetMem(Pointer(pBuf), Len);
    CopyMemory(pBuf, Buf, Len);
    if not PostMsgToOwner(WM_UTCP_RECEIVE, DWord(pBuf), DWord(Len)) then
      FreeMem(Pointer(pBuf));
  end;
end;

procedure TUTcpClient.OnMsgProc(var Msg: TMessage);
begin
  try
    OnWndMsg(Msg);
  except
  end;
end;

procedure TUTcpClient.OnWndMsg(var Msg: TMessage);
var
  p: PChar;
begin
  with Msg do
  case Msg of
    WM_UTCP_MESSAGE:
    begin
      p := PChar(wParam);
      try
        if FHWnd <> 0 then
          OnMessageEvt(Self, P);
      finally
        FreeMem(Pointer(p));
      end;
    end;
    WM_UTCP_OPEN:
      if FHWnd <> 0 then
        OnOpenEvt(Self);
    WM_UTCP_CLOSE:
      if FHWnd <> 0 then
        OnCloseEvt(Self);
    WM_UTCP_CONNECT:
      if FHWnd <> 0 then
        OnConnectEvt(Self);
    WM_UTCP_DISCONNECT:
      if FHWnd <> 0 then
        OnDisconnectEvt(Self);
    WM_UTCP_RECEIVE:
      if FHWnd <> 0 then
        OnReceiveEvt(Self, PByte(wParam), Integer(lParam));
    WM_UTCP_ERROR:
    begin
      p := PChar(wParam);
      try
        if FHWnd <> 0 then
          onErrorEvt(Self, p);
      finally
        FreeMem(Pointer(p));
      end;
    end;
  end;
end;

function TUTcpClient.PostMsgToOwner(Msg, wParam, lParam: DWord): Boolean;
begin
  Result := FHWnd <> 0;
  if Result then
    PostMessage(FHWnd, Msg, wParam, lParam);
end;

function TUTcpClient.PostMsgToOwner(Sender: TUTcp; Msg: DWord; StrMsg: String): Boolean;
var
  pMsg: PChar;
begin
  GetMem(Pointer(pMsg), Length(StrMsg) + 1);
  StrPCopy(pMsg, StrMsg);
  Result := PostMsgToOwner(Msg, DWord(pMsg), DWord(Sender));
  if not Result then
    FreeMem(Pointer(pMsg));
end;

procedure TUTcpClient.PostMsg(Msg: String);
begin
  if Assigned(OnMessageEvt) then
    PostMsgToOwner(Self, WM_UTCP_MESSAGE, Msg);
end;

procedure TUTcpClient.OnExecute();
begin
  inherited;
  CheckAutoConnect();
end;

initialization
  Startup;

finalization
  Cleanup;

end.