Italian community of Lazarus and Free Pascal

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes, SysUtils, CustApp, echo, Unit_Operazioni
  { you can add units after this };

  { add your program here }

  app:=TTCPEchoDaemon.create;
  app.Execute;
  // stop program loop
  Terminate;

program serverSock;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes, SysUtils, CustApp, echo, Unit_Operazioni
  { you can add units after this };

type

  { TMyServer }

  TMyServer = class(TCustomApplication)
  protected
    procedure DoRun; override;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure WriteHelp; virtual;
  end;

{ TMyServer }

procedure TMyServer.DoRun;
var
  ErrorMsg: String;
  app: TTCPEchoDaemon;
begin
  // quick check parameters
  ErrorMsg:=CheckOptions('h','help');
  if ErrorMsg'' then begin
    ShowException(Exception.Create(ErrorMsg));
    Terminate;
    Exit;
  end;

  // parse parameters
  if HasOption('h','help') then begin
    WriteHelp;
    Terminate;
    Exit;
  end;

  { add your program here }
  app:=TTCPEchoDaemon.create;
  app.Execute;
  // stop program loop
  Terminate;
end;

constructor TMyServer.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  StopOnException:=True;
end;

destructor TMyServer.Destroy;
begin
  inherited Destroy;
end;

procedure TMyServer.WriteHelp;
begin
  { add your help code here }
  writeln('Usage: ',ExeName,' -h');
end;

var
  Application: TMyServer;
begin
  Application:=TMyServer.Create(nil);
  Application.Title:='My Server Test';
  Application.Run;
  Application.Free;
end.

unit echo;

interface

uses
  Classes, blcksock, synsock, sysutils, users,  baseunix, Unit_Operazioni;

type
  TTCPEchoDaemon = class(TThread)
  private
    Sock:TTCPBlockSocket;
  public
    Constructor Create;
    Destructor Destroy; override;
    procedure Execute; override;
  end;

  TTCPEchoThrd = class(TThread)
  private
    Sock:TTCPBlockSocket;
    CSock: TSocket;
  public
    Constructor Create (hsock:tSocket);
    procedure Execute; override;
  end;

implementation

{ TEchoDaemon }

Constructor TTCPEchoDaemon.Create;
begin
  inherited create(false);
  sock:=TTCPBlockSocket.create;
  FreeOnTerminate:=true;
end;

Destructor TTCPEchoDaemon.Destroy;
begin
  Sock.free;
end;

procedure TTCPEchoDaemon.Execute;
var
  ClientSock:TSocket;
  Porta: string;
  Host: string;
begin
  Porta:='2408';
  Host:='0.0.0.0';
  with sock do
    begin
      CreateSocket;
      setLinger(true,10000);
      bind(Host,Porta);
      listen;
      repeat
        if terminated then break;
        if canread(1000) then
          begin
            ClientSock:=accept;
            if lastError=0 then TTCPEchoThrd.create(ClientSock);
          end;
      until false;
    end;
end;

{ TEchoThrd }

Constructor TTCPEchoThrd.Create(Hsock:TSocket);
begin
  inherited create(false);
  Csock := Hsock;
  FreeOnTerminate:=true;
end;

procedure TTCPEchoThrd.Execute;
var
  s: string;
begin
  sock:=TTCPBlockSocket.create;
  try
    Sock.socket:=CSock;
    sock.GetSins;
    with sock do
      begin
        repeat
          if terminated then break;
          s := RecvPacket(60000);
          //devo eliminare i caratteri di andata a capo, altrimenti sono
          //nella stringa letta e non riesco a fare i controlli
          s:=stringReplace(s, #13 , '', [RfReplaceAll]);
          s:=stringReplace(s, #10 , '', [RfReplaceAll]);
          if lastError0 then break;

          if s='GETDATE' then
          begin
               GetDate(sock);
          end
          else if s='GETHOUR' then
          begin
               GetHour(sock);
          end
          else if s='GETMENU' then
          begin
               GetMenu(sock);
          end
          else
          begin
               SendString('Comando non valido: ' + s + System.LineEnding);
               SendString('Comandi validi: ' + System.LineEnding);
               SendString('GETDATE' + System.LineEnding);
               SendString('GETHOUR' + System.LineEnding);
               SendString('GETMENU' + System.LineEnding);
          end;
          writeln(Sock.GetRemoteSinIP + ': '+ IntToStr(Sock.GetRemoteSinPort) + ' (' + IntToStr(Self.ThreadID) + ')--> ' + s);

          if lastError0 then break;
        until false;
      end;
  finally
    Sock.Free;
  end;
end;

end.

          s := RecvPacket(60000);
          //devo eliminare i caratteri di andata a capo, altrimenti sono
          //nella stringa letta e non riesco a fare i controlli
          s:=stringReplace(s, #13 , '', [RfReplaceAll]);
          s:=stringReplace(s, #10 , '', [RfReplaceAll]);

          if s='GETDATE' then
          begin
               GetDate(sock);
          end
          else if s='GETHOUR' then
          begin
               GetHour(sock);
          end
          else if s='GETMENU' then
          begin
               GetMenu(sock);
          end
          else
          begin
               SendString('Comando non valido: ' + s + System.LineEnding);
               SendString('Comandi validi: ' + System.LineEnding);
               SendString('GETDATE' + System.LineEnding);
               SendString('GETHOUR' + System.LineEnding);
               SendString('GETMENU' + System.LineEnding);
          end;

writeln(Sock.GetRemoteSinIP + ': '+ IntToStr(Sock.GetRemoteSinPort) + ' (' + IntToStr(Self.ThreadID) + ')--> ' + s);

unit Unit_Operazioni;

{$mode objfpc}{$H+}

interface

uses
  Classes, blcksock, synsock, sysutils, users,  baseunix ;

  procedure GetDate(var sock: TTCPBlockSocket);
  procedure GetHour(var sock: TTCPBlockSocket);
  procedure GetMenu(var sock: TTCPBlockSocket);
implementation

procedure GetDate(var sock: TTCPBlockSocket);
begin
     with sock do
     begin
          SendString(DateToStr(Date) + System.LineEnding);
     end;
end;

procedure GetHour(var sock: TTCPBlockSocket);
begin
  with sock do
  begin
     SendString(TimeToStr(Time) + System.LineEnding);
  end;
end;

procedure GetMenu(var sock: TTCPBlockSocket);
begin
  with sock do
  begin
     SendString('-------------------------------------' + System.LineEnding);
     SendString('|    PROVA DI UN                           |' + System.LineEnding);
     SendString('|           SEMPLICE                         |' + System.LineEnding);
     SendString('|                   MENU                        |' + System.LineEnding);
     SendString('|                       !!!                         |' + System.LineEnding);
     SendString('-------------------------------------' + System.LineEnding);
  end;
end;

end.