The following is an improved Socket control made by this rookie, interested Xiaoxia can play down, by the way.
Unit mscktcomp; interface
Uses Sysutils, Windows, Messages, Classes, Winsock, Syncobjs;
Const cm_socketMessage = WM_USER $ 0001; cm_deferfree = WM_USER $ 0002; cm_lookuppcomplete = wm_user $ 0003;
TYPE EsocketError = Class (Exception);
TCMSocketMessage = Record Msg: cardinal; socket: Tsocket; SELECTEVENT: WORD; SELECTERROR: WORD;
TCMLOOKUPCOMPLETE = Record Msg: cardinal; lookuphandle: thandle; ask; asyncBUFlen: Word; result: longint;
Tcustomwinsocket = Class; TMCUSTOMSOCKET = Class; TSERVERWINSOCKET = Class; TSERVERCLIENTWISOCKET = 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, Esend, 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: Inteder; 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: // ********************************************************* ************** // define a receiving thread {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: // ************************************************************** ******* // define a connection management thread {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 Endco nnect: 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); // add to TLIST connection procedure removeClient (AClient: TServerClientWinSocket); procedure ClientEvent (Sender: TObject; Socket: TCustomWinSocket; SocketEvent: TSocketEvent); // response to customer SOCKET event procedure ClientError (Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer); function GetActiveConnections: Integer; file: // Get the number of connections function GetConnections (Index: Integer): TCustomWinSocket; // Get the specified connection 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 set (Value: integer); Procedure SetService; Property Active: Boolean Read Factive Write SetActive; Property Addr ess: 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 rea d 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;
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: TSocke tNotifyEvent 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 SeerrorProc (ErrorProc: TsocketErrorProc): TsocketErrorProc; Procedure Register;
IMPLEMENTATION
Uses forms, consts;
Threadvar SocketErrorProc: TsocketErrorProc;
Var Wsadata: TWSADATA;
Function setErrorProc (ERRORPROC: TSOCKETERROC): TsocketErrorProc; begin result: = SocketErrorProc; socketErrorProc: = errorproc;
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]); Else Result: = 0;
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;
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;
Procedure tcustomwinsocket.accept (socket: tsocket); begund;
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);
Procedure tcustomwinsocket.connect (socket: tsocket); becomund;
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]); ELSE RESULT: = true;
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); message;
Procedure tcustomwinsocket.deferfree; Begin if fhandle <> 0 THEN PostMessage (Fhandle, Cm_deferFree, 0, 0);
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 = [] The begin blocking: = 0; ioctlsocket (fsocket, fionbio, blocking); 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;
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; energy (self); end;
Function tcustomwinsocket.gethandle: hw; begin if fhandle = 0 Then fhandle: = allocatehwnd (wndproc); result: = fhandle;
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 dam; if gethostname (localname, sizeof (localname)) = 0 THEN Result: = localname; finally unlock; 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;
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 dam.h_name; finally unlock;
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 kilin 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;
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);
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;
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_Addr: = INADDR_ADDR: = 0; fconnected: = false; fin or unlock; end;
Procedure tcustomwinsocket.defaulthandler (var message); begin with tMessage (Message) Do if fhandle <> 0 Then Result: = CallWindowProc (@Defwindowproc, fhandle, msg, wparam, lparam);
Procedure tcustomwinsocket.event (socket: tcustomwinsocket; socketEvent: tsocketevent); beginness (fonsocketevent) THEN FONSOCKETEVENT (Self, Socket, SocketEvent);
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));
Function tcustomwinsocket.sendbuf (VAR BUF; Count: Integer): Integer; var errorcode: integer; begin lock; try result: = 0; if not fconnected kiln 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;
Procedure tcustomwinsocket.setasyncstyles; begin if value <> fasyncstyles the begin fasyncStyles: = value; if fsocket <> invalid_socket dam =etasyncstyles;
Procedure tcustomwinsocket.read (socket: tsocket); begin if (fsocket = invalid_socket) or (Socket <> fsocket).
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: "Begin Result: = ReceiveBuf (Pointer (NIL) ^, -1);
Function TCustomwinsocket.ReceiveText: String; Begin SetLength (Result, ReceiveBuf (Pointer (NIL) ^, -1)); setLENGTH (Result, ReceiveBuf (Pointer (Result));
Procedure tcustomwinsocket.wndproc (var message: tMessage); begin try dispatch; except Application.handlexception (Self); end;
Procedure tcustomwinsocket.write (socket: tsocket); begin if (fsocket = invalid_socket) or (socket <> fsocket).
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, fqueueesize, fclient); end; end; end; {tclientwinsocket}
Procedure Tclientwinsocket.connect (Socket: Tsocket); Begin Fconnected: = true; Event (Self, Seconnect);
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) ;
{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;
{TSERVERWInsocket}
Constructor tServerwinsocket.create (ASocket: Tsocket); begin fconnections: = tList.create; flistlock: = tcriticalsection.create; inherited create (asocket); Fasaccetyles :=
DESTRUCTOR TSERVERWINSOCKET.DESTROY; BEGIN inherited destroy; finterctions.free; flistlock.free;
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: // not respond seConnect: ClientConnect (Socket); file: // trigger the corresponding event 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.GETACTIVECONNECNECT.GETACTIVECONNECNECKET.GEGER; Begin Result: = fconnections.count;
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 TSerWinsocket.ClientConnect (Socket: Tcustomwinsocket); Begin if Assign (FonclientConnect) THEN FONCLIENTCONNECT (Self, Socket);
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);
Procedure TServerwinsocket.ClientWrite (Socket: tcustomwinsocket); Begin IF Assign (FonclientWrite) THEN FONCLIENTWRITE (Self, Socket);
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);
Procedure TMABSTRACTSOCKET.DOERROR (SENDER: TOBJECT; Socket: tcustomwinsocket; erroorevent: terrorevent; var errorcode: integer; begin error (socket, erroorevent, erroorcode);
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 ;
Procedure TMABSTRACTSOCKET.INITSOCKET (SOCKET: TCUSTOMWINSOCKET); Begin Socket.onSocketEvent: = doEvent; socket.onerRorEvent: = doerror;
ProcedureTMabstractSocket.Loaded; begin inherited loaded; doactivate
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;
Procedure tMabstractsocket.close; begin Active: = false;
{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 TMCUSOCKET.ERROR (socket: tcustomwinsocket; erroorevent: terrorEvent; var errorcode: integer; begin if assigned (fonderror) THEN FONERROR (Self, Socket, ErrorEvent, ErrorCode);
{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 , Fservation, fport, clienttype = ctnonblocking; end;
Function TMClientSocket.getClientType: TclientType; Begin Result: = fclientSocket.clientType;
Procedure TmClientSocket.setClientType (Value: TclientType); Begin FclientSocket.ClientType: = Value; End;
{TcustomServersocket}
DESTRUCTOR TMCUSTOERVERSERSOCKET.DESTROY; begin fserversocket.free; inherited destroy;
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;
Function TMCUSTORVERSOCKET.GETSERVERTYPE: TSERVERTYPE; Begin Result: = fserversocket.servertype;
Procedure TMCUSERVERSERSOCKET.SETSERVERTYPE (VALUE: TSERVERTYPE); begin fserversocket.servertype: = value;
Function TMCustomServersocket.getGetsocketEvent: TgetsocketEvent; Begin Result: = fserversocket.ongetsocket;
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;
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;
Function TMCUSTOMSERVERSOCKET.GETONCLIENTERROR: TSOCKETERROREVENT; Begin Result: = fserversocket.onclientEnTerror; End;
Procedure TMCUSTORVERSOCKET.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.
