1,593
社区成员
发帖
与我相关
我的任务
分享
unit ServerSocketLite;
{******************************************************************************}
{ Unit Name : ServerSocketLite.pas }
{ Author : RedFox /Foxbat CopyRight (c) }
{ E-mail : foxbat123@126.com }
{ 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 }
{******************************************************************************}
interface
uses
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 TForm1.Button1Click(Sender: TObject);
var
TestServe: TTcpServerLite;
WsaData: TWSADATA;
begin
if WSAStartup(MAKEWORD(2, 2), WsaData) <> 0 then
begin
WSACleanup;
Exit;
end;
TestServe := TTcpServerLite.Create;
TestServe.Open(1002);
end;
// 发送端
procedure TForm1.Button2Click(Sender: TObject);
var
TestClient: TTcpClientLite;
ListenSocket: TSocket;
Addr: TSockAddr;
I, Len: Integer;
S: array[0..24] of Char;
WsaData: TWSADATA;
begin
if WSAStartup(MAKEWORD(2, 2), WsaData) <> 0 then
begin
WSACleanup;
Exit;
end;
ListenSocket := WSASocket(AF_INET, SOCK_STREAM, 0, nil, 0, WSA_FLAG_OVERLAPPED);
if ListenSocket = INVALID_SOCKET then
begin
ShowMessage(SysErrorMessage(WSAGetLastError));
Exit;
end;
addr.sin_family := AF_INET;
addr.sin_addr.s_addr := inet_addr('127.0.0.1');
addr.sin_port := htons(1002);
Len := SizeOf(TSockAddr);
S := 'Testddd';
TestClient := TTcpClientLite.Create(ListenSocket, addr);
connect(ListenSocket, PSockAddr(@addr), len);
Winsock2.send(ListenSocket, S, Length('Testddd') + 1, 0);
end;
楼主的服务端在FD_Read 进入了死循环
不知道是否是我使用有问题
另外TLIST建议换成哈希,
另外还建议发送和收发包加算法,防止粘包