fpc/fcl/tests/dsocksvr.pp

Program server;
{
    $Id$
    This file is part of the Free Component Library (FCL)
    Copyright (c) 1999-2000 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    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.

 **********************************************************************}

{
  Dual server program. This will listen on port 4100 till
  a client connects if '-i' is on the command-line.
  Otherwise it will open a unix socket. You can connect by
  running the 'sockcli' or 'dsockcli' programs in another
  terminal.

  specifying -b on the command-line will disable blocking.
}
{$mode objfpc} {$H+}
uses sysutils,ssockets,getopts;

const
  ThePort=4100;
  TheSocket = 'ServerSoc';

Var
  DoInet,NonBlocking : boolean;

Type
  TServerApp = Class(TObject)
  Private
    FCalls : longint;
    FServer : TSocketServer;
  Public
    Constructor Create(Port : longint);
    Constructor Create(Socket : String);
    Destructor Destroy;override;
    Procedure OnConnect (Sender : TObject; Data : TSocketStream);
    Procedure OnIdle(Sender : TObject);
    Procedure Run;
  end;

Constructor TServerApp.Create(Port : longint);

begin
  FServer:=TINetServer.Create(Port);
  FServer.OnConnect:=@OnConnect;
end;

Constructor TServerApp.Create(Socket : String);

begin
  FServer:=TUnixServer.Create(Socket);
  FServer.OnConnect:=@OnConnect;
end;

Destructor TServerApp.Destroy;

begin
  FServer.Free;
end;

Procedure TServerApp.OnConnect (Sender : TObject; Data : TSocketStream);


Var Buf : ShortString;
    Count : longint;

begin
  Repeat
    Count:=Data.Read(Buf[1],255);
    SetLength(Buf,Count);
    Write('Server got : ',Buf);
  Until (Count=0) or (Pos('QUIT',Buf)<>0);
  Data.Free;
  FServer.StopAccepting;
end;

Procedure TServerApp.OnIdle(Sender : TObject);

begin
  Inc(FCalls);
  Write('.');
end;
Procedure TServerApp.Run;

begin
  Write ('Listening on ');
  if FServer is TUnixServer Then
    Writeln ('socket : ',(FServer as TUnixServer).Filename)
  else If FServer is TINetServer Then
    Writeln ('port : ',(FServer as TInetServer).port);
  If NonBlocking then
    begin
    FServer.SetNonBlocking;
    FServer.OnIdle:=@OnIdle;
    end;
  FServer.StartAccepting;
end;

Var
  Application : TServerApp;
  c : char;

begin
  DoInet:=False;
  NonBlocking:=False;
  repeat
    c:=getopt('ib');
    case c of
    'b' : NonBlocking:=True;
    'i' : DoInet:=True;
    end;
  until c=EndOfOptions;
  If DoInet then
    Application:=TServerApp.Create(ThePort)
  else
    Application:=TServerApp.Create(TheSocket);
  Application.Run;
  Application.Free;
end.

{
  $Log$
  Revision 1.5  2005-03-16 13:35:59  marco
   * some fixes for objfpc mode

  Revision 1.4  2005/02/14 17:13:18  peter
    * truncate log

}