In a Lazarus (freepascal) project I added a TAsyncProcess with those options: [poUsePipes,poStderrToOutPut] to catch the output and show the last line.
using the ReadData event, I added some code that show the last line if I grab some text:
procedure TForm1.AsyncProcess1ReadData(Sender: TObject);
var
aOutput: TStringList;
iCpt: integer;
sLine: string;
begin
aOutput := TStringList.Create();
aOutput.LoadFromStream(AsyncProcess1.Output);
if (aOutput.Count > 0) then
begin
setStatus(aOutput.Strings[aOutput.Count-1]);
end;
end;
then I tryed to get the last non-empty line:
procedure TForm1.AsyncProcess1ReadData(Sender: TObject);
var
aOutput: TStringList;
iCpt: integer;
sLine: string;
begin
aOutput := TStringList.Create();
aOutput.LoadFromStream(AsyncProcess1.Output);
if (aOutput.Count > 0) then
begin
// Get the last non-empty line
for iCpt := (aOutput.Count-1) to 0 do
begin
sLine := aOutput.Strings[iCpt];
if Length(Trim(sLine)) > 0 then
begin
setStatus(sLine);
Break;
end;
end;
end;
end;
Both shows nothing. I've used the first code with ffmpeg with success.
Thanks!
Related
how are you?
I come here ask for a solution, how prevent TIdTcpServer stuck connections?
Version of indy 10.6.2.5341 and Rad Studio 10.1 Berlin
On both images show the number of connections on TIdTcpServer, these numbers are retrieved from this function:
var
NumClients: Integer;
begin
with Form1.IdTCPServer1.Contexts.LockList do
try
NumClients := Count;
finally
Form1.IdTCPServer1.Contexts.UnlockList;
end;
Result := NumClients;
What happen is, in almost cases this numbers only increase and not decrease. so i believe connections are being stucked on TIdTcpServer.
I use a IdSchedulerOfThreadDefault1 on Scheduler, i don't know if that change something or no but i added.
For manage connections i use ContextClass:
IdTCPServer1.ContextClass := TClientContext;
Who definition is:
type
TCommand = (
cmdConnect,
cmdDisconnect,
cmdHWID,
cmdScreenShotData,
cmdMensagem);
type
TClient = record
HWID : String[40];
Tempo : TDateTime;
Msg : String[100];
end;
const
szClient = SizeOf(TClient);
type
TProtocol = record
Command: TCommand;
Sender: TClient;
DataSize: Integer;
end;
const
szProtocol = SizeOf(TProtocol);
type
TClientContext = class(TIdServerContext)
private
FCriticalSection : TCriticalSection;
FClient : TClient;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
public
procedure Lock;
procedure Unlock;
public
property Client: TClient read FClient write FClient;
end;
Others functions who are used:
procedure InitProtocol(var AProtocol: TProtocol);
begin
FillChar(AProtocol, szProtocol, 0);
end;
function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
begin
SetLength(Result, szProtocol);
Move(AProtocol, Result[0], szProtocol);
end;
constructor TClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
FCriticalSection := TCriticalSection.Create;
end;
destructor TClientContext.Destroy;
begin
FreeAndNil(FCriticalSection);
inherited;
end;
procedure TClientContext.Lock;
begin
FCriticalSection.Enter;
end;
procedure TClientContext.Unlock;
begin
FCriticalSection.Leave;
end;
function BytesToProtocol(const ABytes: TBytes): TProtocol;
begin
Move(ABytes[0], Result, szProtocol);
end;
procedure ClearBuffer(var ABuffer: TBytes);
begin
SetLength(ABuffer, 0);
end;
procedure ClearBufferId(var ABuffer: TIdBytes);
begin
SetLength(ABuffer, 0);
end;
All events (connect/disconnect) i manage on IdTCPServer1Execute
like this example above:
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LBuffer : TIdBytes;
LProtocol : TProtocol;
FTempBuffer : TIdBytes;
Enviar : TBytes;
Protocolo : TProtocol;
Conexao : TClientContext;
//
Queue: TStringList;
List: TStringList;
x : Integer;
//
procedure AddToMemo(const AStr: string);
begin
TThread.Synchronize(nil,
procedure
begin
Memo1.Lines.Add(AStr);
Form1.StatusBar1.Panels[0].Text := Format('Connections [%d]', [RetornaOn]);
end
);
end;
begin
Conexao := TClientContext(AContext);
// QUEUE
List := nil;
try
Queue := Conexao.Queue.Lock;
try
if Queue.Count > 0 then
begin
List := TStringList.Create;
List.Assign(Queue);
Queue.Clear;
end;
finally
Conexao.Queue.Unlock;
end;
if List <> nil then
begin
for x := 0 to List.Count-1 do
begin
InitProtocol(Protocolo);
Protocolo.Command := cmdMensagem;
Protocolo.Sender.Msg := Edit2.Text;
Enviar := ProtocolToBytes(Protocolo);
Conexao.Connection.IOHandler.Write(PTIdBytes(#Enviar)^);
ClearBuffer(Enviar);
end;
// Delete Queue
for x := 0 to List.Count-1 do
begin
List.Delete(x);
end;
end;
finally
List.Free;
end;
// QUEUE
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
//AddToMemo(Format('[%s] Running 1 ...', [TimeToStr(Now)]));
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
{AddToMemo(Format('[%s] Running 2 ...', [TimeToStr(Now)]));
if GetTickDiff(Conexao.Client.Tick, Ticks) >= 10000 then
begin
AddToMemo(Format('[%s] Running 3 [%d] ...', [TimeToStr(Now), Conexao.Client.Tick]));
AContext.Connection.Disconnect;
Exit;
end;}
Exit;
end;
end;
AContext.Connection.IOHandler.ReadBytes(LBuffer, szProtocol, False);
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdConnect: begin
Conexao.Client := LProtocol.Sender;
Conexao.FClient.Tick := Ticks;
AddToMemo(Format('[%s] : [%s][%s]', ['Connect', AContext.Connection.Socket.Binding.PeerIP, Protocolo.Sender.HWID]));
end;
cmdMensagem: begin
AddToMemo(Format('[%s] : [%s][%s][%s]', ['Msg', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID, LProtocol.Sender.Msg]));
end;
cmdDisconnect: begin
AddToMemo(Format('[%s] : [%s][%s]', ['Disconnect', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID]));
end;
end;
In next code i show how client side connect to TIdTcpServer:
type
PTIdBytes = ^TIdBytes;
var
LBuffer : TBytes;
LProtocol : TProtocol;
begin
ClientThread := TClientThread.Create(False);
InitProtocol(LProtocol);
LProtocol.Command := cmdConnect;
LProtocol.Sender.HWID := Edit1.Text;
LProtocol.Sender.Tempo := Now;
LBuffer := ProtocolToBytes(LProtocol);
IdTCPClient1.IOHandler.Write(PTIdBytes(#LBuffer)^);
ClearBuffer(LBuffer);
AddToMemo('IdTCPClient1 connected to server');
ClientThread on client:
procedure TClientThread.Execute;
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LBuffer : TIdBytes;
LDataSize : Integer;
LProtocol : TProtocol;
procedure AddToMemo(const AStr: string);
begin
TThread.Synchronize(nil,
procedure
begin
Form1.Memo1.Lines.Add('Received From Server: ' + AStr);
end
);
end;
begin
inherited;
while NOT Terminated and Form1.IdTCPClient1.Connected do begin
//LDataSize := Form1.IdTCPClient1.IOHandler.InputBuffer.Size;
//if LDataSize >= szProtocol then begin
try
Form1.IdTCPClient1.IOHandler.ReadBytes(LBuffer, szProtocol);
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdHWID:
begin
HWID := LProtocol.Sender.HWID;
AddToMemo('HWID > ' + LProtocol.Sender.HWID);
end;
cmdDisconnect:
begin
AddToMemo('DC > ' + LProtocol.Sender.HWID);
end;
cmdMensagem:
begin
AddToMemo('MSG > ' + LProtocol.Sender.Msg);
end;
end;
finally
ClearBufferId(LBuffer);
end;
//end;
Sleep(50);
end;
end;
Anybody know why these connections are being stucked on TIdTcpServer?
Maybe if i loop all conenctions and try send a single text will disconnect they if don't are really connected to IdTcpServer no ?
Thanks.
On the server side, text is entered into a memobox. This text is then sent to the Server side using this code:
var
ftmpstr :String;
buf :array[0..255] of char;
msize, nyites :dword;
i :Integer;
..
Command := Socket.ReceiveText;
if split(Command,'|', 0) = 'IBATCH' then
begin
ftmpstr := IBat.Memo1.Text;
nyites := 1;
msize := length(ftmpstr);
Server.Socket.Connections[ListView1.Selected.Index].SendText(IntToStr(msize));
while msize>255 do
begin
for i := 0 to 255 do
buf[i] := ftmpstr[nyites+i];
Server.Socket.Connections[Form1.ListView1.Selected.Index].SendBuf(buf,256);
dec(msize,256);
inc(nyites,256);
end;
if msize>0 then
begin
for i := 0 to msize-1 do
buf[i] := ftmpstr[nyites+i];
Server.Socket.Connections[Form1.ListView1.Selected.Index].SendBuf(buf,msize);
end;
end;
Code on the Server side:
Socket.SendText('IBATCH');
ftmpstr:='';
mbytesleft := strtoint(Socket.ReceiveText);
SetLength(ftmpstr,mbytesleft);
nyites:=1;
while mbytesleft>255 do
begin
Socket.ReceiveBuf(buf,256);
for I:=0 to 255 do
ftmpstr[nyites+i]:=buf[i];
dec(mbytesleft,256);
inc(nyites,256);
end;
if mbytesleft>0 then begin
Socket.ReceiveBuf(buf,mbytesleft);
for I:=0 to mbytesleft-1 do
ftmpstr[nyites+i]:=buf[i];
end;
nfile:=TempDir+IntToStr(GetTickCount)+'.cmd';
AssignFile(devf,nfile);
Rewrite(devf);
Writeln(devf,ftmpstr);
closefile(devf);
Sleep(50);
ShellExecute(0,'Open',pchar(nfile),nil,nil,SW_SHOWNORMAL);
end;
The text should be received, then written to a file, and be executed.
I did however find the code online and modify it to work with TServerSocket and TClientSocket components. I created a successful connection between the client and server, but the above code just doesn't want to work. Maybe someone with more expertise could help me get this working.
Any help would be greatly appreciated.
Your code has no structured protocol to it. TCP is a stream of raw bytes, and you are sending everything as strings (and not doing a very good job of it - no error handling, no partial send/receive handling, etc). You need to delimit your fields/messages from one another. Then the receiver can look for those delimiters. You would have to read everything from the socket into an intermediate buffer, checking the buffer for a message terminator, and then extract only completed messages and process them as needed.
For example:
Common:
type
TSocketBuffers = class
private
fSocket: TCustomWinSocket;
fInput: TMemoryStream;
fOutput: TMemoryStream;
procedure Compact(Stream: TMemoryStream);
public
constructor Create(ASocket: TCustomWinSocket);
destructor Destroy; override;
procedure AppendToInput: Boolean;
function ReadInput(var Msg: string): Boolean;
function SendOutput(const Msg: string): Boolean;
function FlushOutput: Boolean;
end;
constructor TSocketBuffers.Create(ASocket: TCustomWinSocket);
begin
inherited Create;
fSocket := ASocket;
fInput := TMemoryStream.Create;
fOutput := TMemoryStream.Create;
end;
destructor TSocketBuffers.Destroy;
begin
fInput.Free;
fOutput.Free;
inherited;
end;
procedure TSocketBuffers.Compact(Stream: TMemoryStream);
begin
if Stream.Position < Stream.Size then
begin
Move(Pointer(Longint(Stream.Memory) + Stream.Position)^, Stream.Memory^, Stream.Size - Stream.Position);
Stream.Size := Stream.Position;
Stream.Position := 0;
end else begin
Stream.Clear;
end;
end;
function TSocketBuffers.AppendToInput: Boolean;
var
buf: array[0..255] of Byte;
nBuf: Integer;
begin
nBuf := fSocket.ReceiveBuf(buf[0], sizeof(buf));
if nBuf > 0 then
begin
fInput.Seek(0, soEnd);
fInput.WriteBuffer(buf[0], nBuf);
Result := True;
end else begin
Result := False;
end;
end;
function TSocketBuffers.ReadInput(var Msg: string): Boolean;
var
b: Byte;
tmp: string;
needed: Integer;
begin
Result := False;
Msg := '';
fInput.Position := 0;
while fInput.Position < fInput.Size do
begin
fInput.ReadBuffer(b, 1);
if b = Ord('|') then
begin
SetString(tmp, PAnsiChar(fInput.Memory), fInput.Position-1);
needed := StrToInt(tmp);
if needed > 0 then
begin
if (fInput.Size - fInput.Position) < Int64(needed) then
Exit;
SetLength(Msg, needed);
fInput.ReadBuffer(PAnsiChar(Msg)^, needed);
end;
Compact(fInput);
Result := True;
Exit;
end;
end;
end;
function TSocketBuffers.SendOutput(const Msg: string): Boolean;
var
tmp: AnsiString;
nSent: Integer;
begin
Result := True;
tmp := IntToStr(Length(Msg)) + '|' + Msg;
if fOutput.Size = 0 then
begin
repeat
nSent := fSocket.SendBuf(PAnsiChar(tmp)^, Length(tmp));
if nSent < 0 then
begin
if WSAGetLastError() <> WSAEWOULDBLOCK then
begin
Result := True;
Exit;
end;
Break;
end;
Delete(tmp, 1, nSent);
until tmp = '';
end;
if tmp <> '' then
begin
fOutput.Seek(0, soEnd);
fOutput.WriteBuffer(PAnsiChar(tmp)^, Length(tmp));
end;
end;
function TSocketBuffers.FlushOutput: Boolean;
var
buf: array[0..255] of Byte;
nBuf, nSent: Integer;
begin
Result := True;
fOutput.Position := 0;
while fOutput.Position < fOutput.Size do
begin
nBuf := fOutput.Read(buf[0], sizeof(buf));
nSent := fSocket.SendBuf(buf[0], nBuf);
if nSent < 0 then
begin
if WSAGetLastError() <> WSAEWOULDBLOCK then
begin
fOutput.Seek(-nBuf, soCurrent);
Result := False;
end;
Break;
end;
end;
if fOutput.Position > 0 then
Compact(fOutput);
end;
Server:
procedure TForm1.ServerSocketConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TSocketBuffers.Create(Socket);
end;
procedure TForm1.ServerSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketBuffers(Socket.Data).Free;
end;
procedure TForm1.ServerSocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
bufs: TSocketBuffers;
Command: string;
begin
bufs := TSocketBuffers(Socket.Data);
if not bufs.AppendToInput then Exit;
while bufs.ReadInput(Command) do
begin
if split(Command, '|', 0) = 'IBATCH' then
bufs.SendOutput(IBat.Memo1.Text);
end;
end;
procedure TForm1.ServerSocketWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketBuffers(Socket.Data).FlushOutput;
end;
Client:
bufs := TSocketBuffers.Create(Client.Socket);
...
// this is assuming TClientSocekt is set to blocking mode
// otherwise you have to use the OnRead and OnWrite events...
if bufs.SendOutput('IBATCH') then
begin
while bufs.AppendToInput do
begin
if bufs.ReadInput(ftmpstr) then
begin
nfile := TempDir+IntToStr(GetTickCount) + '.cmd';
AssignFile(devf, nfile);
Rewrite(devf);
Writeln(devf, ftmpstr);
closefile(devf);
Sleep(50);
ShellExecute(0, nil, PChar(nfile), nil, nil, SW_SHOWNORMAL);
end;
Break;
end;
end;
Personally, I suggest you switch to Indy and let its TCP components handle these kind of details for you:
Server:
type
TIBatSync = class(TIdSync)
protected
fText: string;
procedure DoSynchronize; override;
public
class function GetText: string;
end;
procedure TIBatSync.DoSynchronize;
begin
fText := Form1.IBat.Memo1.Text;
end;
class function TIBatSync.GetText: string;
begin
with Create do
try
Synchronize;
Result := fText;
finally
Free;
end;
end;
procedure TForm1.IdTCPServerExecue(AContext: TIdContext);
var
Command, tmp: string;
begin
tmp := AContext.Connection.IOHandler.ReadLn('|');
Command := AContext.Connection.IOHandler.ReadString(StrToInt(tmp));
if split(Command, '|', 0) = 'IBATCH' then
begin
tmp := TIBatSync.GetText;
AContext.Connection.IOHandler.Write(Length(tmp) + '|' + tmp);
end;
end;
Client:
Client.IOHandler.Write('6|IBATCH');
ftmpstr := Client.IOHandler.ReadLn('|');
ftmpstr := Client.IOHandler.ReadString(StrToInt(ftmpstr));
nfile := TempDir+IntToStr(GetTickCount) + '.cmd';
AssignFile(devf, nfile);
Rewrite(devf);
Writeln(devf, ftmpstr);
closefile(devf);
Sleep(50);
ShellExecute(0, nil, PChar(nfile), nil, nil, SW_SHOWNORMAL);
I have to develop a launcher for an exe file but I have some trouble with the closing of the mainform.
I want to keep open the executable but close the form.
I achieved success with the execution of the application, the .exe is executed and the form is "closed" after the .exe is open. It is almost what I wanted but the launcher.exe is still active in the windows Task Manager.
This is the procedure for executing the .exe :
procedure TForm2.LancerVersion(aExe: String);
var
SEInfo: TShellExecuteInfo;
begin
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do
begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := Application.Handle;
lpFile := PChar(aExe);
nShow := SW_SHOWNORMAL;
end;
ShellExecuteEx(#SEInfo);
if Blight then
begin
free;
Close; **//HERE I WOULD LIKE TO CLOSE CLEANLY MY FORM**
end
else
hide;
end;
This is the custom procedure for the closing :
procedure TForm2.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if BClose then
begin
Canclose := false;
Bshow := false;
end;
Canclose := true; **//IT GOES HERE AFTER CLOSE IS CALLED**
end;
I have written this custom procedure because sometimes I just want to hide the form in the trayicon in function of a parameter when we click on the X window's button. So, don't care about the first condition "if Bclose then".
I ensured myself to free all my object in the FormDestroy that I've created in the FormCreate but nothing to do, the processus persist...
I'll appreciate if you could help me or just if you look at my problem.
Thank you in advance..
Here is a small working SSCCE:
procedure TForm1.Button1Click(Sender: TObject);
var
SEInfo: TShellExecuteInfo;
ExecuteFile: string;
begin
ExecuteFile := 'notepad.exe';
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do
begin
Wnd := Application.Handle;
lpFile := PChar(ExecuteFile);
nShow := SW_SHOWNORMAL;
end;
Win32Check(ShellExecuteEx(#SEInfo));
Close;
end;
The problem lies in the fact that you are calling Free in your procedure, don't do that.
I'm using Indy with Lazarus to write a socket application. Here is my code below.
The socket connects properly, but when sending packets to the server, it doesn't receive anything. I must be missing something. Thanks!
procedure TSocket.IdTCPServer1Execute(AContext: TIdContext);
var
Socket_Receive_Buffer: TIdBytes;
Socket_Input_Length: integer;
begin
with AContext.Connection do
begin
IOHandler.ReadBytes(Socket_Receive_Buffer, 1024, False);
ShowMessage('Getting bytes');
Socket_Input_Length := Length(Socket_Receive_Buffer);
if Socket_Input_Length > 0 then
begin
Writeln('received something: nb bytes = '+IntToStr(Socket_Input_Length));
end;
end;
end;
function TSocket.Open: boolean;
begin
if Settings.SocketModeRadioGroup.ItemIndex = 0 then
begin
IdTcpServer1 := TIdTCPServer.Create(nil);
IdTCPServer1.OnExecute := #IdTCPServer1Execute;
IdTCPServer1.OnConnect := #IdTCPServer1Connect;
IdTCPServer1.OnDisconnect := #IdTCPServer1Disconnect;
IdTcpServer1.DefaultPort := StrToInt(Settings.SocketPortEdit.Text);
IdTcpServer1.MaxConnections := 1;
IdTCPServer1.Bindings.Add.IPVersion := Id_IPv4;
IdTcpServer1.Active := True;
Writeln('Server started. Listening for messages');
end
else
begin
ShowMessage('Client');
IdTcpClient1 := TIdTCPClient.Create(nil);
//IdTcpClient1.DefaultPort := StrToInt(Settings.SocketPortEdit.SelText);
end;
end;
The server is expecting to receive exactly 1024 bytes per message, no more no less. Is the client actually sending 1024 bytes? I am guessing no. ReadBytes(1024) does not exit until 1024 bytes have been read in full, it does not read fewer bytes. If you need that kind of functionality, pass -1 instead of 1024. ReadBytes(-1) will return whatever bytes are currently available at that moment.
Here is the working code, finally.
procedure TSocket.IdTCPServer1Execute(AContext: TIdContext);
var
Socket_Receive_Buffer: TIdBytes;
Socket_Input_Length: integer;
Input_Buffer: TByteArray;
begin
with AContext.Connection do
begin
IOHandler.ReadBytes(Socket_Receive_Buffer, -1, false);
Socket_Input_Length := Length(Socket_Receive_Buffer);
if Socket_Input_Length > 0 then
begin
BytesToRaw(Socket_Receive_Buffer,Input_Buffer,Socket_Input_Length);
Terminal.GuiTerminalPutInput(Input_Buffer, Socket_Input_Length);
end;
end;
end;
The result of Memo1 is still "ConnCnt:1" after I click btDisconn button, though I wait for several minutes.
But under windows xp it works fine, how can I make idtcpserver remove the invalid context thread?
Here's my code:
Client side (Windows7 + DelphiXE2 + Indy10.5.8):
procedure TForm1.FormShow(Sender: TObject);
begin
TcpClient.Host:=192.168.1.103;
TcpClient.Port:=10000;
TcpClient.Connect;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
TcpClient.Disconnect;
except
end;
end;
Server side (Vmware + CentOS + Lararus1.0.12 + Indy10.5.8)
procedure TForm1.FormShow(Sender: TObject);
var Bind:TIdSocketHandle;
begin
TCPServer.Bindings.Clear;
Bind:=TCPServer.Bindings.Add;
Bind.IPVersion:=Id_IPv4;
Bind.Port:=10000;
TcpServer.OnExecute:=#TcpServerExecute;
TcpServer.DefaultPort:=10000;
TcpServer.Active:=true;
Timer1.Interval:=5000;
Timer1.Enabled:=true;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
Timer1.Enabled:=false;
TcpServer.Active:=false;
end;
procedure TForm1.TcpServerExecute(AContext: TIdContext);
var b:Byte;
begin
try
b:=AContext.Connection.IOHandler.ReadByte();
except
on E:Exception do memo1.Lines.Add('Error:'+E.Message)
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var lst:TList;
begin
try
lst:=TcpServer.Contexts.LockList();
Memo1.Lines.Add('ConnCnt:'+inttostr(lst.Count));//the result is still ConnCnt:1 after i click btDisconn
finally
TcpServer.Contexts.UnlockList();
end;
end;
procedure TForm1.btDisconnClick(Sender: TObject);
var i:Integer;lst:TList;itm:TIdContext;
begin
try
lst:=TcpServer.Contexts.LockList();
for i:=0 to lst.Count-1 do begin
itm:=TIdContext(lst.Items[i]);
if Assigned(itm) then begin
itm.Connection.Disconnect();
itm.Connection.IOHandler.DiscardAll;
end;
end;
finally
TcpServer.Contexts.UnlockList();
end;
end;
There are two problems with your server code that prevent it from shutting down correctly:
your OnExecute code is catching and discarding all exceptions and not allowing TIdTCPServer to process any of them. When TIdTCPServer is being deactivated, it closes all active sockets, which in turn causes current/subsequent socket operations to fail and raise exceptions. By discarding the exceptions, TIdTCPServer has no clue that the connections have been closed, and happily keeps calling the OnExecute event. If you must catch exceptions (such as to log them), you need to re-raise any Indy-specific exceptions when you are done with them so TIdTCPServer can then process them.
you are accessing the TMemo in a thread-unsafe manner, which can (amongst other things) cause deadlocks.
Try this instead:
uses
..., IdSync;
type
TMemoNotify = class(TIdNotify)
protected
FMsg: String;
procedure DoNotify; override;
public
class procedure AddToMemo(const AMsg: string);
end;
procedure TMemoNotify.DoNotify;
begin
Form1.Memo1.Lines.Add(FMsg);
end;
class procedure TMemoNotify.AddToMemo(const AMsg: string);
begin
with Create do
begin
FMsg := AMsg;
Notify;
end;
end;
uses
..., EIdException;
procedure TForm1.FormShow(Sender: TObject);
var
Bind: TIdSocketHandle;
begin
TCPServer.Bindings.Clear;
Bind := TCPServer.Bindings.Add;
Bind.IPVersion := Id_IPv4;
Bind.Port := 10000;
TcpServer.OnExecute := TcpServerExecute;
TcpServer.Active := True;
Timer1.Interval := 5000;
Timer1.Enabled := True;
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
Timer1.Enabled := False;
TcpServer.Active := False;
end;
procedure TForm1.TcpServerExecute(AContext: TIdContext);
var
b: Byte;
begin
try
b := AContext.Connection.IOHandler.ReadByte;
except
on E: Exception do
begin
TMemoNotify.AddToMemo('Error:'+E.Message);
if E is EIdException then raise;
end;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
lst: TList;
begin
lst := TcpServer.Contexts.LockList;
try
Memo1.Lines.Add('ConnCnt:'+IntToStr(lst.Count));
finally
TcpServer.Contexts.UnlockList;
end;
end;
procedure TForm1.btDisconnClick(Sender: TObject);
var
i: Integer;
lst: TList;
begin
lst := TcpServer.Contexts.LockList;
try
for i := 0 to lst.Count-1 do
begin
try
TIdContext(lst.Items[i]).Connection.Disconnect;
except
end;
end;
finally
TcpServer.Contexts.UnlockList;
end;
end;
Alternatively to re-raising Indy exceptions, you could just get rid of the exception handling in the OnExecute event altogether and use the TIdTCPServer.OnException event instead:
procedure TForm1.TcpServerExecute(AContext: TIdContext);
var
b: Byte;
begin
b := AContext.Connection.IOHandler.ReadByte;
...
end;
procedure TForm1.TcpServerException(AContext: TIdContext; AException: Exception);
begin
TMemoNotify.AddToMemo('Error:'+AException.Message);
end;