Freelog 11/Freelog011.iso/BestOf/PhoenixMail/Source/comps/WinSocket.pas

Pascal/Delphi Source File | 1999-02-20 | 19KB | 584 lines

{*****************************************************************************
 *
 *  WinSocket.pas - TWinSocket Component
 *
 *  Copyright (c) 1999 Michael Haller
 *
 *  Based on the component from Tom Bradford
 *    (C) 1997 By Beach Dog Software, Inc.
 *    http://www.beachdogsoftware.com
 *  parts copied from Gary Desrosiers
 *
 *  Author:     Michael Haller
 *  E-mail:     [e-mail]
 *  Homepage:   http://www.discountdrive.com/sunrise/
 *
 *  This program is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU General Public License
 *  as published by the Free Software Foundation;
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
 *
 *----------------------------------------------------------------------------
 *
 *  Revision history:
 *
 *     DATE     REV                 DESCRIPTION
 *  ----------- --- ----------------------------------------------------------
 *
 *****************************************************************************}

unit WinSocket;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Winsock;

const
  WM_ASYNCSELECT = WM_USER + 60;

type
  TWinSocket = class;

  TOnErrorEvent = procedure(Sender: TObject; Msg: String) of object;
  TOnConnectEvent = procedure(Sender: TObject) of object;
  TOnCloseEvent = procedure(Sender: TObject) of object;
  TOnReadEvent = procedure(Sender: TObject; Value: String) of object;
  TOnWriteEvent = procedure(Sender: TObject; Value: String) of object;
  TOnAcceptEvent = procedure(Sender: TObject) of object;
  TOnAutoAcceptEvent = procedure(Sender: TObject; ListenSocket, OpenSocket: TWinSocket) of object;

  TWinSocket = class(TCustomControl)
  private
    FSocket: TSocket;
    FConnected: Boolean;
    FHostName: String;
    FPortName: String;
    FListen: Boolean;
    FAutoAccept: Boolean;
    FOutBuffer: String;
    FInBuffer: String;
    FCharBuf: array[1..32768] of Char;
    FBlocking: Boolean;
    FBlockTime: Integer;
    FOnError: TOnErrorEvent;
    FOnConnect: TOnConnectEvent;
    FOnClose: TOnCloseEvent;
    FOnRead: TOnReadEvent;
    FOnWrite: TOnWriteEvent;
    FOnAccept: TOnAcceptEvent;
    FOnAutoAccept: TOnAutoAcceptEvent;
    procedure SetBlocking(Value: Boolean);
    //private
    function PortLookup(Value: String): U_Short;
    function HostLookup(Value: String): TInAddr;
    procedure SocketError(SockFunc: String; Error: Integer);
  protected
    procedure WMAsyncSelect(var Message: TMessage); message WM_ASYNCSELECT;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Open;
    procedure Listen;
    procedure Close;
    procedure Send(Value: String);
    function Receive: String;
    property Connected: Boolean read FConnected;
    property Socket: TSocket read FSocket;
  published
    property PortName: String read FPortName write FPortName;
    property HostName: String read FHostName write FHostName;
    property AutoAccept: Boolean read FAutoAccept write FAutoAccept;
    property Blocking: Boolean read FBlocking write SetBlocking;
    property BlockTime: Integer read FBlockTime write FBlockTime;
    property OnError: TOnErrorEvent read FOnError write FOnError;
    property OnConnect: TOnConnectEvent read FOnConnect write FOnConnect;
    property OnClose: TOnCloseEvent read FOnClose write FOnClose;
    property OnWrite: TOnWriteEvent read FOnWrite write FOnWrite;
    property OnRead: TOnReadEvent read FOnRead write FOnRead;
    property OnAccept: TOnAcceptEvent read FOnAccept write FOnAccept;
    property OnAutoAccept: TOnAutoAcceptEvent read FOnAutoAccept write FOnAutoAccept;
  end;

function GetWinsockDescription: String;
function GetWinsockSystemStatus: String;
function GetLocalHostName: String;

procedure Register;

implementation

type
  TSockThread = class(TThread)
  private
    ParentSocket: TWinSocket;
    ListenSocket: TWinSocket;
    OpenSocket: TWinSocket;
  public
    procedure Execute; override;
    procedure RunThread(ParentSocket, ListenSocket, OpenSocket: TWinSocket);
  end;

