以下是本菜鸟做的一个改进的Socket控件，有兴趣的小侠可以down下玩玩，顺便提提意见。
unit MScktComp;
interface
uses SysUtils, Windows, Messages, Classes, WinSock, SyncObjs;
const
CM_SOCKETMESSAGE = WM_USER + $0001;
CM_DEFERFREE = WM_USER + $0002;
CM_LOOKUPCOMPLETE = WM_USER + $0003;
type
ESocketError = class(Exception);
TCMSocketMessage = record
Msg: Cardinal;
Socket: TSocket;
SelectEvent: Word;
SelectError: Word;
Result: Longint;
end;
TCMLookupComplete = record
Msg: Cardinal;
LookupHandle: THandle;
AsyncBufLen: Word;
AsyncError: Word;
Result: Longint;
end;
TCustomWinSocket = class;
TMCustomSocket = class;
TServerWinSocket = class;
TServerClientWinSocket = class;
// TConManageThread = class;
TServerType = (stNonBlocking);
TClientType = (ctNonBlocking);
TAsyncStyle = (asRead, asWrite, asOOB, asAccept, asConnect, asClose);
TAsyncStyles = set of TAsyncStyle;
TSocketEvent = (seLookup, seConnecting, seConnect, seDisconnect, seListen,
seAccept, seWrite, seRead);
TLookupState = (lsIdle, lsLookupAddress, lsLookupService);
TErrorEvent = (eeGeneral, eeSend, eeReceive, eeConnect, eeDisconnect, eeAccept);
TSocketEventEvent = procedure (Sender: TObject; Socket: TCustomWinSocket;
SocketEvent: TSocketEvent) of object;
TSocketErrorEvent = procedure (Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer) of object;
TGetSocketEvent = procedure (Sender: TObject; Socket: TSocket;
var ClientSocket: TServerClientWinSocket) of object;
TSocketNotifyEvent = procedure (Sender: TObject; Socket: TCustomWinSocket) of object;
TCustomWinSocket = class
private
FSocket: TSocket;
FConnected: Boolean;
FHandle: HWnd;
FAddr: TSockAddrIn;
FAsyncStyles: TASyncStyles;
FLookupState: TLookupState;
FLookupHandle: THandle;
FOnSocketEvent: TSocketEventEvent;
FOnErrorEvent: TSocketErrorEvent;
FSocketLock: TCriticalSection;
FGetHostData: Pointer;
FData: Pointer;
// Used during non-blocking host and service lookups
FService: string;
FPort: Word;
FClient: Boolean;
FQueueSize: Integer;
procedure WndProc(var Message: TMessage);
procedure CMLookupComplete(var Message: TCMLookupComplete); message CM_LOOKUPCOMPLETE;
procedure CMSocketMessage(var Message: TCMSocketMessage); message CM_SOCKETMESSAGE;
procedure CMDeferFree(var Message); message CM_DEFERFREE;
procedure DeferFree;
procedure DoSetAsyncStyles;
function GetHandle: HWnd;
function GetLocalHost: string;
function GetLocalAddress: string;
function GetLocalPort: Integer;
function GetRemoteHost: string;
function GetRemoteAddress: string;
function GetRemotePort: Integer;
function GetRemoteAddr: TSockAddrIn;
protected
procedure AsyncInitSocket(const Name, Address, Service: string; Port: Word;
QueueSize: Integer; Client: Boolean);
procedure DoOpen;
procedure DoListen(QueueSize: Integer);
function InitSocket(const Name, Address, Service: string; Port: Word;
Client: Boolean): TSockAddrIn;
procedure Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent); dynamic;
procedure Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer); dynamic;
procedure SetAsyncStyles(Value: TASyncStyles);
public
constructor Create(ASocket: TSocket);
destructor Destroy; override;
procedure Close;
procedure DefaultHandler(var Message); override;
procedure Lock;
procedure Unlock;
procedure Listen(const Name, Address, Service: string; Port: Word;
QueueSize: Integer; Block: Boolean = True);
procedure Open(const Name, Address, Service: string; Port: Word; Block: Boolean = True);
procedure Accept(Socket: TSocket); virtual;
procedure Connect(Socket: TSocket); virtual;
procedure Disconnect(Socket: TSocket); virtual;
procedure Read(Socket: TSocket); virtual;
procedure Write(Socket: TSocket); virtual;
function LookupName(const name: string): TInAddr;
function LookupService(const service: string): Integer;
function ReceiveLength: Integer;
function ReceiveBuf(var Buf; Count: Integer): Integer;
function ReceiveText: string;
function SendBuf(var Buf; Count: Integer): Integer;
function SendText(const S: string): Integer;
property LocalHost: string read GetLocalHost;
property LocalAddress: string read GetLocalAddress;
property LocalPort: Integer read GetLocalPort;
property RemoteHost: string read GetRemoteHost;
property RemoteAddress: string read GetRemoteAddress;
property RemotePort: Integer read GetRemotePort;
property RemoteAddr: TSockAddrIn read GetRemoteAddr;
property Connected: Boolean read FConnected;
property Addr: TSockAddrIn read FAddr;
property ASyncStyles: TAsyncStyles read FAsyncStyles write SetAsyncStyles;
property Handle: HWnd read GetHandle;
property SocketHandle: TSocket read FSocket;
property LookupState: TLookupState read FLookupState;
property OnSocketEvent: TSocketEventEvent read FOnSocketEvent write FOnSocketEvent;
property OnErrorEvent: TSocketErrorEvent read FOnErrorEvent write FOnErrorEvent;
property Data: Pointer read FData write FData;
end;
TClientWinSocket = class(TCustomWinSocket)
private
FClientType: TClientType;
protected
procedure SetClientType(Value: TClientType);
public
procedure Connect(Socket: TSocket); override;
property ClientType: TClientType read FClientType write SetClientType;
end;
TServerClientWinSocket = class(TCustomWinSocket)
private
FServerWinSocket: TServerWinSocket;
public
constructor Create(Socket: TSocket; ServerWinSocket: TServerWinSocket);
destructor Destroy; override;
property ServerWinSocket: TServerWinSocket read FServerWinSocket;
end;
file://***************************************************
// 定义一个接收线程
{TServerAcceptThread = class(TThread)
private
FServerSocket: TServerWinSocket;
public
constructor Create(CreateSuspended: Boolean; ASocket: TServerWinSocket);
destructor destroy ;override;
procedure Execute; override;
procedure Accept(socket:Tsocket);
property ServerSocket: TServerWinSocket read FServerSocket;
end;
file://****************************************************
file://*****************************************************
// 定义一个连接管理线程
{ConManageThread = class(TThread)
private
FClientSocket: TServerClientWinSocket;
FServerSocket: TServerWinSocket;
FException: Exception;
FEvent: TSimpleEvent;
FKeepInCache: Boolean;
FData: Pointer;
procedure HandleEvent(Sender: TObject; Socket: TCustomWinSocket;
SocketEvent: TSocketEvent);
procedure HandleError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure DoHandleException;
procedure DoRead;
procedure DoWrite;
protected
procedure DoTerminate; override;
procedure Execute; override;
procedure ClientExecute; virtual;
procedure Event(SocketEvent: TSocketEvent); virtual;
procedure Error(ErrorEvent: TErrorEvent; var ErrorCode: Integer); virtual;
procedure HandleException; virtual;
procedure ReActivate(ASocket: TServerClientWinSocket);
function StartConnect: Boolean;
function EndConnect: Boolean;
public
constructor Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket);
destructor Destroy; override;
property ClientSocket: TServerClientWinSocket read FClientSocket;
property ServerSocket: TServerWinSocket read FServerSocket;
property KeepInCache: Boolean read FKeepInCache write FKeepInCache;
property Data: Pointer read FData write FData;
end;}
file://*****************************************************
TServerWinsocket= class(TCustomWinSocket)
private
FServerType: TServerType;
FConnections: TList;
// FServerAcceptThread: TServerAcceptThread;
FListLock: TCriticalSection;
FOnGetSocket: TGetSocketEvent;
FOnClientConnect: TSocketNotifyEvent;
FOnClientDisconnect: TSocketNotifyEvent;
FOnClientRead: TSocketNotifyEvent;
FOnClientWrite: TSocketNotifyEvent;
FOnClientError: TSocketErrorEvent;
procedure AddClient(AClient: TServerClientWinSocket);//向TLIST添加连接
procedure RemoveClient(AClient: TServerClientWinSocket);
procedure ClientEvent(Sender: TObject; Socket: TCustomWinSocket;
SocketEvent: TSocketEvent);//响应客户SOCKET事件
procedure ClientError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
function GetActiveConnections: Integer; file://获取连接数
function GetConnections(Index: Integer): TCustomWinSocket;//获取指定连接
protected
// procedure Accept(Socket: TSocket); override;
procedure SetServerType(Value: TServerType);
function GetClientSocket(Socket: TSocket): TServerClientWinSocket; dynamic;
procedure ClientRead(Socket: TCustomWinSocket); dynamic;
procedure ClientWrite(Socket: TCustomWinSOcket); dynamic;
procedure ClientConnect(Socket: TCustomWinSOcket); dynamic;
procedure ClientDisconnect(Socket: TCustomWinSOcket); dynamic;
procedure ClientErrorEvent(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer); dynamic;
public
constructor Create(ASocket: TSocket);
destructor Destroy; override;
procedure Listen(var Name, Address, Service: string; Port: Word;
QueueSize: Integer);
procedure Accept(Socket:TSocket);override;
property ActiveConnections: Integer read GetActiveConnections;
property Connections[Index: Integer]: TCustomWinSocket read GetConnections;
property ServerType: TServerType read FServerType write SetServerType;
property OnGetSocket: TGetSocketEvent read FOnGetSocket write FOnGetSocket;
property OnClientConnect: TSocketNotifyEvent read FOnClientConnect write FOnClientConnect;
property OnClientDisconnect: TSocketNotifyEvent read FOnClientDisconnect write FOnClientDisconnect;
property OnClientRead: TSocketNotifyEvent read FOnClientRead write FOnClientRead;
property OnClientWrite: TSocketNotifyEvent read FOnClientWrite write FOnClientWrite;
property OnClientError: TSocketErrorEvent read FOnClientError write FOnClientError;
end;
TMAbstractSocket = class(TComponent)
private
FActive: Boolean;
FPort: Integer;
FAddress: string;
FHost: string;
FService: string;
procedure DoEvent(Sender: TObject; Socket: TCustomWinSocket;
SocketEvent: TSocketEvent);
procedure DoError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
protected
procedure Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
virtual; abstract;
procedure Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer); virtual; abstract;
procedure DoActivate(Value: Boolean); virtual; abstract;
procedure InitSocket(Socket: TCustomWinSocket);
procedure Loaded; override;
procedure SetActive(Value: Boolean);
procedure SetAddress(Value: string);
procedure SetHost(Value: string);
procedure SetPort(Value: Integer);
procedure SetService(Value: string);
property Active: Boolean read FActive write SetActive;
property Address: string read FAddress write SetAddress;
property Host: string read FHost write SetHost;
property Port: Integer read FPort write SetPort;
property Service: string read FService write SetService;
public
procedure Open;
procedure Close;
end;
TMCustomSocket = class(TMAbstractSocket)
private
FOnLookup: TSocketNotifyEvent;
FOnConnect: TSocketNotifyEvent;
FOnConnecting: TSocketNotifyEvent;
FOnDisconnect: TSocketNotifyEvent;
FOnListen: TSocketNotifyEvent;
FOnAccept: TSocketNotifyEvent;
FOnRead: TSocketNotifyEvent;
FOnWrite: TSocketNotifyEvent;
FOnError: TSocketErrorEvent;
protected
procedure Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent); override;
procedure Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer); override;
property OnLookup: TSocketNotifyEvent read FOnLookup write FOnLookup;
property OnConnecting: TSocketNotifyEvent read FOnConnecting write FOnConnecting;
property OnConnect: TSocketNotifyEvent read FOnConnect write FOnConnect;
property OnDisconnect: TSocketNotifyEvent read FOnDisconnect write FOnDisconnect;
property OnListen: TSocketNotifyEvent read FOnListen write FOnListen;
property OnAccept: TSocketNotifyEvent read FOnAccept write FOnAccept;
property OnRead: TSocketNotifyEvent read FOnRead write FOnRead;
property OnWrite: TSocketNotifyEvent read FOnWrite write FOnWrite;
property OnError: TSocketErrorEvent read FOnError write FOnError;
end;
TMClientSocket = class(TMCustomSocket)
private
FClientSocket: TClientWinSocket;
protected
procedure DoActivate(Value: Boolean); override;
function GetClientType: TClientType;
procedure SetClientType(Value: TClientType);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Socket: TClientWinSocket read FClientSocket;
published
property Active;
property Address;
property ClientType: TClientType read GetClientType write SetClientType;
property Host;
property Port;
property Service;
property OnLookup;
property OnConnecting;
property OnConnect;
property OnDisconnect;
property OnRead;
property OnWrite;
property OnError;
end;
TMCustomServerSocket = class(TMCustomSocket)
protected
FServerSocket: TServerWinSocket;
procedure DoActivate(Value: Boolean); override;
function GetServerType: TServerType;
function GetGetSocketEvent: TGetSocketEvent;
function GetOnClientEvent(Index: Integer): TSocketNotifyEvent;
function GetOnClientError: TSocketErrorEvent;
procedure SetServerType(Value: TServerType);
procedure SetGetSocketEvent(Value: TGetSocketEvent);
procedure SetOnClientEvent(Index: Integer; Value: TSocketNotifyEvent);
procedure SetOnClientError(Value: TSocketErrorEvent);
property ServerType: TServerType read GetServerType write SetServerType;
property OnGetSocket: TGetSocketEvent read GetGetSocketEvent
write SetGetSocketEvent;
property OnClientConnect: TSocketNotifyEvent index 2 read GetOnClientEvent
write SetOnClientEvent;
property OnClientDisconnect: TSocketNotifyEvent index 3 read GetOnClientEvent
write SetOnClientEvent;
property OnClientRead: TSocketNotifyEvent index 0 read GetOnClientEvent
write SetOnClientEvent;
property OnClientWrite: TSocketNotifyEvent index 1 read GetOnClientEvent
write SetOnClientEvent;
property OnClientError: TSocketErrorEvent read GetOnClientError write SetOnClientError;
public
destructor Destroy; override;
end;
TMServerSocket = class(TMCustomServerSocket)
public
constructor Create(AOwner: TComponent); override;
property Socket: TServerWinSocket read FServerSocket;
published
property Active;
property Port;
property Service;
property ServerType;
property OnListen;
property OnAccept;
property OnGetSocket;
property OnClientConnect;
property OnClientDisconnect;
property OnClientRead;
property OnClientWrite;
property OnClientError;
end;
TSocketErrorProc = procedure (ErrorCode: Integer);
function SetErrorProc(ErrorProc: TSocketErrorProc): TSocketErrorProc;
procedure Register;
implementation
uses Forms, Consts;
threadvar
SocketErrorProc: TSocketErrorProc;
var
WSAData: TWSAData;
function SetErrorProc(ErrorProc: TSocketErrorProc): TSocketErrorProc;
begin
Result := SocketErrorProc;
SocketErrorProc := ErrorProc;
end;
function CheckSocketResult(ResultCode: Integer; const Op: string): Integer;
begin
if ResultCode <> 0 then
begin
Result := WSAGetLastError;
if Result <> WSAEWOULDBLOCK then
if Assigned(SocketErrorProc) then
SocketErrorProc(Result)
else raise ESocketError.CreateResFmt(@sWindowsSocketError,
[SysErrorMessage(Result), Result, Op]);
end else Result := 0;
end;
procedure Startup;
var
ErrorCode: Integer;
begin
ErrorCode := WSAStartup($0101, WSAData);
if ErrorCode <> 0 then
raise ESocketError.CreateResFmt(@sWindowsSocketError,
[SysErrorMessage(ErrorCode), ErrorCode, 'WSAStartup']);
end;
procedure Cleanup;
var
ErrorCode: Integer;
begin
ErrorCode := WSACleanup;
if ErrorCode <> 0 then
raise ESocketError.CreateResFmt(@sWindowsSocketError,
[SysErrorMessage(ErrorCode), ErrorCode, 'WSACleanup']);
end;
{ TCustomWinSocket }
constructor TCustomWinSocket.Create(ASocket: TSocket);
begin
inherited Create;
Startup;
FSocketLock := TCriticalSection.Create;
FASyncStyles := [asRead, asWrite, asConnect, asClose];
FSocket := ASocket;
FAddr.sin_family := PF_INET;
FAddr.sin_addr.s_addr := INADDR_ANY;
FAddr.sin_port := 0;
FConnected := FSocket <> INVALID_SOCKET;
end;
destructor TCustomWinSocket.Destroy;
begin
FOnSocketEvent := nil; { disable events }
if FConnected and (FSocket <> INVALID_SOCKET) then
Disconnect(FSocket);
if FHandle <> 0 then DeallocateHWnd(FHandle);
FSocketLock.Free;
Cleanup;
FreeMem(FGetHostData);
FGetHostData := nil;
inherited Destroy;
end;
procedure TCustomWinSocket.Accept(Socket: TSocket);
begin
end;
procedure TCustomWinSocket.AsyncInitSocket(const Name, Address,
Service: string; Port: Word; QueueSize: Integer; Client: Boolean);
begin
try
case FLookupState of
lsIdle:
begin
if not Client then
begin
FLookupState := lsLookupAddress;
FAddr.sin_addr.S_addr := INADDR_ANY;
end else if Name <> '' then
begin
if FGetHostData = nil then
FGetHostData := AllocMem(MAXGETHOSTSTRUCT);
FLookupHandle := WSAAsyncGetHostByName(Handle, CM_LOOKUPCOMPLETE,
PChar(Name), FGetHostData, MAXGETHOSTSTRUCT);
CheckSocketResult(Ord(FLookupHandle = 0), 'WSAASyncGetHostByName');
FService := Service;
FPort := Port;
FQueueSize := QueueSize;
FClient := Client;
FLookupState := lsLookupAddress;
Exit;
end else if Address <> '' then
begin
FLookupState := lsLookupAddress;
FAddr.sin_addr.S_addr := inet_addr(PChar(Address));
end else raise ESocketError.CreateRes(@sNoAddress);
end;
lsLookupAddress:
begin
if Service <> '' then
begin
if FGetHostData = nil then
FGetHostData := AllocMem(MAXGETHOSTSTRUCT);
FLookupHandle := WSAASyncGetServByName(Handle, CM_LOOKUPCOMPLETE,
PChar(Service), 'tcp' , FGetHostData, MAXGETHOSTSTRUCT);
CheckSocketResult(Ord(FLookupHandle = 0), 'WSAASyncGetServByName');
FLookupState := lsLookupService;
Exit;
end else
begin
FLookupState := lsLookupService;
FAddr.sin_port := htons(Port);
end;
end;
lsLookupService:
begin
FLookupState := lsIdle;
if Client then
DoOpen
else DoListen(QueueSize);
end;
end;
if FLookupState <> lsIdle then
ASyncInitSocket(Name, Address, Service, Port, QueueSize, Client);
except
Disconnect(FSocket);
raise;
end;
end;
procedure TCustomWinSocket.Close;
begin
Disconnect(FSocket);
end;
procedure TCustomWinSocket.Connect(Socket: TSocket);
begin
end;
procedure TCustomWinSocket.Lock;
begin
FSocketLock.Enter;
end;
procedure TCustomWinSocket.Unlock;
begin
FSocketLock.Leave;
end;
procedure TCustomWinSocket.CMSocketMessage(var Message: TCMSocketMessage);
function CheckError: Boolean;
var
ErrorEvent: TErrorEvent;
ErrorCode: Integer;
begin
if Message.SelectError <> 0 then
begin
Result := False;
ErrorCode := Message.SelectError;
case Message.SelectEvent of
FD_CONNECT: ErrorEvent := eeConnect;
FD_CLOSE: ErrorEvent := eeDisconnect;
FD_READ: ErrorEvent := eeReceive;
FD_WRITE: ErrorEvent := eeSend;
FD_ACCEPT: ErrorEvent := eeAccept;
else
ErrorEvent := eeGeneral;
end;
Error(Self, ErrorEvent, ErrorCode);
if ErrorCode <> 0 then
raise ESocketError.CreateResFmt(@sASyncSocketError, [ErrorCode]);
end else Result := True;
end;
begin
with Message do
if CheckError then
case SelectEvent of
FD_CONNECT: Connect(Socket);
FD_CLOSE: Disconnect(Socket);
FD_READ: Read(Socket);
FD_WRITE: Write(Socket);
FD_ACCEPT: Accept(Socket);
end;
end;
procedure TCustomWinSocket.CMDeferFree(var Message);
begin
Free;
end;
procedure TCustomWinSocket.DeferFree;
begin
if FHandle <> 0 then PostMessage(FHandle, CM_DEFERFREE, 0, 0);
end;
procedure TCustomWinSocket.DoSetAsyncStyles;
var
Msg: Integer;
Wnd: HWnd;
Blocking: Longint;
begin
Msg := 0;
Wnd := 0;
if FAsyncStyles <> [] then
begin
Msg := CM_SOCKETMESSAGE;
Wnd := Handle;
end;
WSAAsyncSelect(FSocket, Wnd, Msg, Longint(Byte(FAsyncStyles)));
if FASyncStyles = [] then
begin
Blocking := 0;
ioctlsocket(FSocket, FIONBIO, Blocking);
end;
end;
procedure TCustomWinSocket.DoListen(QueueSize: Integer);
begin
CheckSocketResult(bind(FSocket, FAddr, SizeOf(FAddr)), 'bind');
DoSetASyncStyles;
if QueueSize > SOMAXCONN then QueueSize := SOMAXCONN;
Event(Self, seListen);
CheckSocketResult(Winsock.listen(FSocket, QueueSize), 'listen');
FLookupState := lsIdle;
FConnected := True;
end;
procedure TCustomWinSocket.DoOpen;
begin
DoSetASyncStyles;
Event(Self, seConnecting);
CheckSocketResult(WinSock.connect(FSocket, FAddr, SizeOf(FAddr)), 'connect');
FLookupState := lsIdle;
if not (asConnect in FAsyncStyles) then
begin
FConnected := FSocket <> INVALID_SOCKET;
Event(Self, seConnect);
end;
end;
function TCustomWinSocket.GetHandle: HWnd;
begin
if FHandle = 0 then
FHandle := AllocateHwnd(WndProc);
Result := FHandle;
end;
function TCustomWinSocket.GetLocalAddress: string;
var
SockAddrIn: TSockAddrIn;
Size: Integer;
begin
Lock;
try
Result := '';
if FSocket = INVALID_SOCKET then Exit;
Size := SizeOf(SockAddrIn);
if getsockname(FSocket, SockAddrIn, Size) = 0 then
Result := inet_ntoa(SockAddrIn.sin_addr);
finally
Unlock;
end;
end;
function TCustomWinSocket.GetLocalHost: string;
var
LocalName: array[0..255] of Char;
begin
Lock;
try
Result := '';
if FSocket = INVALID_SOCKET then Exit;
if gethostname(LocalName, SizeOf(LocalName)) = 0 then
Result := LocalName;
finally
Unlock;
end;
end;
function TCustomWinSocket.GetLocalPort: Integer;
var
SockAddrIn: TSockAddrIn;
Size: Integer;
begin
Lock;
try
Result := -1;
if FSocket = INVALID_SOCKET then Exit;
Size := SizeOf(SockAddrIn);
if getsockname(FSocket, SockAddrIn, Size) = 0 then
Result := ntohs(SockAddrIn.sin_port);
finally
Unlock;
end;
end;
function TCustomWinSocket.GetRemoteHost: string;
var
SockAddrIn: TSockAddrIn;
Size: Integer;
HostEnt: PHostEnt;
begin
Lock;
try
Result := '';
if not FConnected then Exit;
Size := SizeOf(SockAddrIn);
CheckSocketResult(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.s_addr, 4, PF_INET);
if HostEnt <> nil then Result := HostEnt.h_name;
finally
Unlock;
end;
end;
function TCustomWinSocket.GetRemoteAddress: string;
var
SockAddrIn: TSockAddrIn;
Size: Integer;
begin
Lock;
try
Result := '';
if not FConnected then Exit;
Size := SizeOf(SockAddrIn);
CheckSocketResult(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
Result := inet_ntoa(SockAddrIn.sin_addr);
finally
Unlock;
end;
end;
function TCustomWinSocket.GetRemotePort: Integer;
var
SockAddrIn: TSockAddrIn;
Size: Integer;
begin
Lock;
try
Result := 0;
if not FConnected then Exit;
Size := SizeOf(SockAddrIn);
CheckSocketResult(getpeername(FSocket, SockAddrIn, Size), 'getpeername');
Result := ntohs(SockAddrIn.sin_port);
finally
Unlock;
end;
end;
function TCustomWinSocket.GetRemoteAddr: TSockAddrIn;
var
Size: Integer;
begin
Lock;
try
FillChar(Result, SizeOf(Result), 0);
if not FConnected then Exit;
Size := SizeOf(Result);
if getpeername(FSocket, Result, Size) <> 0 then
FillChar(Result, SizeOf(Result), 0);
finally
Unlock;
end;
end;
function TCustomWinSocket.LookupName(const Name: string): TInAddr;
var
HostEnt: PHostEnt;
InAddr: TInAddr;
begin
HostEnt := gethostbyname(PChar(Name));
FillChar(InAddr, SizeOf(InAddr), 0);
if HostEnt <> nil then
begin
with InAddr, HostEnt^ do
begin
S_un_b.s_b1 := h_addr^[0];
S_un_b.s_b2 := h_addr^[1];
S_un_b.s_b3 := h_addr^[2];
S_un_b.s_b4 := h_addr^[3];
end;
end;
Result := InAddr;
end;
function TCustomWinSocket.LookupService(const Service: string): Integer;
var
ServEnt: PServEnt;
begin
ServEnt := getservbyname(PChar(Service), 'tcp');
if ServEnt <> nil then
Result := ntohs(ServEnt.s_port)
else Result := 0;
end;
function TCustomWinSocket.InitSocket(const Name, Address, Service: string; Port: Word;
Client: Boolean): TSockAddrIn;
begin
Result.sin_family := PF_INET;
if Name <> '' then
Result.sin_addr := LookupName(name)
else if Address <> '' then
Result.sin_addr.s_addr := inet_addr(PChar(Address))
else if not Client then
Result.sin_addr.s_addr := INADDR_ANY
else raise ESocketError.CreateRes(@sNoAddress);
if Service <> '' then
Result.sin_port := htons(LookupService(Service))
else
Result.sin_port := htons(Port);
end;
procedure TCustomWinSocket.Listen(const Name, Address, Service: string; Port: Word;
QueueSize: Integer; Block: Boolean);
begin
if FConnected then raise ESocketError.CreateRes(@sCannotListenOnOpen);
FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
if FSocket = INVALID_SOCKET then raise ESocketError.CreateRes(@sCannotCreateSocket);
try
Event(Self, seLookUp);
if Block then
begin
FAddr := InitSocket(Name, Address, Service, Port, False);
DoListen(QueueSize);
end else
AsyncInitSocket(Name, Address, Service, Port, QueueSize, False);
except
Disconnect(FSocket);
raise;
end;
end;
procedure TCustomWinSocket.Open(const Name, Address, Service: string; Port: Word; Block: Boolean);
begin
if FConnected then raise ESocketError.CreateRes(@sSocketAlreadyOpen);
FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
if FSocket = INVALID_SOCKET then raise ESocketError.CreateRes(@sCannotCreateSocket);
try
Event(Self, seLookUp);
if Block then
begin
FAddr := InitSocket(Name, Address, Service, Port, True);
DoOpen;
end else
AsyncInitSocket(Name, Address, Service, Port, 0, True);
except
Disconnect(FSocket);
raise;
end;
end;
procedure TCustomWinSocket.Disconnect(Socket: TSocket);
begin
Lock;
try
if FLookupHandle <> 0 then
CheckSocketResult(WSACancelASyncRequest(FLookupHandle), 'WSACancelASyncRequest');
FLookupHandle := 0;
if (Socket = INVALID_SOCKET) or (Socket <> FSocket) then exit;
Event(Self, seDisconnect);
CheckSocketResult(closesocket(FSocket), 'closesocket');
FSocket := INVALID_SOCKET;
FAddr.sin_family := PF_INET;
FAddr.sin_addr.s_addr := INADDR_ANY;
FAddr.sin_port := 0;
FConnected := False;
finally
Unlock;
end;
end;
procedure TCustomWinSocket.DefaultHandler(var Message);
begin
with TMessage(Message) do
if FHandle <> 0 then
Result := CallWindowProc(@DefWindowProc, FHandle, Msg, wParam, lParam);
end;
procedure TCustomWinSocket.Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
begin
if Assigned(FOnSocketEvent) then FOnSocketEvent(Self, Socket, SocketEvent);
end;
procedure TCustomWinSocket.Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
if Assigned(FOnErrorEvent) then FOnErrorEvent(Self, Socket, ErrorEvent, ErrorCode);
end;
function TCustomWinSocket.SendText(const s: string): Integer;
begin
Result := SendBuf(Pointer(S)^, Length(S));
end;
function TCustomWinSocket.SendBuf(var Buf; Count: Integer): Integer;
var
ErrorCode: Integer;
begin
Lock;
try
Result := 0;
if not FConnected then Exit;
Result := send(FSocket, Buf, Count, 0);
if Result = SOCKET_ERROR then
begin
ErrorCode := WSAGetLastError;
if (ErrorCode <> WSAEWOULDBLOCK) then
begin
Error(Self, eeSend, ErrorCode);
Disconnect(FSocket);
if ErrorCode <> 0 then
raise ESocketError.CreateResFmt(@sWindowsSocketError,
[SysErrorMessage(ErrorCode), ErrorCode, 'send']);
end;
end;
finally
Unlock;
end;
end;
procedure TCustomWinSocket.SetAsyncStyles(Value: TASyncStyles);
begin
if Value <> FASyncStyles then
begin
FASyncStyles := Value;
if FSocket <> INVALID_SOCKET then
DoSetAsyncStyles;
end;
end;
procedure TCustomWinSocket.Read(Socket: TSocket);
begin
if (FSocket = INVALID_SOCKET) or (Socket <> FSocket) then Exit;
Event(Self, seRead);
end;
function TCustomWinSocket.ReceiveBuf(var Buf; Count: Integer): Integer;
var
ErrorCode: Integer;
begin
Lock;
try
Result := 0;
if (Count = -1) and FConnected then
ioctlsocket(FSocket, FIONREAD, Longint(Result))
else begin
if not FConnected then Exit;
Result := recv(FSocket, Buf, Count, 0);
if Result = SOCKET_ERROR then
begin
ErrorCode := WSAGetLastError;
if ErrorCode <> WSAEWOULDBLOCK then
begin
Error(Self, eeReceive, ErrorCode);
Disconnect(FSocket);
if ErrorCode <> 0 then
raise ESocketError.CreateResFmt(@sWindowsSocketError,
[SysErrorMessage(ErrorCode), ErrorCode, 'recv']);
end;
end;
end;
finally
Unlock;
end;
end;
function TCustomWinSocket.ReceiveLength: Integer;
begin
Result := ReceiveBuf(Pointer(nil)^, -1);
end;
function TCustomWinSocket.ReceiveText: string;
begin
SetLength(Result, ReceiveBuf(Pointer(nil)^, -1));
SetLength(Result, ReceiveBuf(Pointer(Result)^, Length(Result)));
end;
procedure TCustomWinSocket.WndProc(var Message: TMessage);
begin
try
Dispatch(Message);
except
Application.HandleException(Self);
end;
end;
procedure TCustomWinSocket.Write(Socket: TSocket);
begin
if (FSocket = INVALID_SOCKET) or (Socket <> FSocket) then Exit;
end;
procedure TCustomWinSocket.CMLookupComplete(var Message: TCMLookupComplete);
begin
if Message.LookupHandle = FLookupHandle then
begin
FLookupHandle := 0;
if Message.AsyncError <> 0 then
begin
Disconnect(FSocket);
raise ESocketError.CreateResFmt(@sWindowsSocketError,
[SysErrorMessage(Message.AsyncError), Message.ASyncError, 'ASync Lookup']);
end;
if FLookupState = lsLookupAddress then
begin
FAddr.sin_addr.S_addr := Integer(Pointer(PHostEnt(FGetHostData).h_addr^)^);
ASyncInitSocket('', '', FService, FPort, FQueueSize, FClient);
end else if FLookupState = lsLookupService then
begin
FAddr.sin_port := PServEnt(FGetHostData).s_port;
FPort := 0;
FService := '';
ASyncInitSocket('', '', '', 0, FQueueSize, FClient);
end;
end;
end;
{ TClientWinSocket }
procedure TClientWinSocket.Connect(Socket: TSocket);
begin
FConnected := True;
Event(Self, seConnect);
end;
procedure TClientWinSocket.SetClientType(Value: TClientType);
begin
if Value <> FClientType then
if not FConnected then
begin
FClientType := Value;
ASyncStyles := [asRead, asWrite, asConnect, asClose];
end else raise ESocketError.CreateRes(@sCantChangeWhileActive);
end;
{ TServerClientWinsocket }
constructor TServerClientWinSocket.Create(Socket: TSocket; ServerWinSocket: TServerWinSocket);
begin
FServerWinSocket := ServerWinSocket;
if Assigned(FServerWinSocket) then
begin
FServerWinSocket.AddClient(Self);
if FServerWinSocket.AsyncStyles <> [] then
begin
OnSocketEvent := FServerWinSocket.ClientEvent;
OnErrorEvent := FServerWinSocket.ClientError;
end;
end;
inherited Create(Socket);
if FServerWinSocket.ASyncStyles <> [] then DoSetAsyncStyles;
if FConnected then Event(Self, seConnect);
end;
destructor TServerClientWinSocket.Destroy;
begin
if Assigned(FServerWinSocket) then
FServerWinSocket.RemoveClient(Self);
inherited Destroy;
end;
{ TServerWinSocket }
constructor TServerWinSocket.Create(ASocket: TSocket);
begin
FConnections := TList.Create;
FListLock := TCriticalSection.Create;
inherited Create(ASocket);
FAsyncStyles := [asAccept];
end;
destructor TServerWinSocket.Destroy;
begin
inherited Destroy;
FConnections.Free;
FListLock.Free;
end;
procedure TServerWinSocket.AddClient(AClient: TServerClientWinSocket);
begin
FListLock.Enter;
try
if FConnections.IndexOf(AClient) < 0 then
FConnections.Add(AClient);
finally
FListLock.Leave;
end;
end;
procedure TServerWinSocket.RemoveClient(AClient: TServerClientWinSocket);
begin
FListLock.Enter;
try
FConnections.Remove(AClient);
finally
FListLock.Leave;
end;
end;
procedure TServerWinSocket.Accept(Socket: TSocket);
var
ClientSocket: TServerClientWinSocket;
ClientWinSocket: TSocket;
Addr: TSockAddrIn;
Len: Integer;
OldOpenType, NewOpenType: Integer;
begin
Len := SizeOf(OldOpenType);
if getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, PChar(@OldOpenType),
Len) = 0 then
try
Len := SizeOf(Addr);
ClientWinSocket := WinSock.accept(Socket, @Addr, @Len);
if ClientWinSocket <> INVALID_SOCKET then
begin
ClientSocket := GetClientSocket(ClientWinSocket);
if Assigned(FOnSocketEvent) then
FOnSocketEvent(Self, ClientSocket, seAccept);
end;
finally
Len := SizeOf(OldOpenType);
setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, PChar(@OldOpenType), Len);
end;
end;
procedure TServerWinSocket.ClientEvent(Sender: TObject; Socket: TCustomWinSocket;
SocketEvent: TSocketEvent);
begin
case SocketEvent of
seAccept,
seLookup,
seConnecting,
seListen:
begin end; file://不作反应
seConnect: ClientConnect(Socket); file://触发相应事件
seDisconnect: ClientDisconnect(Socket);
seRead: ClientRead(Socket);
seWrite: ClientWrite(Socket);
end;
end;
procedure TServerWinSocket.ClientError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
ClientErrorEvent(Socket, ErrorEvent, ErrorCode);
end;
function TServerWinSocket.GetActiveConnections: Integer;
begin
Result := FConnections.Count;
end;
function TServerWinSocket.GetConnections(Index: Integer): TCustomWinSocket;
begin
Result := FConnections[Index];
end;
procedure TServerWinSocket.Listen(var Name, Address, Service: string; Port: Word;
QueueSize: Integer);
begin
inherited Listen(Name, Address, Service, Port, QueueSize, ServerType = stnonBlocking);
file://messagebox(0,0,'ksdfaldkf',0);
{ if FConnected then
begin
FServerAcceptThread := TServerAcceptThread.Create(False, Self);
end; }
end;
procedure TServerWinSocket.SetServerType(Value: TServerType);
begin
if Value <> FServerType then
if not FConnected then
begin
FServerType := Value;
ASyncStyles := [asAccept];
end else raise ESocketError.CreateRes(@sCantChangeWhileActive);
end;
function TServerWinSocket.GetClientSocket(Socket: TSocket): TServerClientWinSocket;
begin
Result := nil;
if Assigned(FOnGetSocket) then FOnGetSocket(Self, Socket, Result);
if Result = nil then
Result := TServerClientWinSocket.Create(Socket, Self);
end;
procedure TServerWinSocket.ClientConnect(Socket: TCustomWinSocket);
begin
if Assigned(FOnClientConnect) then FOnClientConnect(Self, Socket);
end;
procedure TServerWinSocket.ClientDisconnect(Socket: TCustomWinSocket);
begin
if Assigned(FOnClientDisconnect) then FOnClientDisconnect(Self, Socket);
if ServerType = stNonBlocking then Socket.DeferFree;
end;
procedure TServerWinSocket.ClientRead(Socket: TCustomWinSocket);
begin
if Assigned(FOnClientRead) then FOnClientRead(Self, Socket);
end;
procedure TServerWinSocket.ClientWrite(Socket: TCustomWinSocket);
begin
if Assigned(FOnClientWrite) then FOnClientWrite(Self, Socket);
end;
procedure TServerWinSocket.ClientErrorEvent(Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
if Assigned(FOnClientError) then FOnClientError(Self, Socket, ErrorEvent, ErrorCode);
end;
{ TAbstractSocket }
procedure TMAbstractSocket.DoEvent(Sender: TObject; Socket: TCustomWinSocket;
SocketEvent: TSocketEvent);
begin
Event(Socket, SocketEvent);
end;
procedure TMAbstractSocket.DoError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
Error(Socket, ErrorEvent, ErrorCode);
end;
procedure TMAbstractSocket.SetActive(Value: Boolean);
begin
if Value <> FActive then
begin
if (csDesigning in ComponentState) or (csLoading in ComponentState) then
FActive := Value;
if not (csLoading in ComponentState) then
DoActivate(Value);
end;
end;
procedure TMAbstractSocket.InitSocket(Socket: TCustomWinSocket);
begin
Socket.OnSocketEvent := DoEvent;
Socket.OnErrorEvent := DoError;
end;
procedure TMAbstractSocket.Loaded;
begin
inherited Loaded;
DoActivate(FActive);
end;
procedure TMAbstractSocket.SetAddress(Value: string);
begin
if CompareText(Value, FAddress) <> 0 then
begin
if not (csLoading in ComponentState) and FActive then
raise ESocketError.CreateRes(@sCantChangeWhileActive);
FAddress := Value;
end;
end;
procedure TMAbstractSocket.SetHost(Value: string);
begin
if CompareText(Value, FHost) <> 0 then
begin
if not (csLoading in ComponentState) and FActive then
raise ESocketError.CreateRes(@sCantChangeWhileActive);
FHost := Value;
end;
end;
procedure TMAbstractSocket.SetPort(Value: Integer);
begin
if FPort <> Value then
begin
if not (csLoading in ComponentState) and FActive then
raise ESocketError.CreateRes(@sCantChangeWhileActive);
FPort := Value;
end;
end;
procedure TMAbstractSocket.SetService(Value: string);
begin
if CompareText(Value, FService) <> 0 then
begin
if not (csLoading in ComponentState) and FActive then
raise ESocketError.CreateRes(@sCantChangeWhileActive);
FService := Value;
end;
end;
procedure TMAbstractSocket.Open;
begin
Active := True;
end;
procedure TMAbstractSocket.Close;
begin
Active := False;
end;
{ TCustomSocket }
procedure TMCustomSocket.Event(Socket: TCustomWinSocket; SocketEvent: TSocketEvent);
begin
case SocketEvent of
seLookup: if Assigned(FOnLookup) then FOnLookup(Self, Socket);
seConnecting: if Assigned(FOnConnecting) then FOnConnecting(Self, Socket);
seConnect:
begin
FActive := True;
if Assigned(FOnConnect) then FOnConnect(Self, Socket);
end;
seListen:
begin
FActive := True;
if Assigned(FOnListen) then FOnListen(Self, Socket);
end;
seDisconnect:
begin
FActive := False;
if Assigned(FOnDisconnect) then FOnDisconnect(Self, Socket);
end;
seAccept: if Assigned(FOnAccept) then FOnAccept(Self, Socket);
seRead: if Assigned(FOnRead) then FOnRead(Self, Socket);
seWrite: if Assigned(FOnWrite) then FOnWrite(Self, Socket);
end;
end;
procedure TMCustomSocket.Error(Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
if Assigned(FOnError) then FOnError(Self, Socket, ErrorEvent, ErrorCode);
end;
{ TMClientSocket }
constructor TMClientSocket.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FClientSocket := TClientWinSocket.Create(INVALID_SOCKET);
InitSocket(FClientSocket);
end;
destructor TMClientSocket.Destroy;
begin
FClientSocket.Free;
inherited Destroy;
end;
procedure TMClientSocket.DoActivate(Value: Boolean);
begin
if (Value <> FClientSocket.Connected) and not (csDesigning in ComponentState) then
begin
if FClientSocket.Connected then
FClientSocket.Disconnect(FClientSocket.FSocket)
else FClientSocket.Open(FHost, FAddress, FService, FPort, ClientType = ctNonBlocking);
end;
end;
function TMClientSocket.GetClientType: TClientType;
begin
Result := FClientSocket.ClientType;
end;
procedure TMClientSocket.SetClientType(Value: TClientType);
begin
FClientSocket.ClientType := Value;
end;
{ TCustomServerSocket }
destructor TMCustomServerSocket.Destroy;
begin
FServerSocket.Free;
inherited Destroy;
end;
procedure TMCustomServerSocket.DoActivate(Value: Boolean);
begin
if (Value <> FServerSocket.Connected) and not (csDesigning in ComponentState) then
begin
if FServerSocket.Connected then
FServerSocket.Disconnect(FServerSocket.SocketHandle)
else FServerSocket.Listen(FHost, FAddress, FService, FPort, SOMAXCONN);
end;
end;
function TMCustomServerSocket.GetServerType: TServerType;
begin
Result := FServerSocket.ServerType;
end;
procedure TMCustomServerSocket.SetServerType(Value: TServerType);
begin
FServerSocket.ServerType := Value;
end;
function TMCustomServerSocket.GetGetSocketEvent: TGetSocketEvent;
begin
Result := FServerSocket.OnGetSocket;
end;
procedure TMCustomServerSocket.SetGetSocketEvent(Value: TGetSocketEvent);
begin
FServerSocket.OnGetSocket := Value;
end;
function TMCustomServerSocket.GetOnClientEvent(Index: Integer): TSocketNotifyEvent;
begin
case Index of
0: Result := FServerSocket.OnClientRead;
1: Result := FServerSocket.OnClientWrite;
2: Result := FServerSocket.OnClientConnect;
3: Result := FServerSocket.OnClientDisconnect;
end;
end;
procedure TMCustomServerSocket.SetOnClientEvent(Index: Integer;
Value: TSocketNotifyEvent);
begin
case Index of
0: FServerSocket.OnClientRead := Value;
1: FServerSocket.OnClientWrite := Value;
2: FServerSocket.OnClientConnect := Value;
3: FServerSocket.OnClientDisconnect := Value;
end;
end;
function TMCustomServerSocket.GetOnClientError: TSocketErrorEvent;
begin
Result := FServerSocket.OnClientError;
end;
procedure TMCustomServerSocket.SetOnClientError(Value: TSocketErrorEvent);
begin
FServerSocket.OnClientError := Value;
end;
{ TServerSocket }
constructor TMServerSocket.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FServerSocket := TServerWinSocket.Create(INVALID_SOCKET);
InitSocket(FServerSocket);
end;
procedure Register;
begin
RegisterComponents('MyPage', [TMServerSocket,TMClientSocket]);
end;
end.
|
本类阅读TOP10