(*
  Simple Synchronous Socket communications component for Delphi.
  Author: Carl Smotricz
  Date: August 2001

  Change log:
  $Log: socketcomm.pas,v $
  Revision 1.4  2001/08/09 06:40:19  Carl
  (1) Renamed TSocketConnection to TSocketComm
  (2) Cleaned up event handling (callbacks are synchronous now)
  (3) Various fixes for cleanliness and stability.

  Revision 1.3  2001/08/08 09:45:41  Carl
  synchronized receive

  Revision 1.2  2001/08/08 08:47:06  Carl
  Extensive modifications for more stable multitasking,
  including semaphores around 'close'.

  Revision 1.1  2001/08/03 19:46:37  Carl
  New communications module, initial version.

*)
unit SocketComm;

interface

uses Classes, Syncobjs, SysUtils, Windows, Winsock;

type
  TSocketComm = class;

  TSocketCommConn =  procedure(aConnection: TSocketComm) of object;
  TSocketCommData =  procedure(aConnection: TSocketComm;
                               aData: String) of object;
  TSocketCommDisco = procedure(aConnection: TSocketComm) of object;
  TSocketCommError = procedure(aConnection: TSocketComm;
                               aCode: Integer; aMessage: String;
                               var handled: boolean) of object;

  TSocketComm = class(TComponent)
  private
    fHost: String;
    fPort: Integer;
    fOnConn: TSocketCommConn;
    fOnData: TSocketCommData;
    fOnDisco: TSocketCommDisco;
    fOnError: TSocketCommError;
    fReceiver: TThread;
    fSemaphore: TCriticalSection;
    fSocket: Integer;
    procedure error(aCode: Integer; aMessage: String);
    procedure errorFmt(aCode: Integer; aMessage: String; aArgs: Array of const);
    class function getLastError: Integer;
    function isConnected: boolean;
    procedure signalData;
    procedure signalDisconnect;
    procedure signalError;
  public
    Constructor Create(aOwner: TComponent); override;
    Destructor Destroy; override;
    procedure Close;
    procedure Open(host: String; port: integer);
    function Send(data: String): Integer;
  published
    property Connected: boolean read isConnected;
    property Host: String read fHost;
    property Lasterror: Integer read getLastError;
    property OnConnect: TSocketCommConn read fOnConn write fOnConn;
    property OnData: TSocketCommData read fOnData write fOnData;
    property OnDisconnect: TSocketCommDisco read fOnDisco write fOnDisco;
    property OnError: TSocketCommError read fOnError write fOnError;
    property Port: Integer read fPort;
  end;

implementation

const
  BUFFER_SIZE = 1024;

type
  TRecvThread = class(TThread)
  private
    fBuffer: String;
    fConn: TSocketComm;
    fDataQueue: TStringList;
    fErrorCode: Integer;
    fErrorMessage: String;
  protected
    procedure Execute; override;
  public
    constructor CreateConn(aConn: TSocketComm);
    destructor Destroy; override;
    function getData: String;
  end;

var
  Instances: Integer;

{ TSocketComm }

{ == Close down this connection }
procedure TSocketComm.Close;
begin
  if isConnected then begin
    closeSocket(fSocket);
    while isConnected do sleep(10);
  end;
end;

{ == Create a SocketConnection object.
     Start up Windows Sockets plumbing. }
constructor TSocketComm.Create;
var
  wsaData: TWSAData;
begin
  if WSAStartup($101, wsaData) <> 0 then begin
    error(6, 'Unable to initialize WinSock');
    raise Exception.create('Unable to initialize WinSock');
  end;
  fSemaphore := TCriticalSection.Create;
  Inc(instances);
end;

{ == Clean up the connection before this thing goes away. }
destructor TSocketComm.Destroy;
begin
  Close;
  fSemaphore.Free;
  Dec(instances);
  if (instances <= 0) then WSACleanup;
end;

{ == Handle an error, with a message }
procedure TSocketComm.error(aCode: Integer; aMessage: String);
var
  handled: boolean;
begin
  handled := false;
  if assigned(fOnError) then fOnError(self, aCode, aMessage, handled);
end;

{ == Handle an error, with a formatted message }
procedure TSocketComm.errorFmt(aCode: Integer; aMessage: String;
  aArgs: array of const);
var
  handled: boolean;
begin
  handled := false;
  if assigned(fOnError) then fOnError(self, aCode, Format(aMessage, aArgs), handled);
  if not handled then begin
    raise Exception.CreateFmt('TSocketComm exception %d: %s',
      [aCode, Format(aMessage, aArgs)]);
  end;
end;

