unit WSockets;
{

WSockets Version 1.20 - A Simple VCL Encapsulation of the WinSocket API

VCL Classes in this Unit:
  TTCPClient - A TCP Client (derived from TCustomWSocket)
  TTCPServer - A TCP Server (derived from TCustomWSocket)
  TUDPClient - A UDP Client (derived from TCustomWSocket)
  TUDPServer - A UDP Server (derived from TCustomWSocket)

Other classes ni this Unit:
  TCustomWSocket - A generic base class for other socket classes
  TClientList    - A list class used only by the TTCPServer class

Legal issues:

Copyright (C) 1997 by Robert T. Palmqvist <robert.palmqvist@skanska.se>

  This software is provided 'as-is', without any express or implied
  warranty.  In no event will the author be held liable for any damages
  arising from the use of this software.

  Permission is granted to anyone to use this software for any purpose,
  including commercial applications, and to alter it and redistribute it
  freely, subject to the following restrictions:

  1. The origin of this software must not be misrepresented, you must not
     claim that you wrote the original software. If you use this software
     in a product, an acknowledgment in the product documentation would be
     appreciated but is not required.

  2. Altered source versions must be plainly marked as such, and must not be
     misrepresented as being the original software.

  3. This notice may not be removed or altered from any source distribution.

Credits go to:

  Gary T. Desrosiers. His unit "Sockets" inspired me to write my own.

  Martin Hall, Mark Towfig, Geoff Arnold, David Treadwell, Henry Sanders
  and InfoMagic, Inc. for their Windows Help File "WinSock.hlp".

  All the guys at Borland who gave us a marvellous tool named "Delphi"!

Recommended information sources:

  Specification:
    Windows Sockets Version 1.1 Specification

  Textbook:
    Quinn and Shute. "Windows Sockets Network Programming"
    1996 by Addison-Wesley Publishing Company, Inc. ISBN 0-201-63372-8

  World Wide Web:
    http://www.sockets.com
    http://www.stardust.com

  Network News:
    alt.winsock.programming

  Frequently Asked Questions:
    "WinSock Application FAQ" Mailto: info@lcs.com Subject: faq

  Requests for Comments:
    RFC 768 "User Datagram Protocol"
    RFC 791 "Internet Protocol"
    RFC 793 "Transmission Control Protocol"

}
interface

uses
  Windows, WinSock, SysUtils, Classes, Messages, Forms;

const
  WM_ASYNCSELECT = WM_USER + 1;
  READ_BUFFER_SIZE = 1024;
  MAX_LOOP = 100;

