source: trunk/UTCP.pas

unit UTCP;

{$mode Delphi}{$H+}

interface

uses
  Classes, SysUtils,
  {$IFDEF WINDOWS}
  WinSock,
  {$ELSE}
  baseunix, sockets,
  //LibC,
  {$ENDIF}
  ssockets, fphttpserver, UPool, UResetableThread;

type
  TTCPServer = class;

  { TTCPClientThread }

  TTCPClientThread = class(TResetableThread)
    Parent: TTCPServer;
    Socket: TSocketStream;
    procedure Execute;
    constructor Create;
    destructor Destroy; override;
  end;

  { TClientThreadedPool }

  TClientThreadedPool = class(TThreadPool)
  protected
    function NewItemObject: TObject; override;
  private
    FActive: Boolean;
    procedure SetActive(const AValue: Boolean);
  public
    property Active: Boolean read FActive write SetActive;
  end;

  { TAcceptThread }

  TAcceptThread = class(TThread)
    Parent: TTCPServer;
    procedure Execute; override;
  end;


  { TTCPServer }

  TTCPServer = class
  private
    FOnClientConnect: TNotifyEvent;
    FSocket: TInetServer;
    FActive: Boolean;
    FAcceptThread: TAcceptThread;
    procedure SetActive(const AValue: Boolean);
    procedure ConnectExecute(Sender : TObject; Data : TSocketStream);
  public
    ThreadPool: TClientThreadedPool;
    Address: string;
    Port: Word;
    constructor Create;
    destructor Destroy; override;
    property Active: Boolean read FActive write SetActive;
    property OnClientConnect: TNotifyEvent read FOnClientConnect
      write FOnClientConnect;
  end;

  { TTCPClient }

  TTCPClient = class
  private
    FActive: Boolean;
    FSocket: TInetSocket;
    procedure SetActive(AValue: Boolean);
  public
    Address: string;
    Port: Word;
    constructor Create;
    destructor Destroy; override;
    property Socket: TInetSocket read FSocket;
    property Active: Boolean read FActive write SetActive;
  end;


implementation

{ TAcceptThread }

procedure TAcceptThread.Execute;
begin
  Parent.FSocket.StartAccepting;
end;

{ TTCPClient }

procedure TTCPClient.SetActive(AValue: Boolean);
begin
  if AValue and not FActive then begin
    FSocket := TInetSocket.Create(Address, Port);
    with FSocket do begin
      Connect;
      if LastError <> 0 then raise Exception.Create('Socket connect error');
    end;
  end else
  if not AValue and FActive then begin
    with FSocket do begin
      FreeAndNil(FSocket);
    end;
  end;
  FActive := AValue;
end;

constructor TTCPClient.Create;
begin
  FSocket := nil;
  Address := '0.0.0.0';
  Port := 80;
end;

destructor TTCPClient.Destroy;
begin
  Active := False;
  FSocket.Free;
  inherited Destroy;
end;

{ TTCPServer }

procedure TTCPServer.SetActive(const AValue: Boolean);
begin
  if AValue and not FActive then begin
    ThreadPool.Active := True;
    FSocket := TInetServer.Create(Address, Port);
    //SetLinger(True, 10);
    FSocket.OnConnect := ConnectExecute;
    FSocket.Bind;
    FSocket.Listen;
    FAcceptThread := TAcceptThread.Create(True);
    FAcceptThread.Parent := Self;
    FAcceptThread.FreeOnTerminate := False;
    FAcceptThread.Start;
  end else
  if not AValue and FActive then begin
    FAcceptThread.Terminate;
    FAcceptThread.WaitFor;
    FreeAndNil(FAcceptThread);
    ThreadPool.Active := False;
    FreeAndNil(FSocket);
  end;
  FActive := AValue;
end;

constructor TTCPServer.Create;
begin
  ThreadPool := TClientThreadedPool.Create;
  ThreadPool.TotalCount := 10;
  ThreadPool.Active := True;

  FSocket := nil;
  Address := '0.0.0.0';
  Port := 80;
end;

destructor TTCPServer.Destroy;
begin
  ThreadPool.Destroy;
  Active := False;
  inherited Destroy;
end;

procedure TTCPServer.ConnectExecute(Sender : TObject; Data : TSocketStream);
var
  NewSocket: TSocket;
  NewObject: TTCPClientThread;
begin
  NewObject := TTCPClientThread(ThreadPool.Acquire);
  NewObject.Parent := Self;
  NewObject.Socket := Data;
  NewObject.Start;
end;

{ TTCPClientThread }

procedure TTCPClientThread.Execute;
begin
  if Assigned(Parent.FOnClientConnect) then
    Parent.FOnClientConnect(Self);

  Parent.ThreadPool.Release(Self);
end;

constructor TTCPClientThread.Create;
begin
  inherited;
  Method := Execute;
  Socket := nil;
end;

destructor TTCPClientThread.Destroy;
begin
  Socket.Free;
  inherited;
end;

{ TClientThreadedPool }

function TClientThreadedPool.NewItemObject: TObject;
begin
  Result := TTCPClientThread.Create;
  TResetableThread(Result).OnException := ThreadException;
end;

procedure TClientThreadedPool.SetActive(const AValue: Boolean);
begin
  FActive := AValue;
end;

end.