{ == Return the last socket error from the WinSock plumbing }
class function TSocketComm.getLastError: Integer;
begin
  Result := WSAGetLastError;
end;

{ == Determine whether there is currently a connection }
function TSocketComm.isConnected: boolean;
begin
  Result := (fPort <> -1) and (fSocket <> 0);
end;

{ == Start up a socket and its receiving Thread. }
Procedure TSocketComm.Open(host: String; port: Integer);
var
  a: TSockAddrIn;
  h: PHostEnt;
begin
  if isConnected then Close;
  if host = '' then error(1, 'Host name not set');
  h := getHostByName(PChar(host));
  if h = nil then errorFmt(2, 'Could not resolve host name "%s"', [host]);
  FillChar(a, SizeOf(a), 0);
  with a.sin_addr, h^ 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;
  a.sin_family := AF_INET;
  a.sin_port := htons(port);
  fSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
  if fSocket = 0 then error(3, 'Could not create socket');
  if connect(fSocket, a, sizeof(a)) <> 0 then
    errorFmt(4, 'Cannot establish connection; Status: %d', [WSAGetLastError]);
  // Connection successful - set fHost and fPort for reference
  fHost := host;
  fPort := port;
  if Assigned(fOnConn) then fOnConn(self);
  fReceiver := TRecvThread.createConn(self);
end;

{ == Send some data over the line }
function TSocketComm.Send(data: String): Integer;
var
  status: Integer;
begin
  fSemaphore.Enter;
  status := Winsock.send(fSocket, data[1], Length(data), 0);
  fSemaphore.Leave;
  if status < 0 then begin
    error(lastError, 'Error on send');
    Result := SOCKET_ERROR;
  end else begin
    Result := 0;
  end;
end;

{ == Indicate that data is available. }
procedure TSocketComm.signalData;
var
  Data: String;
begin
  Data := TRecvThread(fReceiver).getData;
  if Assigned(fOnData) then fOnData(self, Data);
end;

{ == Tell the application about our disconnect }
procedure TSocketComm.signalDisconnect;
begin
  if Assigned(fOnDisco) then fOnDisco(self);
  fHost := '';
  fPort := -1;
end;

{ == Tell the application about our error }
procedure TSocketComm.signalError;
var
  handled: boolean;
  code: integer;
  msg: String;
begin
  handled := false;
  code := TRecvThread(fReceiver).fErrorCode;
  msg := TRecvThread(fReceiver).fErrorMessage;
  if Assigned(fOnError) then fOnError(self, code, msg, handled);
  if not handled then begin
    raise Exception.CreateFmt('TSocketComm exception %d: %s', [code, msg]);
  end;
end;

{ TRecvThread }

{ == Create this thread with a SocketConnection }
constructor TRecvThread.CreateConn(aConn: TSocketComm);
begin
  inherited Create(false);
  fConn := aConn;
  fDataQueue := TStringList.Create;
end;

{ == Free this Thread's resources. }
destructor TRecvThread.Destroy;
begin
  fDataQueue.Free;
  inherited;
end;

{ == What TRecvThread does. }
procedure TRecvThread.Execute;
var
  n: Integer;
begin
  while (fConn.fSocket <> 0) do begin
    SetLength(fBuffer, BUFFER_SIZE);
    n := Winsock.recv(fConn.fSocket, fBuffer[1], BUFFER_SIZE, 0);
    if n > BUFFER_SIZE then begin
      fErrorCode := 17;
      fErrorMessage := 'Buffer overrun';
      Synchronize(fConn.signalError);
    end else if (n > 0) then begin
      // successful receive
      SetLength(fBuffer, n);
      if Assigned(fConn.fOnData) then begin
        fConn.fSemaphore.enter;
        fDataQueue.append(String(fBuffer));
        fConn.fSemaphore.leave;
        Synchronize(fConn.signalData);
      end;
    end else if n = 0 then begin
      // disconnected
      closeSocket(fConn.fSocket);
      fConn.fSocket := 0;
    end else begin
      // error
      fErrorCode := fConn.lastError;
      fErrorMessage := 'Receive error';
      closeSocket(fConn.fSocket);
      fConn.fSocket := 0;
      Synchronize(fConn.signalError);
    end;
  end; //while
  Synchronize(fConn.signalDisconnect);
end;

{ == Get all current data as one string from the receive queue }
function TRecvThread.getData: String;
var
  j: Integer;
begin
  Result := '';
  fConn.fSemaphore.enter;
  for j := 0 to fDataQueue.Count - 1 do Result := Result + fDataQueue[j];
  fDataQueue.Clear;
  fConn.fSemaphore.leave;
end;

initialization
  instances := 0;
end.