type
  TSocketState = (ssNotStarted, ssClosed, ssConnected, ssListening, ssOpen);

  TOnError = procedure(Sender: TObject; Error: integer; Msg: string) of object;
  TOnData = procedure(Sender: TObject; Socket: TSocket) of object;
  TOnAccept = procedure(Sender: TObject; Socket: TSocket) of object;
  TOnConnect = procedure(Sender: TObject; Socket: TSocket) of object;
  TOnClose = procedure(Sender: TObject; Socket: TSocket) of object;

  TReadBuffer = array[1..READ_BUFFER_SIZE] of byte;

  TClientList = class(TObject)
  private
    FSockets: TList;
  protected
    function GetSockets(Index: integer): TSocket;
    function GetCount: integer;
  public
    constructor Create;
    destructor Destroy; override;
    function Add(Socket: TSocket): boolean;
    procedure Delete(Socket: TSocket);
    procedure Clear;
    function IndexOf(Socket: TSocket): integer;
    property Sockets[Index: integer]: TSocket read GetSockets; default;
    property Count: integer read GetCount;
  end;

  TCustomWSocket = class(TComponent)
  private
    {WinSocket Information Private Fields}
    FVersion: string;
    FDescription: string;
    FSystemStatus: string;
    FMaxSockets: integer;
    FMaxUDPSize: integer;
    {End WinSocket Information Private Fields}
    FProtocol: integer;
    FType: integer;

    FReadBuffer: TReadBuffer;
    FLocalSocket: TSocket;
    FSocketState: TSocketState;
    FLastError: integer;
    FOnError: TOnError;
  protected
    procedure SocketError(Error: integer);
    function LastErrorDesc: string;

    function GetLocalHostAddress: string;
    function GetLocalHostName: string;
    {Socket Helper Functions}
    procedure SocketClose(var Socket: TSocket; Handle: HWND);
    function SocketQueueSize(Socket: TSocket): longint;

    procedure SocketWrite(Socket: TSocket; Flag: integer; Data: string);
    function SocketRead(Socket: TSocket; Flag: integer): string;
    function SocketWriteBuffer(Socket: TSocket; Buffer: Pointer; Size, Flag: integer): integer;
    function SocketReadBuffer(Socket: TSocket; Buffer: Pointer; Size, Flag: integer): integer;

    procedure SocketWriteTo(Socket: TSocket; Flag: integer; Data: string; var SockAddrIn: TSockAddrIn);
    function SocketReadFrom(Socket: TSocket; Flag: integer; var SockAddrIn: TSockAddrIn): string;
    function SocketWriteBufferTo(Socket: TSocket; Buffer: Pointer; Size, Flag: integer; var SockAddrIn: TSockAddrIn): integer;
    function SocketReadBufferFrom(Socket: TSocket; Buffer: Pointer; Size, Flag: integer; var SockAddrIn: TSockAddrIn): integer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    {Address and Port Resolving Helper Functions}
    function GetSockAddrIn(Host, Port: string; var SockAddrIn: TSockAddrIn): boolean;
    function GetAnySockAddrIn(Port: string; var SockAddrIn: TSockAddrIn): boolean;
    function GetBroadcastSockAddrIn(Port: string; var SockAddrIn: TSockAddrIn): boolean;
    function SockAddrInToName(SockAddrIn: TSockAddrIn): string;
    function SockAddrInToAddress(SockAddrIn: TSockAddrIn): string;
    function SockAddrInToPort(SockAddrIn: TSockAddrIn): string;
    function SocketToName(Socket: TSocket): string;
    function SocketToAddress(Socket: TSocket): string;
    function SocketToPort(Socket: TSocket): string;
    function PeerToName(Socket: TSocket): string;
    function PeerToAddress(Socket: TSocket): string;
    function PeerToPort(Socket: TSocket): string;
    {WinSocket Information Properties}
    property Version: string read FVersion;
    property Description: string read FDescription;
    property SystemStatus: string read FSystemStatus;
    property MaxSockets: integer read FMaxSockets;
    property MaxUDPSize: integer read FMaxUDPSize;
    {End WinSocket Information Properties}
    property LocalSocket: TSocket read FLocalSocket;
    property SocketState: TSocketState read FSocketState;
    property LastError: integer read FLastError;
    property LocalHostAddress: string read GetLocalHostAddress;
    property LocalHostName: string read GetLocalHostName;
  published
    property OnError: TOnError read FOnError write FOnError;
  end;

  TTCPClient = class(TCustomWSocket)
  private
    FHandle: HWND;

    FHost: string;
    FPort: string;

    FOnData: TOnData;
    FOnConnect: TOnConnect;
    FOnClose: TOnClose;
  protected
    procedure WndProc(var AMsg: TMessage);
    procedure OpenConnection(Socket: TSocket; Error: word);
    procedure IncommingData(Socket: TSocket; Error: word);
    procedure CloseConnection(Socket: TSocket; Error: word);

    function GetPeerAddress: string;
    function GetPeerPort: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Open;
    procedure Close;

    function Peek: string;

    procedure Write(Data: string);
    function Read: string;

    function WriteBuffer(Buffer: Pointer; Size: integer): integer;
    function ReadBuffer(Buffer: Pointer; Size: integer): integer;

    property Handle: HWND read FHandle;

    property PeerAddress: string read GetPeerAddress;
    property PeerPort: string read GetPeerPort;
  published
    property Host: string read FHost write FHost;
    property Port: string read FPort write FPort;

    property OnData: TOnData read FOnData write FOnData;
    property OnConnect: TOnConnect read FOnConnect write FOnConnect;
    property OnClose: TOnClose read FOnClose write FOnClose;
  end;

  TTCPServer = class(TCustomWSocket)
  private
    FHandle: HWND;
    FPort: string;

    FOnData: TOnData;
    FOnAccept: TOnAccept;
    FOnClose: TOnClose;

    FClients: TClientList;
  protected
    procedure WndProc(var AMsg: TMessage);
    procedure OpenConnection(Socket: TSocket; Error: word);
    procedure IncommingData(Socket: TSocket; Error: word);
    procedure CloseConnection(Socket: TSocket; Error: word);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Open;
    procedure Close;

    function Peek(Socket: TSocket): string;

    procedure Write(Socket: TSocket; Data: string);
    function Read(Socket: TSocket): string;

    function WriteBuffer(Socket: TSocket; Buffer: Pointer; Size: integer): integer;
    function ReadBuffer(Socket: TSocket; Buffer: Pointer; Size: integer): integer;

    procedure Disconnect(Socket: TSocket);

    property Handle: HWND read FHandle;
    property Clients: TClientList read FClients;
  published
    property Port: string read FPort write FPort;

    property OnData: TOnData read FOnData write FOnData;
    property OnAccept: TOnAccept read FOnAccept write FOnAccept;
    property OnClose: TOnClose read FOnClose write FOnClose;
  end;

  TUDPClient = class(TCustomWSocket)
  private
    FHandle: HWND;

    FHost: string;
    FPort: string;

    FOnData: TOnData;
  protected
    procedure WndProc(var AMsg: TMessage);
    procedure IncommingData(Socket: TSocket; Error: word);

    function GetPeerAddress: string;
    function GetPeerPort: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Open;
    procedure Close;

    function Peek: string;

    procedure Write(Data: string);
    function Read: string;

    function WriteBuffer(Buffer: Pointer; Size: integer): integer;
    function ReadBuffer(Buffer: Pointer; Size: integer): integer;

    property Handle: HWND read FHandle;

    property PeerAddress: string read GetPeerAddress;
    property PeerPort: string read GetPeerPort;
  published
    property Host: string read FHost write FHost;
    property Port: string read FPort write FPort;

    property OnData: TOnData read FOnData write FOnData;
  end;

  TUDPServer = class(TCustomWSocket)
  private
    FHandle: HWND;
    FPort: string;

    FOnData: TOnData;
  protected
    procedure WndProc(var AMsg: TMessage);
    procedure IncommingData(Socket: TSocket; Error: word);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Open;
    procedure Close;

    function Peek(Socket: TSocket; var SockAddrIn: TSockAddrIn): string;

    procedure Write(Socket: TSocket; Data: string; var SockAddrIn: TSockAddrIn);
    function Read(Socket: TSocket; var SockAddrIn: TSockAddrIn): string;

    function WriteBuffer(Socket: TSocket; Buffer: Pointer; Size: integer; var SockAddrIn: TSockAddrIn): integer;
    function ReadBuffer(Socket: TSocket; Buffer: Pointer; Size: integer; var SockAddrIn: TSockAddrIn): integer;

    property Handle: HWND read FHandle;
  published
    property Port: string read FPort write FPort;

    property OnData: TOnData read FOnData write FOnData;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TTCPClient, TTCPServer, TUDPClient, TUDPServer]);
end;

(**** TClientList Class ****)

constructor TClientList.Create;
begin
  inherited Create;
  FSockets:= TList.Create;
end;

destructor TClientList.Destroy;
begin
  Clear;
  FSockets.Free;
  inherited Destroy;
end;

function TClientList.GetSockets(Index: integer): TSocket;
begin
  Result:= TSocket(FSockets[Index]);
end;

