Delphi异步socket通讯组件

2024-03-04 14:31•java•阅读 4292

一直很烦恼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;

{ 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;

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;

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;

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;

procedure TUTcp.CloseSocketEvent();

begin

if FSocketEvent <> 0 then

begin

WSACloseEvent(FSocketEvent);

FSocketEvent := 0;

end;

procedure TUTcp.Execute();

begin

while not Terminated do

begin

try

TickCountExec := GetTickCount();

OnExecute();

if Assigned(OnThreadExecuteEvt) then

OnThreadExecuteEvt(Self);

except

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;

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;

{ 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;

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;

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;

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;

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;

procedure TUTcpServer.CheckAutoOpen();

begin

if (FTickCountAutoOpen <> 0) and (FAutoOpenTime <> 0) and

(DecTickCount(FTickCountAutoOpen, GetTickCount()) > DWord(FAutoOpenTime * 1000)) then

begin

FTickCountAutoOpen := GetTickCount();

DoOpen();

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;

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;

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;

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;

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;

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;

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;

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;

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;

except

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;

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;

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;

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;

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;

procedure TUTcpClient.OnMsgProc(var Msg: TMessage);

begin

try

OnWndMsg(Msg);

except

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;

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;

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.

上一篇 »python运维开发之第八天，socket
下一篇 »HTML+CSS+JS，+Vue写一个通讯录组件

Delphi异步socket通讯组件

相关推荐

linux connect非阻塞

PHP异步调用实现方式

workerman是一个高性能的PHP socket服务器框架

unigui组件中client javascript delphi组件之间的操作

PHP socket Workerman实用的php框架

Erlang和PHP间的Socket通讯－01

基于/dev/shm的PHP缓存类

python中asyncore异步模块的实现