这里有一个fox1999发过的WSAEventSelect的server类
关于Delphi的WSAEventSelect例子实在是难找,再加上我太菜,拭了试不太会用
能不能帮我讲一讲怎么使用这个类呢? 写成例子当然更好
我会快速结帖的!
先谢谢了,下面是这个类的代码:
unit ServerSocketLite;{******************************************************************************}
{ Unit Name : ServerSocketLite.pas }
{ Author : RedFox /Foxbat CopyRight (c) }
{ E-mail : [email protected] }
{ Blog : redsoft.yculblog.com }
{ Baidu Hi : redfox_hi }
{ Datetime : 2008-05-03 }
{ Version : v1.1 }
{ Description : ServerSocket Class Lite }
{ }
{ History List }
{ 1. 2008-05-03 Version 1.0 }
{ 2. 2008-07-06 Version 1.1 }
{******************************************************************************}interfaceuses
Windows, Messages, WinSock2, SysUtils, Classes;type
{====================== TTcpServerLite forward define ======================}
TTcpServerLite = class; {===================== TTcpClientLite =======================================}
TTcpClientLite = class
protected
m_socket : TSocket;
m_saddr : TSockAddr;
m_serv : TTcpServerLite;
m_csSend : TRTLCriticalSection;
m_PeerIp : string;
m_PeerPort : Word;
m_Closing : Boolean;
public
constructor Create(hsocket : TSocket; saddr : TSockAddr); virtual;
destructor Destroy; override; procedure Close; virtual;
property Server: TTcpServerLite read m_serv;
function Send(Buf: Pointer; BufLen :Integer): Boolean;
end; {==================== Event Define ==========================================}
TClientCloseEvent = procedure(Sender: TObject; Client: TTcpClientLite) of object;
TClientConnectEvent = procedure(Sender: TObject; Client: TTcpClientLite) of object;
TClientRecvEvent = procedure(Sender: TObject; Client: TTcpClientLite) of object; TTcpClientLiteClass = class of TTcpClientLite; {======================== TTcpServerLite ====================================}
TTcpServerLite = class
protected
m_hWnd : HWND;
m_ListenSocket : TSocket;
m_Clients : TList;
m_ClientLock : TRTLCriticalSection;
m_Port : Word; fOnClientClose : TClientCloseEvent;
fOnClientConnect : TClientConnectEvent;
fOnClientRecv : TClientRecvEvent;
function getActive: Boolean;
protected
TcpClientClass : TTcpClientLiteClass;
function NewClient(hClient: TSocket; saddr : TSockAddr):Boolean;
function GetClient(hClient: TSocket): TTcpClientLite;
procedure DelClient(sckt: TTcpClientLite);
procedure DoClientClose(Client: TTcpClientLite); virtual;
procedure DoClientConnect(Client: TTcpClientLite);
procedure DoClientRecv(Client: TTcpClientLite); virtual; procedure WndProc(var msg: TMessage);
public
constructor Create;
destructor Destroy; override; function Open(nPort: Word):Boolean;
procedure Close();
property Active :Boolean read getActive;
property Clients:TList read m_Clients;
property OnClientClose: TClientCloseEvent read fOnClientClose write fOnClientClose;
property OnClientRecv : TClientRecvEvent read fOnClientRecv write fOnClientRecv;
property OnClientConnect: TClientConnectEvent read fOnClientConnect write fOnClientConnect;
end; implementation const
WM_SOCKET = WM_APP + 1;{=========================== TTcpClientLite ==================================}//--------------------------------------------------------------------------
// Close TcpClientLite Connection
procedure TTcpClientLite.Close;
begin
if (not m_Closing) then
begin
shutdown(m_socket, SD_BOTH);
closesocket(m_socket);
m_Closing := true;
end;
end;//-------------------------------------------------------------------------
// Create New TcpClientLite Object
// hsocket : socket handler
// saddr : Peer Socket Address
// return : New TcpClientLite Created
constructor TTcpClientLite.Create(hsocket: TSocket; saddr : TSockAddr);
begin
m_socket := hsocket;
m_saddr := saddr;
m_PeerIp := inet_ntoa(saddr.sin_addr);
m_PeerPort:= ntohs(saddr.sin_port);
m_Closing := False;
InitializeCriticalSection(m_csSend);
inherited Create();
end;destructor TTcpClientLite.Destroy;
begin
Close;
DeleteCriticalSection(m_csSend);
inherited;
end;//-----------------------------------------------------------------------
// Send Data from TcpClientLite to Peer, Thread safed
// Buf : Data Pointer for send
// BufLen : Data length want to send
// return : true -- Success
function TTcpClientLite.Send(Buf: Pointer; BufLen: Integer): Boolean;
var
nSend : Integer;
pData : PChar;
begin EnterCriticalSection(m_csSend);
pData := Buf;
try
while BufLen > 0 do
begin
nSend := WinSock2.send(m_socket, pData^, BufLen, 0); if (nSend = SOCKET_ERROR) then
begin
if (WSAGetLastError() = WSAEWOULDBLOCK) then
begin
Sleep(5);
Continue;
end
else begin
Result := False;
m_Closing := True;
Exit;
end;
end;
Inc(pData, nSend); Dec(BufLen, nSend);
end;
Result := true;
finally
LeaveCriticalSection(m_csSend);
end;
end;
procedure TTcpServerLite.Close;
var
i : Integer;
sckt: TTcpClientLite;
begin
if not Active then Exit; WSAAsyncSelect(m_ListenSocket, m_hWnd, WM_SOCKET, 0);
shutdown(m_ListenSocket, SD_BOTH);
closesocket(m_ListenSocket);
m_ListenSocket := INVALID_SOCKET; // Clear Client List
EnterCriticalSection(m_ClientLock);
try
for i := 0 to m_Clients.Count -1 do
begin
sckt := TTcpClientLite(m_Clients.Items[i]);
WSAAsyncSelect(sckt.m_socket, m_hWnd, WM_SOCKET, 0);
sckt.Close;
DoClientClose(sckt);
sckt.Free;
end; m_Clients.Clear;
finally
LeaveCriticalSection(m_ClientLock);
end;
end;
constructor TTcpServerLite.Create;
var
wsData : TWSAData;
begin
ZeroMemory(@wsData, SizeOf(TWSAData));
WSAStartup(2, wsData);
m_ListenSocket := INVALID_SOCKET; m_Clients := TList.Create;
InitializeCriticalSection(m_ClientLock); TcpClientClass := TTcpClientLite; m_hWnd := AllocateHWnd(WndProc);
inherited Create;
end;procedure TTcpServerLite.DelClient(sckt: TTcpClientLite);
begin
EnterCriticalSection(m_ClientLock);
try
m_Clients.Remove(sckt);
sckt.Free;
finally
LeaveCriticalSection(m_ClientLock);
end;
end;destructor TTcpServerLite.Destroy;
begin
Close;
m_Clients.Free;
DeleteCriticalSection(m_ClientLock); DeallocateHWnd(m_hWnd);
WSACleanup;
inherited;
end;
关于Delphi的WSAEventSelect例子实在是难找,再加上我太菜,拭了试不太会用
能不能帮我讲一讲怎么使用这个类呢? 写成例子当然更好
我会快速结帖的!
先谢谢了,下面是这个类的代码:
unit ServerSocketLite;{******************************************************************************}
{ Unit Name : ServerSocketLite.pas }
{ Author : RedFox /Foxbat CopyRight (c) }
{ E-mail : [email protected] }
{ Blog : redsoft.yculblog.com }
{ Baidu Hi : redfox_hi }
{ Datetime : 2008-05-03 }
{ Version : v1.1 }
{ Description : ServerSocket Class Lite }
{ }
{ History List }
{ 1. 2008-05-03 Version 1.0 }
{ 2. 2008-07-06 Version 1.1 }
{******************************************************************************}interfaceuses
Windows, Messages, WinSock2, SysUtils, Classes;type
{====================== TTcpServerLite forward define ======================}
TTcpServerLite = class; {===================== TTcpClientLite =======================================}
TTcpClientLite = class
protected
m_socket : TSocket;
m_saddr : TSockAddr;
m_serv : TTcpServerLite;
m_csSend : TRTLCriticalSection;
m_PeerIp : string;
m_PeerPort : Word;
m_Closing : Boolean;
public
constructor Create(hsocket : TSocket; saddr : TSockAddr); virtual;
destructor Destroy; override; procedure Close; virtual;
property Server: TTcpServerLite read m_serv;
function Send(Buf: Pointer; BufLen :Integer): Boolean;
end; {==================== Event Define ==========================================}
TClientCloseEvent = procedure(Sender: TObject; Client: TTcpClientLite) of object;
TClientConnectEvent = procedure(Sender: TObject; Client: TTcpClientLite) of object;
TClientRecvEvent = procedure(Sender: TObject; Client: TTcpClientLite) of object; TTcpClientLiteClass = class of TTcpClientLite; {======================== TTcpServerLite ====================================}
TTcpServerLite = class
protected
m_hWnd : HWND;
m_ListenSocket : TSocket;
m_Clients : TList;
m_ClientLock : TRTLCriticalSection;
m_Port : Word; fOnClientClose : TClientCloseEvent;
fOnClientConnect : TClientConnectEvent;
fOnClientRecv : TClientRecvEvent;
function getActive: Boolean;
protected
TcpClientClass : TTcpClientLiteClass;
function NewClient(hClient: TSocket; saddr : TSockAddr):Boolean;
function GetClient(hClient: TSocket): TTcpClientLite;
procedure DelClient(sckt: TTcpClientLite);
procedure DoClientClose(Client: TTcpClientLite); virtual;
procedure DoClientConnect(Client: TTcpClientLite);
procedure DoClientRecv(Client: TTcpClientLite); virtual; procedure WndProc(var msg: TMessage);
public
constructor Create;
destructor Destroy; override; function Open(nPort: Word):Boolean;
procedure Close();
property Active :Boolean read getActive;
property Clients:TList read m_Clients;
property OnClientClose: TClientCloseEvent read fOnClientClose write fOnClientClose;
property OnClientRecv : TClientRecvEvent read fOnClientRecv write fOnClientRecv;
property OnClientConnect: TClientConnectEvent read fOnClientConnect write fOnClientConnect;
end; implementation const
WM_SOCKET = WM_APP + 1;{=========================== TTcpClientLite ==================================}//--------------------------------------------------------------------------
// Close TcpClientLite Connection
procedure TTcpClientLite.Close;
begin
if (not m_Closing) then
begin
shutdown(m_socket, SD_BOTH);
closesocket(m_socket);
m_Closing := true;
end;
end;//-------------------------------------------------------------------------
// Create New TcpClientLite Object
// hsocket : socket handler
// saddr : Peer Socket Address
// return : New TcpClientLite Created
constructor TTcpClientLite.Create(hsocket: TSocket; saddr : TSockAddr);
begin
m_socket := hsocket;
m_saddr := saddr;
m_PeerIp := inet_ntoa(saddr.sin_addr);
m_PeerPort:= ntohs(saddr.sin_port);
m_Closing := False;
InitializeCriticalSection(m_csSend);
inherited Create();
end;destructor TTcpClientLite.Destroy;
begin
Close;
DeleteCriticalSection(m_csSend);
inherited;
end;//-----------------------------------------------------------------------
// Send Data from TcpClientLite to Peer, Thread safed
// Buf : Data Pointer for send
// BufLen : Data length want to send
// return : true -- Success
function TTcpClientLite.Send(Buf: Pointer; BufLen: Integer): Boolean;
var
nSend : Integer;
pData : PChar;
begin EnterCriticalSection(m_csSend);
pData := Buf;
try
while BufLen > 0 do
begin
nSend := WinSock2.send(m_socket, pData^, BufLen, 0); if (nSend = SOCKET_ERROR) then
begin
if (WSAGetLastError() = WSAEWOULDBLOCK) then
begin
Sleep(5);
Continue;
end
else begin
Result := False;
m_Closing := True;
Exit;
end;
end;
Inc(pData, nSend); Dec(BufLen, nSend);
end;
Result := true;
finally
LeaveCriticalSection(m_csSend);
end;
end;
procedure TTcpServerLite.Close;
var
i : Integer;
sckt: TTcpClientLite;
begin
if not Active then Exit; WSAAsyncSelect(m_ListenSocket, m_hWnd, WM_SOCKET, 0);
shutdown(m_ListenSocket, SD_BOTH);
closesocket(m_ListenSocket);
m_ListenSocket := INVALID_SOCKET; // Clear Client List
EnterCriticalSection(m_ClientLock);
try
for i := 0 to m_Clients.Count -1 do
begin
sckt := TTcpClientLite(m_Clients.Items[i]);
WSAAsyncSelect(sckt.m_socket, m_hWnd, WM_SOCKET, 0);
sckt.Close;
DoClientClose(sckt);
sckt.Free;
end; m_Clients.Clear;
finally
LeaveCriticalSection(m_ClientLock);
end;
end;
constructor TTcpServerLite.Create;
var
wsData : TWSAData;
begin
ZeroMemory(@wsData, SizeOf(TWSAData));
WSAStartup(2, wsData);
m_ListenSocket := INVALID_SOCKET; m_Clients := TList.Create;
InitializeCriticalSection(m_ClientLock); TcpClientClass := TTcpClientLite; m_hWnd := AllocateHWnd(WndProc);
inherited Create;
end;procedure TTcpServerLite.DelClient(sckt: TTcpClientLite);
begin
EnterCriticalSection(m_ClientLock);
try
m_Clients.Remove(sckt);
sckt.Free;
finally
LeaveCriticalSection(m_ClientLock);
end;
end;destructor TTcpServerLite.Destroy;
begin
Close;
m_Clients.Free;
DeleteCriticalSection(m_ClientLock); DeallocateHWnd(m_hWnd);
WSACleanup;
inherited;
end;
解决方案 »
- 如何修改一个delphi 6 编写的程序中的数据库连接字符串
- PerlRegEx对中文支持不行啊,
- 在stringgrid中如何修改数据库数据并提交
- 我在执行时,发现数据库插入了数据,但是出现错误
- 如何使用Delphi实现对“服务”的重新启动(象Officescan,SQL Server的服务)
- 有关输出到文本再输出到LPT1端口的问题(AssignFile(F, OutFile);)
- “多步ole db操作产生错误,请检查每个OLE DB状态值”---是怎么回事?
- Delphi中如何获取"计算机唯一标识"?
- 关于delphi若干个问题的补充
- 如何存取图片到sql server图片格式最好是jpg的。
- 找DELPHI老师
- 请问如何将数据中数据导入excel,并根据某一字段合并单元格。
begin
if Assigned(fOnClientClose) then
fOnClientClose(self, Client);end;procedure TTcpServerLite.DoClientConnect(Client: TTcpClientLite);
begin
if Assigned(fOnClientConnect) then
fOnClientConnect(self, Client);
end;procedure TTcpServerLite.DoClientRecv(Client: TTcpClientLite);
begin
if Assigned(fOnClientRecv) then
fOnClientRecv(Self, Client);
end;function TTcpServerLite.getActive: Boolean;
begin
Result := m_ListenSocket <> INVALID_SOCKET;
end;//--------------------------------------------------------------------
// Find Client Object from ClientList by Socket Handle
// hClient : Client Object Socket Handle
// return : Client Object maybe null
function TTcpServerLite.GetClient(hClient: TSocket): TTcpClientLite;
var
i : Integer;
sckt: TTcpClientLite;
begin
Result := nil;
EnterCriticalSection(m_ClientLock);
try
for i := 0 to m_Clients.Count -1 do
begin
sckt := TTcpClientLite(m_Clients[i]);
if (sckt <> nil) and (sckt.m_socket = hClient) then
begin
Result := sckt;
Exit;
end;
end;
finally
LeaveCriticalSection(m_ClientLock);
end;
end;
//-----------------------------------------------------------------
// Create New Client Object and add to ClientList
//
function TTcpServerLite.NewClient(hClient: TSocket; saddr: TSockAddr):Boolean;
var
Client : TTcpClientLite;
begin
Result := false;
Client := TcpClientClass.Create(hClient, saddr);
Client.m_serv := Self;
EnterCriticalSection(m_ClientLock);
try
m_Clients.Add(Client);
finally
LeaveCriticalSection(m_ClientLock);
end; DoClientConnect(Client);
WSAAsyncSelect(Client.m_socket, m_hWnd, WM_SOCKET, FD_READ or FD_CLOSE);
Result := True;
end;//----------------------------------------------------------------------
// Open Tcp Port to Listen
// nPort : Listen Port, if nPort = 0 then Randmoze Port
//
function TTcpServerLite.Open(nPort : Word): Boolean;
var
saddr : TSockAddr;
nameLen : Integer;
begin
Result := False;
if Active then Close; m_ListenSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); if m_ListenSocket = INVALID_SOCKET then
begin
OutputDebugString('TTcpServerLite.Open: socket error!!!');
Exit;
end; ZeroMemory(@saddr, SizeOf(TSockAddr));
saddr.sin_family := AF_INET;
saddr.sin_port := htons(nPort); if bind(m_ListenSocket, @saddr, SizeOf(TSockAddr)) = SOCKET_ERROR then
begin
OutputDebugString('TTcpServerLite.Open: bind error!!!');
Exit;
end; if listen(m_ListenSocket, 5) = SOCKET_ERROR then
begin
OutputDebugString('TTcpServerLite.Open: listen error!!!');
Exit;
end; if nPort = 0 then
begin
getsockname(m_ListenSocket, saddr, nameLen);
m_Port := ntohs(saddr.sin_port);
end
else
m_Port := nPort; WSAAsyncSelect(m_ListenSocket, m_hWnd, WM_SOCKET, FD_ACCEPT); Result := True;
end;
//-------------------------------------------------------------------
// Socket Message Process
//
procedure TTcpServerLite.WndProc(var msg: TMessage);
var
sckt : TTcpClientLite;
nErr : Word;
nEvt : Word;
saddr : TSockAddrIn;
addrLen : Integer;
hClient : TSocket;
begin
case msg.Msg of
WM_SOCKET:
begin
nErr := HiWord(msg.LParam);
nEvt := loWord(msg.LParam); case nEvt of
FD_ACCEPT:
begin
ZeroMemory(@saddr, SizeOf(TSockAddrIn));
addrLen := SizeOf(TSockAddrIn);
if (nErr <> 0) then Exit;
hClient := accept(m_ListenSocket,saddr, addrLen);
if hClient <> INVALID_SOCKET then
begin
self.NewClient(hClient, saddr);
end;
end;
FD_READ:
begin
hClient := msg.WParam;
if nErr <> 0 then Exit;
sckt := GetClient(hClient);
WSAAsyncSelect(sckt.m_socket, m_hWnd, WM_SOCKET, 0);
//WSAAsyncSelect(sckt.m_socket, m_hWnd, WM_SOCKET,FD_WRITE or FD_CLOSE);
Self.DoClientRecv(sckt);
if sckt.m_Closing then
begin
DoClientClose(sckt);
DelClient(sckt);
end
else
WSAAsyncSelect(sckt.m_socket, m_hWnd, WM_SOCKET, FD_READ or FD_CLOSE);
end; FD_CLOSE:
begin
hClient := msg.WParam;
if nErr <> 0 then Exit;
sckt := GetClient(hClient);
WSAAsyncSelect(sckt.m_socket, m_hWnd, WM_SOCKET, 0);
sckt.Close;
Self.DoClientClose(sckt);
DelClient(sckt);
end;
end;
end;
else begin
msg.Result := DefWindowProc(m_hWnd, msg.Msg, msg.WParam, msg.LParam);
end;
end;
end;end.
需要往客户端发数据的话调用Clients[i].Send方法就行了。
请问Clients对象怎么建立的呢
比如, MyServer.OnClientConnect:=我的事件;
但是这个事件要求一个TTcpClientLite参数, 而我只建立了个MyServer对象,Clients对象该怎么建立呢?
比如:MyServer.Clients.Count 就是连上来的客户端的个数
算了,结帖