//const
  //INADDR_NONE: Longint = -1;

var
  WSAData: TWSAData;
  IPCache: TStringList;

////////////////////////////////////////////////////////////////////////////////

procedure TSockThread.Execute;
begin
  ParentSocket.OnAutoAccept(ParentSocket, ListenSocket, OpenSocket);
  ListenSocket.Close;
  OpenSocket.Close;
  ListenSocket.Free;
  OpenSocket.Free;
  ListenSocket := nil;
  OpenSocket := nil;
  ParentSocket := nil;
  Terminate;
end;

procedure TSockThread.RunThread(ParentSocket, ListenSocket, OpenSocket: TWinSocket);
begin
  Self.ParentSocket := ParentSocket;
  Self.ListenSocket := ListenSocket;
  Self.OpenSocket := OpenSocket;
  FreeOnTerminate := True;
  Resume;
end;

////////////////////////////////////////////////////////////////////////////////

constructor TWinSocket.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHostName := '';
  FPortName := '';
  FConnected := False;
  FListen := False;
  FBlocking := True;
  FAutoAccept := False;
  FBlockTime := 0;
  FSocket := INVALID_SOCKET;
  FOutBuffer := '';
  FInBuffer := '';
  if csDesigning in ComponentState then begin
    SetZOrder(True);
  end else begin
    Width := 0;
    Height := 0;
    SetZOrder(False);
    Visible := False;
  end;
end;

destructor TWinSocket.Destroy;
begin
  if FListen or FConnected then Close;
  inherited Destroy;
end;

procedure TWinSocket.WMSize(var Message: TWMSize);
begin
  inherited;
  if csDesigning in ComponentState then begin
    Width := 120;
    Height := 40;
  end;
  Message.Result := 0;
end;

procedure TWinSocket.Send(Value: String);
var
  Remain : Integer;
  S: String;
begin
  if FSocket = INVALID_SOCKET then Exit;
  if FListen then Exit;
  FOutBuffer := FOutBuffer + Value;
  if FOutBuffer = '' then Exit;
  if FBlocking then begin
    Remain := Length(FOutBuffer);
    while Remain > 0 do begin
      S := FOutBuffer;
      Remain := WinSock.Send(FSocket, FOutBuffer[1], Length(FOutBuffer), 0);
      if (Remain = SOCKET_ERROR) and (WinSock.WSAGetLastError <> WSAEINPROGRESS) then begin
        SocketError('Send', WSAGetLastError);
        Exit;
      end;
      if Remain > 0 then Delete(FOutBuffer, 1, Remain);
      Remain := Length(FOutBuffer);
    end;
    FOutBuffer := '';
    if Assigned(FOnWrite) then FOnWrite(Self, S);
  end else begin
    Remain := WinSock.Send(FSocket, FOutBuffer[1], Length(FOutBuffer), 0);
    if Assigned(FOnWrite) then FOnWrite(Self, Copy(FOutBuffer, 1, Remain));
    if Remain > 0 then Delete(FOutBuffer, 1, Remain);
  end;
end;

function TWinSocket.Receive: String;
var
  Res: Integer;
  FDSet: PFDSet;
  TV: PTimeVal;
begin
  Result := '';
  if (FSocket = INVALID_SOCKET) and (FInBuffer = '') then Exit;
  if FListen then Exit;
  if FBlocking then begin
    FDSet := New(PFDSet);
    FDSet^.FD_Count := 1;
    FDSet^.FD_Array[0] := FSocket;
    if FBlockTime >= 0 then begin
      TV := New(PTimeVal);
      TV^.tv_sec := FBlockTime;
    end else TV := nil;
    if FConnected and (Select(FSocket, FDSet, nil, nil, TV) > 0) then begin
      Res := Recv(FSocket, FCharBuf, SizeOf(FCharBuf), 0);
      if (Res = SOCKET_ERROR) then begin
        FInBuffer := '';
        Dispose(FDSet);
        Dispose(TV);
        SocketError('Receive', WSAGetLastError);
        Exit;
      end;
      if Res > 0 then FInBuffer := FInBuffer + Copy(FCharBuf, 1, Res);
      if Res = 0 then begin
        Close;
        if Assigned(FOnClose) then FOnClose(Self);
      end;
    end;
    Result := FInBuffer;
    FInBuffer := '';
    Dispose(FDSet);
    Dispose(TV);
  end else begin
    Result := FInBuffer;
    FInBuffer := '';
  end;