function TClientList.GetCount: integer;
begin
  Result:= FSockets.Count;
end;

function TClientList.Add(Socket: TSocket): boolean;
begin
  Result:= (FSockets.Add(Ptr(Socket)) >= 0);
end;

procedure TClientList.Delete(Socket: TSocket);
var
  i: integer;
begin
  for i:= 0 to FSockets.Count-1 do
    begin
      if TSocket(FSockets[i]) = Socket then
        begin
          FSockets.Delete(i);
          Break;
        end;
    end;
end;

procedure TClientList.Clear;
begin
  FSockets.Clear;
end;

function TClientList.IndexOf(Socket: TSocket): integer;
var
  i: integer;
begin
  Result:= -1;
  for i:= 0 to FSockets.Count-1 do
    begin
      if TSocket(FSockets[i]) = Socket then
        begin
          Result:= i;
          Break;
        end;
    end;
end;

(**** TCustomWSocket Class ****)

constructor TCustomWSocket.Create(AOwner: TComponent);
var
  WSAData: TWSAData;
begin
  inherited Create(AOwner);
  FProtocol:= IPPROTO_IP;
  FType:= SOCK_RAW;
  FLocalSocket:= INVALID_SOCKET;
  FSocketState:= ssNotStarted;
  FLastError:= WSAStartup($101, WSAData);
  if FLastError = 0 then
    begin
      FSocketState:= ssClosed;
      with WSAData do
        begin
          FVersion:= Concat(IntToStr(Hi(wVersion)),'.',(IntToStr(Lo(wVersion))));
          FDescription:= String(szDescription);
          FSystemStatus:= String(szSystemStatus);
          FMaxSockets:= iMaxSockets;
          FMaxUDPSize:= iMaxUDPDg;
        end;
    end
  else
    SocketError(FLastError);
end;

destructor TCustomWSocket.Destroy;
begin
  if FLocalSocket <> INVALID_SOCKET then
    closesocket(FLocalSocket);
  if FSocketState <> ssNotStarted then
    if WSACleanUp = SOCKET_ERROR then
      SocketError(WSAGetLastError);
  inherited Destroy;
end;

function TCustomWSocket.GetSockAddrIn(
         Host, Port: string; var SockAddrIn: TSockAddrIn): boolean;
var
  ProtoEnt: PProtoEnt;
  ServEnt: PServEnt;
  HostEnt: PHostEnt;
begin
  Result:= false;
  SockAddrIn.sin_family:= AF_INET;

  ProtoEnt:= getprotobynumber(FProtocol);
  if ProtoEnt = nil then
    begin
      SocketError(WSAGetLastError);
      Exit;
    end;

  ServEnt:= getservbyname(PAnsiChar(AnsiString(Port)), ProtoEnt^.p_name);
  if ServEnt = nil then
    SockAddrIn.sin_port:= htons(StrToInt(Port))
  else
    SockAddrIn.sin_port:= ServEnt^.s_port;

  SockAddrIn.sin_addr.s_addr:= inet_addr(PAnsiChar(AnsiString(Host)));
  if SockAddrIn.sin_addr.s_addr = Integer(INADDR_NONE) then
    begin
      HostEnt:= gethostbyname(PAnsiChar(AnsiString(Host)));
      if HostEnt = nil then
        begin
         SocketError(WSAGetLastError);
         Exit;
        end;
      SockAddrIn.sin_addr.S_addr:= longint(plongint(HostEnt^.h_addr_list^)^);
    end;
  Result:= true;
end;

function TCustomWSocket.GetAnySockAddrIn(
         Port: string; var SockAddrIn: TSockAddrIn): boolean;
var
  ProtoEnt: PProtoEnt;
  ServEnt: PServEnt;
begin
  Result:= false;
  SockAddrIn.sin_family:= AF_INET;

  ProtoEnt:= getprotobynumber(FProtocol);
  if ProtoEnt = nil then
    Exit;

  ServEnt:= getservbyname(PAnsiChar(AnsiString(Port)), ProtoEnt^.p_name);
  if ServEnt = nil then
    SockAddrIn.sin_port:= htons(StrToInt(Port))
  else
    SockAddrIn.sin_port:= ServEnt^.s_port;

  SockAddrIn.sin_addr.s_addr:= INADDR_ANY;
  Result:= true;
end;

function TCustomWSocket.GetBroadcastSockAddrIn(
         Port: string; var SockAddrIn: TSockAddrIn): boolean;
var
  ProtoEnt: PProtoEnt;
  ServEnt: PServEnt;
begin
  Result:= false;
  SockAddrIn.sin_family:= AF_INET;

  ProtoEnt:= getprotobynumber(FProtocol);
  if ProtoEnt = nil then
    Exit;

  ServEnt:= getservbyname(PAnsiChar(AnsiString(Port)), ProtoEnt^.p_name);
  if ServEnt = nil then
    SockAddrIn.sin_port:= htons(StrToInt(Port))
  else
    SockAddrIn.sin_port:= ServEnt^.s_port;

  SockAddrIn.sin_addr.s_addr:= Integer(INADDR_BROADCAST);
  Result:= true;
end;

function TCustomWSocket.SockAddrInToName(SockAddrIn: TSockAddrIn): string;
var
  HostEnt: PHostEnt;
begin
  HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
  if HostEnt <> nil then
    Result:= String(AnsiString(HostEnt.h_name));
end;

function TCustomWSocket.SockAddrInToAddress(SockAddrIn: TSockAddrIn): string;
begin
  Result:= String(AnsiString(inet_ntoa(SockAddrIn.sin_addr)));
end;

function TCustomWSocket.SockAddrInToPort(SockAddrIn: TSockAddrIn): string;
begin
  Result:= IntToStr(ntohs(SockAddrIn.sin_port));
end;

function TCustomWSocket.SocketToName(Socket: TSocket): string;
var
  SockAddrIn: TSockAddrIn;
  Len: integer;
  HostEnt: PHostEnt;
