wsockets.pas

Winsock para comunica&ccedil &atilde o tcp Ip

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 <[e-mail]>

  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: [e-mail] 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:= StrPas(szDescription);
          FSystemStatus:= StrPas(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(PChar(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(PChar(Host));
  if SockAddrIn.sin_addr.s_addr = INADDR_NONE then
    begin
      HostEnt:= gethostbyname(PChar(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(PChar(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);