scktconnect.pas

boomerang library 5.11 internet ed

(* ScktConnect - socket connection library
 * Copyright (C) 2001 Tomas Mandys-MandySoft
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA  02111-1307  USA
 *)

{ URL: http://www.2p.cz }

unit ScktConnect;

{ ScktConnect.htx }

{ DONE 1.10.2003 thread terminate bug fixed }

interface
uses
  Classes, Connect, ScktComp, WinSock, Windows;

type
  TClientSocketConnection = class;

  TClientSocketThread = class(TThread)
  private
    FConnection: TClientSocketConnection;
  protected
    procedure Execute; override;
    procedure DoOnSignal;
  public
    constructor Create(aConnection: TClientSocketConnection);
  end;

  TClientSocketConnection = class(TCommunicationConnection)
  private
    FPort: Integer;
    FHost: string;
    FAddress: string;
    FService: string;
    FSocket: TCustomWinSocket;
    FEventThread: TClientSocketThread;
    procedure SetAddress(Value: string);
    procedure SetHost(Value: string);
    procedure SetPort(Value: Integer);
    procedure SetService(Value: string);
  protected
    procedure OpenConn; override;
    procedure CloseConn; override;
    function Write(var Buf; Count: Integer): Integer; override;
    function Read(var Buf; Count: Integer): Integer; override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    function InQueCount: Integer; override;
    procedure PurgeIn; override;
    procedure PurgeOut; override;
    property Socket: TCustomWinSocket read FSocket;
  published
    property Address: 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;
    property OnRxChar;
  end;

procedure Register;

implementation

resourcestring
  sCannotOpenSocket = 'Cannot open socket';

{ TClientSocketConnection }

constructor TClientSocketConnection.Create(aOwner: TComponent);
begin
  inherited;
end;

destructor TClientSocketConnection.Destroy;
begin
  inherited;
end;

procedure TClientSocketConnection.OpenConn;
begin
  FSocket:= TCustomWinSocket.Create(INVALID_SOCKET);
  FSocket.ASyncStyles:= [];
  FSocket.Open(FHost, FAddress, FService, FPort{$IFNDEF VER120}, True{ctBlocking}{$ENDIF});
  if not FSocket.Connected then
    raise EConnectError.Create(sCannotOpenSocket);
  FEventThread:= TClientSocketThread.Create(Self);
end;

procedure TClientSocketConnection.CloseConn;
begin
  if FEventThread <> nil then
  begin
    FEventThread.Free;   // Terminate and WaitFor is inside Destroy, FreeOnTerminate = False
    FEventThread:= nil;  
  end;
  PurgeIn; // remove pending queue chars if not processed in OnRxChar
  FSocket.Free;
  FSocket:= nil;
end;

procedure TClientSocketConnection.SetAddress(Value: string);
begin
  CheckInactive;
  FAddress:= Value;
end;

procedure TClientSocketConnection.SetHost(Value: string);
begin
  CheckInactive;
  FHost:= Value;
end;

procedure TClientSocketConnection.SetPort(Value: Integer);
begin
  CheckInactive;
  FPort:= Value;
end;

procedure TClientSocketConnection.SetService(Value: string);
begin
  CheckInactive;
  FService:= Value;
end;

function TClientSocketConnection.InQueCount: Integer;
begin
  if Active then
  begin
    Result:= FSocket.ReceiveLength;
  end else Result:= -1;
end;

procedure TClientSocketConnection.PurgeIn;
var
  C: Char;
begin
  if Active and (FSocket <> nil) then
  begin
    FSocket.Lock;
    try
      while Integer(FSocket.ReceiveLength) > 0 do
        FSocket.ReceiveBuf(C, 1);
    finally
      FSocket.Unlock;
    end;
  end;
end;

procedure TClientSocketConnection.PurgeOut;
begin
  if Active then;
end;

function TClientSocketConnection.Read(var Buf; Count: Integer): Integer;
begin
  Result:= FSocket.ReceiveBuf(Buf, Count);
end;

function TClientSocketConnection.Write(var Buf; Count: Integer): Integer;
begin
  Result:= FSocket.SendBuf(Buf, Count);
end;

{ TClientSocketThread }

constructor TClientSocketThread.Create(aConnection: TClientSocketConnection);
begin
  FreeOnTerminate := False;
  FConnection:= aConnection;
  inherited Create(False{create non suspended});
  Priority := tpLower;
end;

procedure TClientSocketThread.DoOnSignal;
begin
  FConnection.DoOnRxChar(FConnection.FSocket.ReceiveLength);
end;

procedure TClientSocketThread.Execute;
begin
  while not Terminated do
  begin
    if FConnection.Socket.ReceiveLength > 0 then
      if FConnection.DontSynchronize then DoOnSignal
                                     else Synchronize(DoOnSignal);
    Sleep(100); // don't eat 100% CPU time
  end;
end;

procedure Register;
begin
  RegisterComponents('Communication', [TClientSocketConnection]);
end;

end.