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.

posted @ 2012-09-20 14:07 马儿快跑阅读(2748) 评论(0) 编辑收藏举报

会员力量，点亮园子希望

刷新页面返回顶部

Delphi异步socket通讯组件

公告