1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

Program server;
{
    $Id: dsocksvr.pp,v 1.5 2005/03/16 13:35:59 marco Exp $
    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: dsocksvr.pp,v $  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 
}