end;

procedure TWinSocket.WMAsyncSelect(var Message: TMessage);
var
  Error: Word;
  Res, AddrL: Integer;
  Addr: TSockAddrIn;
  ListenSocket, OpenSocket: TWinSocket;
  SockThread : TSockThread;
begin
  inherited;
  Error := WinSock.WSAGetSelectError(Message.LParam);
  if Error > WSABASEERR then begin
    SocketError('WSAAsyncSelect', Error);
    Exit;
  end;
  case WinSock.WSAGetSelectEvent(Message.LParam) of
    FD_ACCEPT: begin
      if FAutoAccept and Assigned(FOnAutoAccept) then begin
        // the main program is responsible to free ListenSocket and...
        // ...OpenSocket in Non Blocking Mode
        ListenSocket := TWinSocket.Create(Self);
        ListenSocket.Parent := Self;
        AddrL := SizeOf(Addr);
        FillChar(Addr, AddrL, #0);
        ListenSocket.FSocket := Accept(FSocket, @Addr, @AddrL);
        ListenSocket.FBlockTime := FBlockTime;
        ListenSocket.FOnRead := FOnRead;
        ListenSocket.FOnWrite := FOnWrite;
        ListenSocket.FOnClose := FOnClose;
        ListenSocket.FOnError := FOnError;
        ListenSocket.FPortname := FPortName;
        ListenSocket.FHostName := INet_NToA(Addr.SIn_Addr);
        ListenSocket.SetBlocking(FBlocking);
        ListenSocket.FConnected := True;
        OpenSocket := TWinSocket.Create(Self);
        OpenSocket.Parent := Self;
        OpenSocket.FBlockTime := FBlockTime;
        OpenSocket.FOnError := FOnError;
        OpenSocket.SetBlocking(FBlocking);
        if FBlocking then begin
          SockThread := TSockThread.Create(True);
          SockThread.RunThread(Self, ListenSocket, OpenSocket);
        end else
          FOnAutoAccept(Self, ListenSocket, OpenSocket);
      end else
        if Assigned(FOnAccept) then FOnAccept(Self);
    end;
    FD_CONNECT: begin
      FConnected := True;
      if Assigned(FOnConnect) then FOnConnect(Self);
    end;
    FD_CLOSE: begin
      Close;
      if Assigned(FOnClose) then FOnClose(Self);
    end;
    FD_WRITE: if FOutBuffer <> '' then Send('');
    FD_READ: begin
      Res := Recv(FSocket, FCharBuf, SizeOf(FCharBuf), 0);
      if Res > 0 then begin
        FInBuffer := FInBuffer + Copy(FCharBuf, 1, Res);
        if Assigned(FOnRead) then FOnRead(Self, Copy(FCharBuf, 1, Res));
      end;
    end;
  end;
  Message.Result := 0;
end;

procedure TWinSocket.WMPaint(var Message: TWMPaint);
begin
  inherited;
  if csDesigning in ComponentState then begin
    Canvas.Brush.Color := clBtnFace;
    Canvas.Pen.Color := clBlack;
    Canvas.RectAngle(0, 0, Width, Height);
    Canvas.TextOut(4, 4, 'TWinSocket');
    Canvas.TextOut(4, 20, '(c) 1999 Michael Haller');
  end;
  Message.Result := 0;
end;

function TWinSocket.PortLookup(Value: String): U_Short;
var
  PEnt: PServEnt;
begin
  Result := 0;
  if Pos(Value[1], '0123456789') > 0 then Result := HToNS(StrToInt(Value)) else begin
    PEnt := WinSock.GetServByName(PChar(Value), PChar('tcp'));
    if PEnt <> nil then Result := PEnt^.S_Port else SocketError('GetServByName', WSAGetLastError);
  end;
end;

function TWinSocket.HostLookup(Value: String): TInAddr;
type
  PLongInt = ^Longint;
var
  PHost: PHostEnt;
  Res: Integer;
begin
   Result.S_Addr := HToNL(INADDR_ANY);
   if Value = '' then Exit;
   FillChar(Result, SizeOf(TInAddr), #0);
   if Pos(Value[1],'0123456789') > 0 then Result := TInAddr(WinSock.Inet_Addr(PChar(Value))) else begin
     Res := IPCache.IndexOf(Value);
     if Res >= 0 then Result.S_Addr := U_Long(IPCache.Objects[Res]) else begin
       PHost := GetHostByName(PChar(Value));
       if PHost <> nil then begin
         Result.S_Addr := Longint(PLongInt(PHost^.H_Addr_List^)^);
         IPCache.AddObject(Value, Pointer(Result.S_Addr));
       end else SocketError('GetHostByName', WSAGetLastError);
     end;
   end;
end;

procedure TWinSocket.SetBlocking(Value: Boolean);
var
  I: U_Long;
begin
  if (not (csDesigning in ComponentState)) and (csReading in ComponentState) then begin
    FBlocking := Value;
    Exit;
  end;
  if FSocket = INVALID_SOCKET then FBlocking := Value else begin
    FBlocking := Value;
    if Parent = nil then begin
      Parent := Screen.Forms[0];
      HandleNeeded;
    end;
    if FBlocking and (FListen = False) then begin
      //WSAAsyncSelect(FSocket, Handle, WM_ASYNCSELECT, 0);
      //I := 0;
      //IOCtlSocket(FSocket, FIONBIO, I);
    end else begin
      if FListen then I := FD_ACCEPT else I := FD_READ or FD_CLOSE or FD_CONNECT or FD_WRITE or FD_READ;
      WSAAsyncSelect(FSocket, Handle, WM_ASYNCSELECT, I);
    end;
  end;
end;

procedure TWinSocket.Open;
var
  Res: Integer;
  FSockAddrIn: TSockAddrIn;
begin
  FConnected := False;
  if FSocket <> INVALID_SOCKET then Exit;
  FSocket := WinSock.Socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
  SetBlocking(FBlocking);
  FSockAddrIn.SIn_Family := AF_INET;
  FSockAddrIn.SIn_Port := PortLookup(FPortName);
  FSockAddrIn.SIn_Addr := HostLookup(FHostName);
  Res := Connect(FSocket, FSockAddrIn, SizeOf(TSockAddrIn));
  if FBlocking = False then Exit;
  if Res = 0 then begin
    FConnected := True;
    if Assigned(FOnConnect) then FOnConnect(Self);
  end else begin
    SocketError('Connect', WSAGetLastError);
    Close;
  end;
end;

procedure TWinSocket.Close;
begin
  WSACancelBlockingCall;
  ShutDown(FSocket, 2);
  if FBlocking = False then
    try WSAAsyncSelect(FSocket, Handle, WM_ASYNCSELECT, 0); except end;
  CloseSocket(FSocket);
  FSocket := INVALID_SOCKET;
  FConnected := False;
  FListen := False;
end;

procedure TWinSocket.Listen;
var
  Addr: TSockAddr;
begin
  FSocket := WinSock.Socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
  FillChar(Addr, SizeOf(Addr), #0);
  Addr.SIn_Family := AF_INET;
  Addr.SIn_Port := PortLookup(FPortName);
  Addr.SIn_Addr.S_Addr := HToNL(INADDR_ANY);
  FListen := True;
  SetBlocking(FBlocking);
  FListen := False;
  if Bind(FSocket, Addr, SizeOf(Addr)) <> 0 then begin
    SocketError('Bind', WSAGetLastError);
    Exit;
  end;
  if Winsock.Listen(FSocket, 5) <> 0 then begin
    SocketError('Listen', WSAGetLastError);
    Exit;
  end;
  FListen := True;
end;

procedure TWinSocket.SocketError(SockFunc: String; Error: Integer);
var
  S: String;
begin
  case Error of
    WSAEINTR: S := 'Interrupted system call';
    WSAEBADF: S := 'Bad file number';
    WSAEACCES: S := 'Permission denied';
    WSAEFAULT: S := 'Bad address';
    WSAEINVAL: S := 'Invalid argument';
    WSAEMFILE: S := 'Too many open files';
    WSAEWOULDBLOCK: S := 'Operation would block, but socket in nonblock mode';
    WSAEINPROGRESS: S := 'Operation now in progress';
    WSAEALREADY: S := 'Operation already in progress';
    WSAENOTSOCK: S := 'Socket operation on non-socket';
    WSAEDESTADDRREQ: S := 'Destination address required';
    WSAEMSGSIZE: S := 'Message too long';
    WSAEPROTOTYPE: S := 'Protocol wrong type for socket';
    WSAENOPROTOOPT: S := 'Protocol not available';
    WSAEPROTONOSUPPORT: S := 'Protocol not supported';
    WSAESOCKTNOSUPPORT: S := 'Socket type not supported';
    WSAEOPNOTSUPP: S := 'Operation not supported on socket';
    WSAEPFNOSUPPORT: S := 'Protocol family not supported';
    WSAEAFNOSUPPORT: S := 'Address family not supported by protocol family';
    WSAEADDRINUSE: S := 'Address already in use';
    WSAEADDRNOTAVAIL: S := 'Can''t assign requested address';
    WSAENETDOWN: S := 'Network is down';
    WSAENETUNREACH: S := 'Network is unreachable';
    WSAENETRESET: S := 'Network dropped connection on reset';
    WSAECONNABORTED: S := 'Software caused connection abort';
    WSAECONNRESET: S := 'Connection reset by peer';
    WSAENOBUFS: S := 'No buffer space available';
    WSAEISCONN: S := 'Socket is already connected';
    WSAENOTCONN: S := 'Socket is not connected';
    WSAESHUTDOWN: S := 'Can''t send after socket ShutDown';
    WSAETOOMANYREFS: S := 'Too many references: can''t splice';
    WSAETIMEDOUT: S := 'Connection timed out';
    WSAECONNREFUSED: S := 'Connection refused';
    WSAELOOP: S := 'Too many levels of symbolic links';
    WSAENAMETOOLONG: S := 'File name too long';
    WSAEHOSTDOWN: S := 'Host is down';
    WSAEHOSTUNREACH: S := 'No route to host';
    WSAENOTEMPTY: S := 'Directory not empty';
    WSAEPROCLIM: S := 'Too many processes';
    WSAEUSERS: S := 'Too many users';
    WSAEDQUOT: S := 'Disk quota exceeded';
    WSAESTALE: S := 'Stale NFS file handle';
    WSAEREMOTE: S := 'Too many levels of remote in path';
    WSASYSNOTREADY: S := 'WinSock DLL not found, or not responding';
    WSAVERNOTSUPPORTED: S := 'Your WinSock DLL is an old version';
    WSANOTINITIALISED: S := 'WinSock has not yet been initialized';
    WSAHOST_NOT_FOUND: S := 'Host not found';
    WSATRY_AGAIN: S := 'Host not found';
    WSANO_RECOVERY: S := 'Non-recoverable error';
    WSANO_DATA: S := 'No Data; perhaps no route to host';
    else S := 'Error undefined in WinSock v1.1 spec';
  end;
  if SockFunc = '' then S := S else S := 'Code '+IntToStr(Error)+' in function '+SockFunc+#13+#10+S;
  if Assigned(FOnError) then FOnError(Self, S) else raise Exception.Create(S);
end;

////////////////////////////////////////////////////////////////////////////////

function GetWinsockDescription: String;
begin
  Result := StrPas(WSAData.szDescription);
end;

function GetWinsockSystemStatus: String;
begin
  Result := StrPas(WSAData.szSystemStatus);
end;

function GetLocalHostName: String;
var
  szHostName: array[0..255] of char;
  pHost: PHostEnt;
  addr: TSockAddrIn;
  Paddr: ^TSockAddrIn;
  LocalHName: String;
begin
  GetHostName(szHostName, 255);
  pHost := GetHostByName(szHostName);
  if pHost = nil then
    Result := 'localhost'
  else begin
    LocalHName := StrPas(pHost^.h_name);
    if Length(LocalHName) = 0 then Result := 'localhost' else begin
      addr.sin_addr.s_addr := longint(pLongInt(pHost^.h_addr_list^)^);
      Paddr:= @addr.sin_addr.s_addr;
      pHost := GetHostByAddr(pLongInt(Paddr), 4, PF_INET);
      if pHost = nil then Result := LocalHName else Result:= StrPas(pHost^.h_name);
    end;
  end;
end;

procedure Register;
begin
   RegisterComponents('Phoenix', [TWinSocket]);
end;

////////////////////////////////////////////////////////////////////////////////

initialization
  if WSAStartup($101, WSAData) <> 0 then raise Exception.Create('Could Not Initialize WinSock');
  IPCache := TStringList.Create;

finalization
  IPCache.Free;
  WSACleanup;

end.