客服电话
APP下载
迪恩网络APP
随时随地掌握行业动态
官方微信
扫描二维码
关注迪恩网络微信公众号
|
在服务器端，创建线程池，对于每个客户连接对应一个独立的线程类，可以在线程内处理客户数据，并可以线程间采用同步机制交换数据，为通讯服务器的建立提供了技术实现的基础。
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.
|
2023-10-27
2022-08-15
2022-08-17
2022-09-23
2022-08-13
六六分期app的软件客服如何联系？不知道吗？加qq群【895510560】即可！标题：六六分期
今天小编告诉大家如何处理win10系统火狐flash插件总是崩溃的问题，可能很多用户都不知
今天小编告诉大家如何对win10系统删除桌面回收站图标进行设置，可能很多用户都不知道
今天小编告诉大家如何对win10系统电脑设置节能降温的设置方法，想必大家都遇到过需要
我们在使用xp系统的过程中,经常需要对xp系统无线网络安装向导设置进行设置，可能很多
今天小编告诉大家如何处理win7系统玩cf老是与主机连接不稳定的问题，可能很多用户都不
电脑对日常生活的重要性小编就不多说了，可是一旦碰到win7系统设置cf烟雾头的问题，很
我们在日常使用电脑的时候，有的小伙伴们可能在打开应用的时候会遇见提示应用程序无法
今天小编告诉大家如何对win7系统打开vcf文件进行设置，可能很多用户都不知道怎么对win
今天小编告诉大家如何对win10系统s4开启USB调试模式进行设置，可能很多用户都不知道怎
请发表评论