begin
  if Socket <> INVALID_SOCKET then
    begin
      Len:= SizeOf(SockAddrIn);
      if getsockname(Socket, SockAddrIn, Len) <> SOCKET_ERROR then
        begin
          HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
          if HostEnt <> nil then
            Result:= String(AnsiString(HostEnt.h_name));
        end;
    end;
end;

function TCustomWSocket.SocketToAddress(Socket: TSocket): string;
var
  SockAddrIn: TSockAddrIn;
  Len: integer;
begin
  if Socket <> INVALID_SOCKET then
    begin
      Len:= SizeOf(SockAddrIn);
      if getsockname(Socket, SockAddrIn, Len) <> SOCKET_ERROR then
        Result:= String(AnsiString(inet_ntoa(SockAddrIn.sin_addr)));
    end;
end;

function TCustomWSocket.SocketToPort(Socket: TSocket): string;
var
  SockAddrIn: TSockAddrIn;
  Len: integer;
begin
  if Socket <> INVALID_SOCKET then
    begin
      Len:= SizeOf(SockAddrIn);
      if getsockname(Socket, SockAddrIn, Len) <> SOCKET_ERROR then
        Result:= IntToStr(ntohs(SockAddrIn.sin_port));
    end;
end;

function TCustomWSocket.PeerToName(Socket: TSocket): string;
var
  SockAddrIn: TSockAddrIn;
  Len: integer;
  HostEnt: PHostEnt;
begin
  if Socket <> INVALID_SOCKET then
    begin
      Len:= SizeOf(SockAddrIn);
      if getpeername(Socket, SockAddrIn, Len) <> SOCKET_ERROR then
        begin
          HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
          if HostEnt <> nil then
            Result:= String(AnsiString(HostEnt.h_name));
        end;
    end;
end;

function TCustomWSocket.PeerToAddress(Socket: TSocket): string;
var
  SockAddrIn: TSockAddrIn;
  Len: integer;
begin
  if Socket <> INVALID_SOCKET then
    begin
      Len:= SizeOf(SockAddrIn);
      if getpeername(Socket, SockAddrIn, Len) <> SOCKET_ERROR then
        Result:= String(AnsiString(inet_ntoa(SockAddrIn.sin_addr)));
    end;
end;

function TCustomWSocket.PeerToPort(Socket: TSocket): string;
var
  SockAddrIn: TSockAddrIn;
  Len: integer;
begin
  if Socket <> INVALID_SOCKET then
    begin
      Len:= SizeOf(SockAddrIn);
      if getpeername(Socket, SockAddrIn, Len) <> SOCKET_ERROR then
        Result:= IntToStr(ntohs(SockAddrIn.sin_port));
    end;
end;

procedure TCustomWSocket.SocketClose(var Socket: TSocket; Handle: HWND);
var
  RC: integer;
begin
  if Socket <> INVALID_SOCKET then
    begin
      if WSAASyncSelect(Socket, Handle, WM_ASYNCSELECT, 0) <> 0 then
        begin
          SocketError(WSAGetLastError);
          Exit;
        end;

      if shutdown(Socket, 1) <> 0 then
        if WSAGetLastError <> WSAENOTCONN then
          begin
            SocketError(WSAGetLastError);
            Exit;
          end;

      repeat
        RC:= recv(Socket, FReadBuffer, SizeOf(TReadBuffer), 0);
      until (RC = 0) or (RC = SOCKET_ERROR);

      if closesocket(Socket) <> 0 then
        SocketError(WSAGetLastError)
      else
        Socket:= INVALID_SOCKET;
    end;
end;

function TCustomWSocket.SocketQueueSize(Socket: TSocket): longint;
var
  Size: longint;
begin
  Result:= 0;
  if ioctlsocket(Socket, FIONREAD, Size) <> 0 then
    SocketError(WSAGetLastError)
  else
    Result:= Size;
end;

procedure TCustomWSocket.SocketWrite(Socket: TSocket; Flag: integer; Data: string);
var
  TotSent, ToSend, Sent, ErrorLoop: integer;
begin
  if Data <> '' then
    begin
      ErrorLoop:= 0;
      TotSent:= 0;
      ToSend:= Length(Data);
      repeat
        Sent:= send(Socket, Data[TotSent+1], (ToSend-TotSent), Flag);
        if Sent = SOCKET_ERROR then
          begin
            Inc(ErrorLoop);
            if WSAGetLastError <> WSAEWOULDBLOCK then
              begin
                SocketError(WSAGetLastError);
                Exit;
              end;
          end
        else
          Inc(TotSent, Sent);
      until (TotSent >= ToSend) or (ErrorLoop > MAX_LOOP);
    end;
end;

function TCustomWSocket.SocketRead(Socket: TSocket; Flag: integer): string;
var
  Received: longint;
begin
  Result:= '';
  Received:= recv(Socket, FReadBuffer, SizeOf(TReadBuffer), Flag);
  if Received = SOCKET_ERROR then
    begin
      if WSAGetLastError <> WSAEWOULDBLOCK then
        SocketError(WSAGetLastError);
    end
  else
    begin
      SetLength(Result, Received);
      Move(FReadBuffer, Result[1], Received);
    end;
end;

function TCustomWSocket.SocketWriteBuffer(Socket: TSocket; Buffer: Pointer; Size, Flag: integer): integer;
begin
  Result:= send(Socket, Buffer^, Size, Flag);
  if Result = SOCKET_ERROR then
    begin
      Result:= 0;
      if WSAGetLastError <> WSAEWOULDBLOCK then
        SocketError(WSAGetLastError);
    end;
end;

function TCustomWSocket.SocketReadBuffer(Socket: TSocket; Buffer: Pointer; Size, Flag: integer): integer;
begin
  Result:= recv(Socket, Buffer^, Size, Flag);
  if Result = SOCKET_ERROR then
    begin
      Result:= 0;
      if WSAGetLastError <> WSAEWOULDBLOCK then
        SocketError(WSAGetLastError);
    end;
