Dear
i Try to create a socket server on 9000 port,
there is no real examples using Indy on linux without using the
component in a form.
I'm trying to write a tcp socket server on unix by command line ...
Is there anybody already develop a SMTP server or socket server using
Indy component without using a TForm ??
Best regards
here it is my example that does not working
program indysmtp;
*********************************************************************************************
{$mode objfpc}{$H+}
uses
cthreads, Classes, smtpserv;
var SMTPSERVER:TSmtpServ;
begin
SMTPSERVER.Create();
readln();
end.
The port is open but when sending datas to it, the port will
automatically disconnect itself
*********************************************************************************************
unit smtpserv;
{$MODE DELPHI}
{$LONGSTRINGS ON}
interface
uses
SysUtils, Variants, Classes, Dialogs, IdBaseComponent, IdComponent,
IdCustomTCPServer,IdTCPServer, IdContext, IdIntercept,
IdServerInterceptLogBase, IdServerInterceptLogFile,IdSync;
type
TClientinfo = class(TIdContext)
public
IP: String;
cname: String;
procedure SendResponse(const Clientname: String;const
AResponse: String);
end;
TWriteResponse = class(TIdSync)
protected
FMsg: String;
procedure DoSynchronize; override;
public
constructor Create(const AResponse: String);
class procedure AddResponse(const AResponse: String);
end;
TSmtpServ = class
IdTCPServer1: TIdTCPServer;
IdServerInterceptLogFile1: TIdServerInterceptLogFile;
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure IdTCPServer1Disconnect(AContext: TIdContext);
procedure IdTCPServer1Execute(AContext: TIdContext);
constructor Create();
procedure Free();
private
{ Private declarations }
public
{ Public declarations }
end;
implementation
procedure TSmtpServ.IdTCPServer1Connect(AContext: TIdContext);
begin
with TClientinfo(AContext) do
begin
if (Connection.Socket <> nil) then
IP :=Connection.Socket.Binding.PeerIP;
cname := Connection.IOHandler.ReadLn;
if cname <> ''then
begin
connection.IOHandler.WriteLn('Welcome '+ cname);
end
else
//Client did not send a name...
begin
connection.IOHandler.WriteLn('You did not send a name.
Please send a name next time you try to connect!');
connection.Disconnect;
end;
end; end;
procedure TSmtpServ.IdTCPServer1Disconnect(AContext: TIdContext);
begin
TWriteResponse.AddResponse(TClientinfo(AContext).cname + 'Disconnected');
end;
procedure TSmtpServ.IdTCPServer1Execute(AContext: TIdContext);
var
thedate,request,cmd,response,AFormat,sentfrom:string;
i,j:integer;
arr:Array[1..6] of String;
begin
//the request from the client is received in the request var
request:=acontext.Connection.IOHandler.ReadLn;
// we need to break the request up into command(cmd) and sender
writeln(request);
//showmessage(cmd+'===>'+sentfrom);
//Check which command the client sent
//Send the response to the client...
TClientinfo(AContext).SendResponse(sentfrom,arr[i]);
end;
procedure TClientInfo.SendResponse(const Clientname: String;
const AResponse: String);
var
List: TList;
Context: TClientInfo;
I: Integer;
begin
// FContextList is inherited from TIdContext
List := FContextList.LockList;
try
for I := 0 to List.Count-1 do
begin
Context := TClientInfo(List[I]);
if Context.cname = clientname then
begin
try
Context.Connection.IOHandler.WriteLn(AResponse);
except
end;
Exit;
end;
end;
finally
FContextList.UnlockList;
end;
Self.Connection.IOHandler.WriteLn('this server cannot find the
client you sent the message to.');
end;
constructor TWriteResponse.Create(const AResponse: String);
begin
FMsg := AResponse;
inherited Create;
end;
procedure TWriteResponse.DoSynchronize;
begin
writeln(FMsg);
end;
class procedure TWriteResponse.AddResponse (const AResponse:
String);
begin
with Create(AResponse) do try
Synchronize;
finally
Free;
end;
end;
constructor TSmtpServ.Create();
begin
inherited Create();
idTCPServer1.ContextClass := TClientinfo;
idTCPServer1.Bindings.Add.Port:=9000;
idtcpserver1.Active:=true;
idtcpserver1.StartListening;
end;
procedure TSmtpServ.Free();
begin
idtcpserver1.Active:=false;
end;
end.
--
David Touzeau -------------------------- Linux Ubuntu 7.04 feisty
FreePascal-Lazarus,perl,delphi,php artica for postfix management console
(http://www.artica.fr) icq:160018849
_______________________________________________
fpc-devel maillist - fpc-devel@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-devel
