1Program server;
2{
3    This file is part of the Free Component Library (FCL)
4    Copyright (c) 1999-2000 by the Free Pascal development team
5
6    See the file COPYING.FPC, included in this distribution,
7    for details about the copyright.
8
9    This program is distributed in the hope that it will be useful,
10    but WITHOUT ANY WARRANTY; without even the implied warranty of
11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 **********************************************************************}
14
15{
16  Dual server program. This will listen on port 4100 till
17  a client connects if '-i' is on the command-line.
18  Otherwise it will open a unix socket. You can connect by
19  running the 'sockcli' or 'dsockcli' programs in another
20  terminal.
21
22  specifying -b on the command-line will disable blocking.
23}
24{$mode objfpc} {$H+}
25uses sysutils,ssockets,getopts;
26
27const
28  ThePort=4100;
29  TheSocket = 'ServerSoc';
30
31Var
32  DoInet,NonBlocking : boolean;
33
34Type
35  TServerApp = Class(TObject)
36  Private
37    FCalls : longint;
38    FServer : TSocketServer;
39  Public
40    Constructor Create(Port : longint);
41    Constructor Create(Socket : String);
42    Destructor Destroy;override;
43    Procedure OnConnect (Sender : TObject; Data : TSocketStream);
44    Procedure OnIdle(Sender : TObject);
45    Procedure Run;
46  end;
47
48Constructor TServerApp.Create(Port : longint);
49
50begin
51  FServer:=TINetServer.Create(Port);
52  FServer.OnConnect:=@OnConnect;
53end;
54
55Constructor TServerApp.Create(Socket : String);
56
57begin
58  FServer:=TUnixServer.Create(Socket);
59  FServer.OnConnect:=@OnConnect;
60end;
61
62Destructor TServerApp.Destroy;
63
64begin
65  FServer.Free;
66end;
67
68Procedure TServerApp.OnConnect (Sender : TObject; Data : TSocketStream);
69
70
71Var Buf : ShortString;
72    Count : longint;
73
74begin
75  Repeat
76    Count:=Data.Read(Buf[1],255);
77    SetLength(Buf,Count);
78    Write('Server got : ',Buf);
79  Until (Count=0) or (Pos('QUIT',Buf)<>0);
80  Data.Free;
81  FServer.StopAccepting;
82end;
83
84Procedure TServerApp.OnIdle(Sender : TObject);
85
86begin
87  Inc(FCalls);
88  Write('.');
89end;
90Procedure TServerApp.Run;
91
92begin
93  Write ('Listening on ');
94  if FServer is TUnixServer Then
95    Writeln ('socket : ',(FServer as TUnixServer).Filename)
96  else If FServer is TINetServer Then
97    Writeln ('port : ',(FServer as TInetServer).port);
98  If NonBlocking then
99    begin
100    FServer.SetNonBlocking;
101    FServer.OnIdle:=@OnIdle;
102    end;
103  FServer.StartAccepting;
104end;
105
106Var
107  Application : TServerApp;
108  c : char;
109
110begin
111  DoInet:=False;
112  NonBlocking:=False;
113  repeat
114    c:=getopt('ib');
115    case c of
116    'b' : NonBlocking:=True;
117    'i' : DoInet:=True;
118    end;
119  until c=EndOfOptions;
120  If DoInet then
121    Application:=TServerApp.Create(ThePort)
122  else
123    Application:=TServerApp.Create(TheSocket);
124  Application.Run;
125  Application.Free;
126end.
127