end;

procedure TCustomWSocket.SocketWriteTo(Socket: TSocket; Flag: integer; Data: string; var SockAddrIn: TSockAddrIn);
var
  TotSent, ToSend, Sent, ErrorLoop: integer;
begin
  if Data <> '' then
    begin
      ErrorLoop:= 0;
      TotSent:= 0;
      ToSend:= Length(Data);
      repeat
        Sent:= sendto(Socket, Data[TotSent+1], (ToSend-TotSent), Flag, SockAddrIn, SizeOf(SockAddrIn));
        if Sent = SOCKET_ERROR then
          begin
            Inc(ErrorLoop);
            if WSAGetLastError <> WSAEWOULDBLOCK then
              begin
                SocketError(WSAGetLastError);
                Exit;
              end;
          end
        else
          Inc(TotSent, Sent);
      until (TotSent >= ToSend) or (ErrorLoop > MAX_LOOP);
    end;
end;

function TCustomWSocket.SocketReadFrom(Socket: TSocket; Flag: integer; var SockAddrIn: TSockAddrIn): string;
var
  Len: integer;
  Received: longint;
begin
  Len:= SizeOf(SockAddrIn);
  Received:= recvfrom(Socket, FReadBuffer, SizeOf(TReadBuffer), Flag, SockAddrIn, Len);
  if Received = SOCKET_ERROR then
    begin
      if WSAGetLastError <> WSAEWOULDBLOCK then
        SocketError(WSAGetLastError);
    end
  else
    begin
      SetLength(Result, Received);
      Move(FReadBuffer, Result[1], Received);
    end;
end;

function TCustomWSocket.SocketWriteBufferTo(Socket: TSocket; Buffer: Pointer; Size, Flag: integer; var SockAddrIn: TSockAddrIn): integer;
begin
  Result:= sendto(Socket, Buffer^, Size, Flag, SockAddrIn, SizeOf(SockAddrIn));
  if Result = SOCKET_ERROR then
    begin
      Result:= 0;
      if WSAGetLastError <> WSAEWOULDBLOCK then
        SocketError(WSAGetLastError);
    end;
end;

function TCustomWSocket.SocketReadBufferFrom(Socket: TSocket; Buffer: Pointer; Size, Flag: integer; var SockAddrIn: TSockAddrIn): integer;
var
  Len: integer;
begin
  Len:= SizeOf(SockAddrIn);
  Result:= recvfrom(Socket, Buffer^, Size, Flag, SockAddrIn, Len);
  if Result = SOCKET_ERROR then
    begin
      Result:= 0;
      if WSAGetLastError <> WSAEWOULDBLOCK then
        SocketError(WSAGetLastError);
    end;
end;

procedure TCustomWSocket.SocketError(Error: integer);
begin
  FLastError:= Error;
  if Assigned(FOnError) then
    FOnError(Self, FLastError, LastErrorDesc);
end;

function TCustomWSocket.LastErrorDesc: string;
begin
  case FLastError of
    WSAEINTR           : Result:= 'Interrupted system call';
    WSAEBADF           : Result:= 'Bad file number';
    WSAEACCES          : Result:= 'Permission denied';
    WSAEFAULT          : Result:= 'Bad address';
    WSAEINVAL          : Result:= 'Invalid argument';
    WSAEMFILE          : Result:= 'Too many open files';
    WSAEWOULDBLOCK     : Result:= 'Operation would block';
    WSAEINPROGRESS     : Result:= 'Operation now in progress';
    WSAEALREADY        : Result:= 'Operation already in progress';
    WSAENOTSOCK        : Result:= 'Socket operation on nonsocket';
    WSAEDESTADDRREQ    : Result:= 'Destination address required';
    WSAEMSGSIZE        : Result:= 'Message too long';
    WSAEPROTOTYPE      : Result:= 'Protocol wrong type for socket';
    WSAENOPROTOOPT     : Result:= 'Protocol not available';
    WSAEPROTONOSUPPORT : Result:= 'Protocol not supported';
    WSAESOCKTNOSUPPORT : Result:= 'Socket not supported';
    WSAEOPNOTSUPP      : Result:= 'Operation not supported on socket';
    WSAEPFNOSUPPORT    : Result:= 'Protocol family not supported';
    WSAEAFNOSUPPORT    : Result:= 'Address family not supported';
    WSAEADDRINUSE      : Result:= 'Address already in use';
    WSAEADDRNOTAVAIL   : Result:= 'Can''t assign requested address';
    WSAENETDOWN        : Result:= 'Network is down';
    WSAENETUNREACH     : Result:= 'Network is unreachable';
    WSAENETRESET       : Result:= 'Network dropped connection on reset';
    WSAECONNABORTED    : Result:= 'Software caused connection abort';
    WSAECONNRESET      : Result:= 'Connection reset by peer';
    WSAENOBUFS         : Result:= 'No buffer space available';
    WSAEISCONN         : Result:= 'Socket is already connected';
    WSAENOTCONN        : Result:= 'Socket is not connected';
    WSAESHUTDOWN       : Result:= 'Can''t send after socket shutdown';
    WSAETOOMANYREFS    : Result:= 'Too many references:can''t splice';
    WSAETIMEDOUT       : Result:= 'Connection timed out';
    WSAECONNREFUSED    : Result:= 'Connection refused';
    WSAELOOP           : Result:= 'Too many levels of symbolic links';
    WSAENAMETOOLONG    : Result:= 'File name is too long';
    WSAEHOSTDOWN       : Result:= 'Host is down';
    WSAEHOSTUNREACH    : Result:= 'No route to host';
    WSAENOTEMPTY       : Result:= 'Directory is not empty';
    WSAEPROCLIM        : Result:= 'Too many processes';
    WSAEUSERS          : Result:= 'Too many users';
    WSAEDQUOT          : Result:= 'Disk quota exceeded';
    WSAESTALE          : Result:= 'Stale NFS file handle';
    WSAEREMOTE         : Result:= 'Too many levels of remote in path';
    WSASYSNOTREADY     : Result:= 'Network subsystem is unusable';
    WSAVERNOTSUPPORTED : Result:= 'Winsock DLL cannot support this application';
    WSANOTINITIALISED  : Result:= 'Winsock not initialized';
    WSAHOST_NOT_FOUND  : Result:= 'Host not found';
    WSATRY_AGAIN       : Result:= 'Non authoritative - host not found';
    WSANO_RECOVERY     : Result:= 'Non recoverable error';
    WSANO_DATA         : Result:= 'Valid name, no data record of requested type'
  else
    Result:= 'Not a Winsock error';
  end;
end;

function TCustomWSocket.GetLocalHostAddress: string;
var
  SockAddrIn: TSockAddrIn;
  HostEnt: PHostEnt;
  szHostName: array[0..128] of ansichar;
begin
  if gethostname(szHostName, 128) = 0 then
    begin
      HostEnt:= gethostbyname(szHostName);
      if HostEnt = nil then
        Result:= ''
      else
        begin
          SockAddrIn.sin_addr.S_addr:= longint(plongint(HostEnt^.h_addr_list^)^);
          Result:= String(AnsiString(inet_ntoa(SockAddrIn.sin_addr)));
        end;
    end
  else
    SocketError(WSAGetLastError);
end;

function TCustomWSocket.GetLocalHostName: string;
var
  szHostName: array[0..128] of ansichar;
begin
  if gethostname(szHostName, 128) = 0 then
    Result:= String(AnsiString(szHostName))
  else
    SocketError(WSAGetLastError);
end;

(**** TTCPClient Class ****)

constructor TTCPClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle:= AllocateHWnd(WndProc);
  FProtocol:= IPPROTO_TCP;
  FType:= SOCK_STREAM;
end;

destructor TTCPClient.Destroy;
begin
  Close;
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure TTCPClient.OpenConnection(Socket: TSocket; Error: word);
var
  EventMask: longint;
begin
  if Error <> 0 then
    SocketError(Error)
  else
    begin
      EventMask:= FD_READ or FD_CLOSE;
      if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, EventMask) <> 0 then
        SocketError(WSAGetLastError)
      else
        begin
          if Assigned(FOnConnect) then
            FOnConnect(Self, Socket);
          FSocketState:= ssConnected;
        end;
    end;
end;

procedure TTCPClient.CloseConnection(Socket: TSocket; Error: word);
begin
  if Error = WSAENETDOWN then
    SocketError(Error)
  else
    begin
      if Assigned(FOnClose) then
        FOnClose(Self, Socket);
      Close;
    end;
end;

procedure TTCPClient.IncommingData(Socket: TSocket; Error: word);
begin
  if Error <> 0 then
    SocketError(Error)
  else
    if Assigned(FOnData) then
      FOnData(Self, Socket);
end;

procedure TTCPClient.WndProc(var AMsg: TMessage);
var
  Error: word;
begin
  with AMsg do
    case Msg of
      WM_ASYNCSELECT:
        begin
          if (FSocketState = ssClosed) then
            Exit;
          Error:= WSAGetSelectError(LParam);
          case WSAGetSelectEvent(LParam) of
            FD_READ   : IncommingData(WParam, Error);
            FD_CONNECT: OpenConnection(WParam, Error);
            FD_CLOSE  : CloseConnection(WParam, Error);
          else
            if Error <> 0 then
              SocketError(Error);
          end;
        end;
    else
      Result:= DefWindowProc(FHandle, Msg, WParam, LParam);
    end;
end;

procedure TTCPClient.Open;
var
  SockAddrIn: TSockAddrIn;
  SockOpt: LongBool;
  EventMask: longint;
begin
  if (FSocketState <> ssClosed) then
    Exit;

  if not GetSockAddrIn(FHost, FPort, SockAddrIn) then
    Exit;

  FLocalSocket:= socket(PF_INET, FType, 0);
  if FLocalSocket = INVALID_SOCKET then
    begin
      SocketError(WSAGetLastError);
      Exit;
    end;

  EventMask:= (FD_CONNECT or FD_READ or FD_CLOSE);
  if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, EventMask) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  SockOpt:= true; {Enable OOB Data inline}
  if setsockopt(FLocalSocket, SOL_SOCKET, SO_OOBINLINE, PAnsiChar(@SockOpt), SizeOf(SockOpt)) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if connect(FLocalSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 then
    begin
      if WSAGetLastError <> WSAEWOULDBLOCK then
        begin
          SocketError(WSAGetLastError);
          closesocket(FLocalSocket);
          Exit;
        end;
    end;

  FSocketState:= ssOpen;
end;

procedure TTCPClient.Close;
begin
  if (FSocketState = ssNotStarted) or (FSocketState = ssClosed) then
    Exit;

  SocketClose(FLocalSocket, FHandle);
  if FLocalSocket = INVALID_SOCKET then
    FSocketState:= ssClosed;
end;

procedure TTCPClient.Write(Data: string);
begin
  SocketWrite(FLocalSocket, 0, Data);
end;

function TTCPClient.Read: string;
begin
  Result:= SocketRead(FLocalSocket, 0);
end;

function TTCPClient.Peek: string;
begin
  Result:= SocketRead(FLocalSocket, MSG_PEEK);
end;

function TTCPClient.WriteBuffer(Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketWriteBuffer(FLocalSocket, Buffer, Size, 0);
end;

function TTCPClient.ReadBuffer(Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketReadBuffer(FLocalSocket, Buffer, Size, 0);
end;

function TTCPClient.GetPeerAddress: string;
begin
  Result:= PeerToAddress(FLocalSocket);
end;

function TTCPClient.GetPeerPort: string;
begin
  Result:= PeerToPort(FLocalSocket);
end;

(**** TTCPServer Class ****)

constructor TTCPServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle:= AllocateHWnd(WndProc);
  FProtocol:= IPPROTO_TCP;
  FType:= SOCK_STREAM;
  FClients:= TClientList.Create;
end;

destructor TTCPServer.Destroy;
begin
  Close;
  DeallocateHWnd(FHandle);
  FClients.Free;
  inherited Destroy;
end;

procedure TTCPServer.OpenConnection(Socket: TSocket; Error: word);
var
  Len: integer;
  NewSocket: TSocket;
  SockAddrIn: TSockAddrIn;
  SockOpt: LongBool;
  EventMask: longint;
begin
  if Error <> 0 then
    SocketError(Error)
  else
    begin
      Len:= SizeOf(SockAddrIn);
      //{$IFDEF VER100} // Delphi 3
      NewSocket:= accept(FLocalSocket, @SockAddrIn, @Len);
      //{$ELSE}         // Delphi 2
      //NewSocket:= accept(FLocalSocket, SockAddrIn, Len);
      //{$ENDIF}
      if NewSocket = INVALID_SOCKET then
        begin
          SocketError(WSAGetLastError);
          Exit;
        end;

      EventMask:= (FD_READ or FD_CLOSE);
      if WSAASyncSelect(NewSocket, FHandle, WM_ASYNCSELECT, EventMask) <> 0 then
        begin
          SocketError(WSAGetLastError);
          closesocket(NewSocket);
          Exit;
        end;

      SockOpt:= true; {Enable OOB Data inline}
      if setsockopt(NewSocket, SOL_SOCKET, SO_OOBINLINE	, PAnsiChar(@SockOpt), SizeOf(SockOpt)) <> 0 then
        begin
          SocketError(WSAGetLastError);
          closesocket(NewSocket);
          Exit;
        end;

      if not FClients.Add(NewSocket) then
        SocketClose(NewSocket, FHandle)
      else
        if Assigned(FOnAccept) then
          FOnAccept(Self, NewSocket);
    end;
end;

procedure TTCPServer.CloseConnection(Socket: TSocket; Error: word);
begin
  if Error = WSAENETDOWN then
    SocketError(Error)
  else
    begin
      if Assigned(FOnClose) then
        FOnClose(Self, Socket);
      Disconnect(Socket);
    end;
end;

procedure TTCPServer.IncommingData(Socket: TSocket; Error: word);
begin
  if Error <> 0 then
    SocketError(Error)
  else
    if Assigned(FOnData) then
      FOnData(Self, Socket);
end;

procedure TTCPServer.WndProc(var AMsg: TMessage);
var
  Error: word;
begin
  with AMsg do
    case Msg of
      WM_ASYNCSELECT:
        begin
          if (FSocketState = ssClosed) then
            Exit;
          Error:= WSAGetSelectError(LParam);
          case WSAGetSelectEvent(LParam) of
            FD_READ  : IncommingData(WParam, Error);
            FD_ACCEPT: OpenConnection(WParam, Error);
            FD_CLOSE : CloseConnection(WParam, Error);
          else
            if Error <> 0 then
              SocketError(Error);
          end;
        end;
    else
      Result:= DefWindowProc(FHandle, Msg, WParam, LParam);
    end;
end;

procedure TTCPServer.Open;
var
  SockAddrIn: TSockAddrIn;
begin
  if (FSocketState <> ssClosed) then
    Exit;

  if not GetAnySockAddrIn(FPort, SockAddrIn) then
    Exit;

  FLocalSocket:= socket(PF_INET, FType, 0);
  if FLocalSocket = INVALID_SOCKET then
    begin
      SocketError(WSAGetLastError);
      Exit;
    end;

  if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, FD_ACCEPT) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if bind(FLocalSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if listen(FLocalSocket, 5) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  FSocketState:= ssListening;
end;

procedure TTCPServer.Close;
var
  i: integer;
  Dummy: TSocket;
begin
  if (FSocketState = ssNotStarted) or (FSocketState = ssClosed) then
    Exit;

  for i:= 0 to FClients.Count-1 do
    begin
      Dummy:= FClients[i];
      SocketClose(Dummy, FHandle);
    end;
  FClients.Clear;

  SocketClose(FLocalSocket, FHandle);
  if FLocalSocket = INVALID_SOCKET then
    FSocketState:= ssClosed;
end;

procedure TTCPServer.Write(Socket: TSocket; Data: string);
begin
  SocketWrite(Socket, 0, Data);
end;

function TTCPServer.Read(Socket: TSocket): string;
begin
  Result:= SocketRead(Socket, 0);
end;

function TTCPServer.Peek(Socket: TSocket): string;
begin
  Result:= SocketRead(Socket, MSG_PEEK);
end;

function TTCPServer.WriteBuffer(Socket: TSocket; Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketWriteBuffer(Socket, Buffer, Size, 0);
end;

function TTCPServer.ReadBuffer(Socket: TSocket; Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketReadBuffer(Socket, Buffer, Size, 0);
end;

procedure TTCPServer.Disconnect(Socket: TSocket);
begin
  FClients.Delete(Socket);
  SocketClose(Socket, FHandle);
end;

(**** TUDPClient Class ****)

constructor TUDPClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle:= AllocateHWnd(WndProc);
  FProtocol:= IPPROTO_UDP;
  FType:= SOCK_DGRAM;
end;

destructor TUDPClient.Destroy;
begin
  Close;
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure TUDPClient.IncommingData(Socket: TSocket; Error: word);
begin
  if Error <> 0 then
    SocketError(Error)
  else
    if Assigned(FOnData) then
      FOnData(Self, Socket);
end;

procedure TUDPClient.WndProc(var AMsg: TMessage);
var
  Error: word;
begin
  with AMsg do
    case Msg of
      WM_ASYNCSELECT:
        begin
          if (FSocketState = ssClosed) then
            Exit;
          Error:= WSAGetSelectError(LParam);
          case WSAGetSelectEvent(LParam) of
            FD_READ   : IncommingData(WParam, Error);
          else
            if Error <> 0 then
              SocketError(Error);
          end;
        end;
    else
      Result:= DefWindowProc(FHandle, Msg, WParam, LParam);
    end;
end;

procedure TUDPClient.Open;
var
  SockAddrIn: TSockAddrIn;
begin
  if (FSocketState <> ssClosed) then
    Exit;

  if not GetSockAddrIn(FHost, FPort, SockAddrIn) then
    Exit;

  FLocalSocket:= socket(PF_INET, FType, 0);
  if FLocalSocket = INVALID_SOCKET then
    begin
      SocketError(WSAGetLastError);
      Exit;
    end;

  if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, FD_READ) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if connect(FLocalSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 then
    begin
      if WSAGetLastError <> WSAEWOULDBLOCK then
        begin
          SocketError(WSAGetLastError);
          closesocket(FLocalSocket);
          Exit;
        end;
    end;

  FSocketState:= ssOpen;
end;

procedure TUDPClient.Close;
begin
  if (FSocketState = ssNotStarted) or (FSocketState = ssClosed) then
    Exit;

  SocketClose(FLocalSocket, FHandle);
  if FLocalSocket = INVALID_SOCKET then
    FSocketState:= ssClosed;
end;

procedure TUDPClient.Write(Data: string);
begin
  SocketWrite(FLocalSocket, 0, Data);
end;

function TUDPClient.Read: string;
begin
  Result:= SocketRead(FLocalSocket, 0);
end;

function TUDPClient.Peek: string;
begin
  Result:= SocketRead(FLocalSocket, MSG_PEEK);
end;

function TUDPClient.WriteBuffer(Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketWriteBuffer(FLocalSocket, Buffer, Size, 0);
end;

function TUDPClient.ReadBuffer(Buffer: Pointer; Size: integer): integer;
begin
  Result:= SocketReadBuffer(FLocalSocket, Buffer, Size, 0);
end;

function TUDPClient.GetPeerAddress: string;
begin
  Result:= PeerToAddress(FLocalSocket);
end;

function TUDPClient.GetPeerPort: string;
begin
  Result:= PeerToPort(FLocalSocket);
end;

(**** TUDPServer Class ****)

constructor TUDPServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHandle:= AllocateHWnd(WndProc);
  FProtocol:= IPPROTO_UDP;
  FType:= SOCK_DGRAM;
end;

destructor TUDPServer.Destroy;
begin
  Close;
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;

procedure TUDPServer.IncommingData(Socket: TSocket; Error: word);
begin
  if Error <> 0 then
    SocketError(Error)
  else
    if Assigned(FOnData) then
      FOnData(Self, Socket);
end;

procedure TUDPServer.WndProc(var AMsg: TMessage);
var
  Error: word;
begin
  with AMsg do
    case Msg of
      WM_ASYNCSELECT:
        begin
          if (FSocketState = ssClosed) then
            Exit;
          Error:= WSAGetSelectError(LParam);
          case WSAGetSelectEvent(LParam) of
            FD_READ  : IncommingData(WParam, Error);
          else
            if Error <> 0 then
              SocketError(Error);
          end;
        end;
    else
      Result:= DefWindowProc(FHandle, Msg, WParam, LParam);
    end;
end;

procedure TUDPServer.Open;
var
  SockAddrIn: TSockAddrIn;
  SockOpt: LongBool;
begin
  if (FSocketState <> ssClosed) then
    Exit;

  if not GetAnySockAddrIn(FPort, SockAddrIn) then
    Exit;

  FLocalSocket:= socket(PF_INET, FType, 0);
  if FLocalSocket = INVALID_SOCKET then
    begin
      SocketError(WSAGetLastError);
      Exit;
    end;

  if WSAASyncSelect(FLocalSocket, FHandle, WM_ASYNCSELECT, FD_READ) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  SockOpt:= true; {Enable Broadcasting on this Socket}
  if setsockopt(FLocalSocket, SOL_SOCKET, SO_BROADCAST, PAnsiChar(@SockOpt), SizeOf(SockOpt)) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  if bind(FLocalSocket, SockAddrIn, SizeOf(SockAddrIn)) <> 0 then
    begin
      SocketError(WSAGetLastError);
      closesocket(FLocalSocket);
      Exit;
    end;

  FSocketState:= ssListening;
end;

procedure TUDPServer.Close;
begin
  if (FSocketState = ssNotStarted) or (FSocketState = ssClosed) then
    Exit;

  SocketClose(FLocalSocket, FHandle);
  if FLocalSocket = INVALID_SOCKET then
    FSocketState:= ssClosed;
end;

procedure TUDPServer.Write(Socket: TSocket; Data: string; var SockAddrIn: TSockAddrIn);
begin
  SocketWriteTo(Socket, 0, Data, SockAddrIn);
end;

function TUDPServer.Read(Socket: TSocket; var SockAddrIn: TSockAddrIn): string;
begin
  Result:= SocketReadFrom(Socket, 0, SockAddrIn);
end;

function TUDPServer.Peek(Socket: TSocket; var SockAddrIn: TSockAddrIn): string;
begin
  Result:= SocketReadFrom(Socket, MSG_PEEK, SockAddrIn);
end;

function TUDPServer.WriteBuffer(Socket: TSocket; Buffer: Pointer; Size: integer; var SockAddrIn: TSockAddrIn): integer;
begin
  Result:= SocketWriteBufferTo(Socket, Buffer, Size, 0, SockAddrIn);
end;

function TUDPServer.ReadBuffer(Socket: TSocket; Buffer: Pointer; Size: integer; var SockAddrIn: TSockAddrIn): integer;
begin
  Result:= SocketReadBufferFrom(Socket, Buffer, Size, 0, SockAddrIn);
end;

end.