I need help very much.
I have a TCP server application based on Indy 10's TIdTCPServer
component, which I want to run on Win32 and Android. I'm using Delphi XE7.
The server has to handle 10 clients.
Application works fine on Windows and Android on: CONNECTING, SENDING, RECEIVING data, but there is a problem with the OnDisconnect
event on Android only. The application works totally fine on Windows, but on Android there is a big problem with disconnecting the clients and on event: TCPServer.Active := FALSE
. On 90% of cases the application is being automatically closed when I disconnect a client.
When I start the server: TCPServer1.Active := TRUE
, and then I close it TCPServer1.Active := FALSE
, without connecting the clients, the application works fine.
I'm adding my code under. I have used hints from Remy Lebeau.
Please help.
// TMyContext
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
FQueue := TIdThreadSafeStringList.Create;
FEvent := TEvent.Create(nil, True, False, '');
end;
destructor TMyContext.Destroy;
begin
FQueue.Free;
FEvent.Free;
inherited;
end;
procedure TMyContext.AddMsgToQueue(const Msg: String);
begin
with FQueue.Lock do
try
Add(Msg);
FEvent.SetEvent;
finally
FQueue.Unlock;
end;
end;
function TMyContext.GetQueuedMsgs: TStrings;
var
List: TStringList;
begin
Result := nil;
if FEvent.WaitFor(1000) <> wrSignaled then Exit;
List := FQueue.Lock;
try
if List.Count > 0 then
begin
Result := TStringList.Create;
try
Result.Assign(List);
List.Clear;
except
Result.Free;
raise;
end;
end;
FEvent.ResetEvent;
finally
FQueue.Unlock;
end;
end;
// TCPServer
procedure THeaderFooterwithNavigation.TCPServer1Connect(AContext: TIdContext);
var
client : String;
datetime : TDateTime;
begin
datetime := now;
// CLIENT CON INFO
client := AContext.Binding.PeerIP;
TThread.Queue(nil,
procedure
begin
TCPServer1.Contexts.LockList();
mmoLog.Lines.Add ('CONNECT: ' + AContext.Connection.Socket.Binding.PeerIP
+ ' : ' +
IntToStr(AContext.Connection.Socket.Binding.PeerPort) + ' ' +
DateToStr (datetime) + ' ' + TimeToStr (datetime)
);
TCPServer1.Contexts.UnlockList();
if TCPServer1.Contexts.Count = 1 then
edtPort1.Text := IntToStr(AContext.Connection.Socket.Binding.PeerPort);
if TCPServer1.Contexts.Count = 2 then
edtPort2.Text := IntToStr(AContext.Connection.Socket.Binding.PeerPort);
AContext.Connection.Socket.Binding.Send('HELLO');
// CLIENTSDATA LIST
ClientsList.Add (' ', AContext.Connection.Socket.Binding.PeerIP, AContext.Connection.Socket.Binding.PeerPort);
LV_Refresh ();
end
);
end;
procedure THeaderFooterwithNavigation.TCPServer1Disconnect(
AContext: TIdContext);
var
cl_item : Integer;
datetime : TDateTime;
begin
try
datetime := now;
if fSvrClose = FALSE then begin
fClDiscon := TRUE;
buff_discon [pos_ip] := AContext.Connection.Socket.Binding.PeerIP;
buff_discon [pos_port] := IntToStr (AContext.Connection.Socket.Binding.PeerPort);
buff_discon [pos_date] := DateToStr (datetime);
buff_discon [pos_time] := TimeToStr (datetime);
end;
finally
AContext.Connection.Socket.InputBuffer.Clear;
AContext.Connection.Disconnect;
end;
end;
procedure THeaderFooterwithNavigation.TCPServer1Exception(AContext: TIdContext;
AException: Exception);
begin
ShowMessage ('Error');
end;
procedure THeaderFooterwithNavigation.TCPServer1Execute(AContext: TIdContext);
var
buff : String;
List : TStrings;
I : Integer;
buffout : String;
n : Integer;
// FOR DISCONNECT
{$IFDEF MSWINDOWS}
clist : TList;
{$ENDIF MSWINDOWS}
{$IFDEF Android}
clist : TList <TIdContext>;
{$ENDIF Android}
begin
if fSvrClose = FALSE then begin
// READ MESSAGES FROM THE CLIENTS
fDisconAccess := FALSE;
// SEND MESSAGES TO THE CLIENTS
List := TMyContext(AContext).GetQueuedMsgs;
if List <> nil then begin
try
for I := 0 to List.Count-1 do
AContext.Connection.IOHandler.Write(List[I]);
finally
List.Free;
end;
end;
// READ MESSAGE FROM CLIENTS
if AContext.Connection.IOHandler.CheckForDataOnSource(200) then begin
buffout := AContext.Connection.IOHandler.ReadLn();
TThread.Queue(nil,
procedure
begin
if AContext.Connection.Socket.Binding.PeerPort = StrToInt(edtPort1.Text) then begin
edtRec1.Text := buffout;
end;
if AContext.Connection.Socket.Binding.PeerPort = StrToInt(edtPort2.Text) then begin
edtRec2.Text := buffout;
end;
end
);
end;
fDisconAccess := TRUE;
end;
end;
// USER INTERFACE
procedure THeaderFooterwithNavigation.SendMessage (const IP : String; port : Word; Msg: string);
var
I: Integer;
begin
with TCPServer1.Contexts.LockList do
try
for I := 0 to Count-1 do begin
with TMyContext(Items[I]) do begin
if (Binding.PeerIP = IP) and (Binding.PeerPort = port) then begin
AddMsgToQueue(Msg);
Break;
end;
end;
end;
finally
TCPServer1.Contexts.UnlockList;
end;
end;
procedure THeaderFooterwithNavigation.Timer1Timer(Sender: TObject);
begin
Get_ClientsNum ();
// UPDATE UI (USER INTERFACE)
UpdateUI ();
// BUTTONS
if TCPServer1.Active = TRUE then begin
btnListen.Enabled := FALSE;
edtStatus.Text := 'LISTENING';
end else begin
btnListen.Enabled := TRUE;
edtStatus.Text := 'CLOSED';
end;
// ON SINGLE CLIENT DISCONNECT
if fClDiscon = TRUE then begin
fClDiscon := FALSE;
CL_DeleteClient (buff_discon [pos_ip], StrToInt (buff_discon [pos_port]));
LV_Refresh ();
mmoLog.Lines.Add ('DISCON: ' + buff_discon [pos_ip] + ' : ' + buff_discon [pos_port] + ' ' +
buff_discon [pos_date] + ' ' + buff_discon [pos_time] );
end;
end;
procedure THeaderFooterwithNavigation.TitleActionUpdate(Sender: TObject);
begin
if Sender is TCustomAction then
begin
if TabControl1.ActiveTab <> nil then
TCustomAction(Sender).Text := TabControl1.ActiveTab.Text
else
TCustomAction(Sender).Text := '';
end;
end;
procedure THeaderFooterwithNavigation.btnCloseClick(Sender: TObject);
var
{$IFDEF MSWINDOWS}
clist : TList;
{$ENDIF MSWINDOWS}
{$IFDEF Android}
clist : TList <TIdContext>;
{$ENDIF Android}
i : Integer;
ip : String;
port : Word;
datetime : TDateTime;
begin
TThread.Queue(nil,
procedure
var
n : Integer;
begin
datetime := now;
if Clients_Num = 0 then begin
TCPServer1.StopListening();
TCPServer1.Active := FALSE;
end else begin
fSvrClose := TRUE;
// SERVER CLOSE
if fSvrClose = TRUE then begin
while fDisconAccess = FALSE do begin
end;
try
clist := TCPServer1.Contexts.LockList;
for n := 0 to (clist.Count - 1) do begin
try
TIdContext (clist[n]).Connection.Socket.WriteBufferClear;
TIdContext (clist[n]).Connection.Socket.InputBuffer.Clear;
ip := TIdContext (clist[n]).Connection.Socket.Binding.PeerIP;
port := TIdContext (clist[n]).Connection.Socket.Binding.PeerPort;
TIdContext (clist[n]).Connection.Disconnect;
CL_DeleteClient (ip, port);
mmoLog.Lines.Add ('DISCON: ' + ip + ' : ' + IntToStr(port) + ' ' +
DateToStr (datetime) + ' ' + TimeToStr (datetime) );
sleep (100);
except
end;
end;
finally
TCPServer1.Contexts.UnlockList;
TCPServer1.Active := FALSE;
fSvrClose := FALSE;
LV_Refresh ();
end;
end;
end
);
end;
procedure THeaderFooterwithNavigation.btnListenClick(Sender: TObject);
var
port : Word;
begin
port := StrToInt (edtPort.Text);
TCPServer1.Contexts.Clear;
TCPServer1.Bindings.Clear();
if (port > 200) and (port < 65535) then begin
TCPServer1.DefaultPort := StrToInt (edtPort.Text);
end else
TCPServer1.DefaultPort := 30000;
TCPServer1.Bindings.Add.IPVersion := Id_IPv4;
if TCPServer1.Active = FALSE then begin
TCPServer1.Active := TRUE;
end;
end;
procedure THeaderFooterwithNavigation.btnSendClick(Sender: TObject);
var
ip : string;
port : Word;
item : Integer;
begin
item := LV.ItemIndex;
if (item > -1) then begin
ip := ClientsList.Items[item].IP;
port := ClientsList.Items[item].Port;
SendMessage (ip, port, edtSend.Text);
end;
end;
procedure THeaderFooterwithNavigation.Get_ClientsNum ();
var
{$IFDEF MSWINDOWS}
clist : TList;
{$ENDIF MSWINDOWS}
{$IFDEF Android}
clist : TList <TIdContext>;
{$ENDIF Android}
begin
try
clist := TCPServer1.Contexts.LockList();
Clients_Num := TCPServer1.Contexts.Count;
finally
TCPServer1.Contexts.UnlockList;
end;
end;
This code is not correct or safe, for Windows or Android. The fact that it works at all is pure luck . There is a lot of dangerous logic in this code that needs to be re-written.
Try something more like this instead:
// TMyContext
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
FQueue := TIdThreadSafeStringList.Create;
FEvent := TEvent.Create(nil, True, False, '');
end;
destructor TMyContext.Destroy;
begin
FQueue.Free;
FEvent.Free;
inherited;
end;
procedure TMyContext.AddMsgToQueue(const Msg: String);
begin
with FQueue.Lock do
try
Add(Msg);
FEvent.SetEvent;
finally
FQueue.Unlock;
end;
end;
function TMyContext.GetQueuedMsgs: TStrings;
var
List: TStringList;
begin
Result := nil;
if FEvent.WaitFor(1000) <> wrSignaled then Exit;
List := FQueue.Lock;
try
if List.Count > 0 then
begin
Result := TStringList.Create;
try
Result.Assign(List);
List.Clear;
except
Result.Free;
raise;
end;
end;
FEvent.ResetEvent;
finally
FQueue.Unlock;
end;
end;
// TCPServer
procedure THeaderFooterwithNavigation.LogMessage(Msg: string);
begin
TThread.Queue(nil,
procedure
begin
mmoLog.Lines.Add (Msg);
end
);
end;
procedure THeaderFooterwithNavigation.TCPServer1Connect(AContext: TIdContext);
var
clientIP : String;
clientPort: TIdPort;
datetime : TDateTime;
begin
datetime := now;
// CLIENT CON INFO
clientIP := AContext.Binding.PeerIP;
clientPort := AContext.Binding.PeerPort;
AContext.Connection.IOHandler.WriteLn('HELLO');
LogMessage('CONNECT: ' + clientIP + ' : ' + IntToStr(clientPort) + ' ' + DateToStr (datetime) + ' ' + TimeToStr (datetime));
TThread.Queue(nil,
procedure
var
client: string;
begin
client := clientIP + ':' + IntToStr(clientPort);
case TCPServer1.Contexts.Count of
1: edtPort1.Text := client;
2: edtPort2.Text := client;
end;
// CLIENTSDATA LIST
ClientsList.Add (' ', clientIP, clientPort);
LV_Refresh;
end
);
end;
procedure THeaderFooterwithNavigation.TCPServer1Disconnect(
AContext: TIdContext);
var
datetime : TDateTime;
clientIP : String;
clientPort: TIdPort;
begin
datetime := now;
// CLIENT CON INFO
clientIP := AContext.Binding.PeerIP;
clientPort := AContext.Binding.PeerPort;
LogMessage('DISCON: ' + clientIP + ' : ' + IntToStr(clientPort) + ' ' + DateToStr(datetime) + ' ' + TimeToStr(datetime));
TThread.Queue(nil,
procedure
var
client: string;
begin
client := clientIP + ':' + IntToStr(clientPort);
if edtPort1.Text = client then begin
edtPort1.Text := '';
end;
if edtPort2.Text = client then begin
edtPort2.Text := '';
end;
CL_DeleteClient (clientIP, clientPort);
if fSvrClose = FALSE then LV_Refresh;
end
);
end;
procedure THeaderFooterwithNavigation.TCPServer1Exception(AContext: TIdContext; AException: Exception);
begin
if fSvrClose = FALSE then
LogMessage ('Error: ' + AException.Message);
end;
procedure THeaderFooterwithNavigation.TCPServer1Execute(AContext: TIdContext);
var
buff : String;
List : TStrings;
I : Integer;
clientIP: String;
clientPort: TIdPort;
begin
if fSvrClose = TRUE then Exit;
// SEND MESSAGES TO THE CLIENTS
List := TMyContext(AContext).GetQueuedMsgs;
if List <> nil then
try
for I := 0 to List.Count-1 do
AContext.Connection.IOHandler.WriteLn(List[I]);
finally
List.Free;
end;
if fSvrClose = TRUE then Exit;
// READ MESSAGE FROM CLIENTS
if AContext.Connection.IOHandler.InputBufferIsEmpty then begin
AContext.Connection.IOHandler.CheckForDataOnSource(200);
AContext.Connection.IOHandler.CheckForDisconnect;
if fSvrClose = TRUE then Exit;
end;
if not AContext.Connection.IOHandler.InputBufferIsEmpty then begin
begin
buff := AContext.Connection.IOHandler.ReadLn;
if fSvrClose = TRUE then Exit;
clientIP := AContext.Binding.PeerIP;
clientPort := AContext.Binding.PeerPort;
TThread.Queue(nil,
procedure
var
client: string;
begin
client := clientIP + ':' + IntToStr(clientPort);
if edtPort1.Text = client then begin
edtRec1.Text := buff;
end;
if edtPort2.Text = client then begin
edtRec2.Text := buff;
end;
end
);
end;
end;
// USER INTERFACE
procedure THeaderFooterwithNavigation.SendMessage (const IP : String; port : TIdPort; const Msg: string);
var
I: Integer;
begin
with TCPServer1.Contexts.LockList do
try
for I := 0 to Count-1 do begin
with TMyContext(Items[I]) do begin
if (Binding <> nil) and (Binding.PeerIP = IP) and (Binding.PeerPort = port) then begin
AddMsgToQueue(Msg);
Exit;
end;
end;
end;
finally
TCPServer1.Contexts.UnlockList;
end;
end;
procedure THeaderFooterwithNavigation.Timer1Timer(Sender: TObject);
begin
Get_ClientsNum;
// UPDATE UI (USER INTERFACE)
UpdateUI;
end;
procedure THeaderFooterwithNavigation.TitleActionUpdate(Sender: TObject);
begin
if Sender is TCustomAction then
begin
if TabControl1.ActiveTab <> nil then
TCustomAction(Sender).Text := TabControl1.ActiveTab.Text
else
TCustomAction(Sender).Text := '';
end;
end;
procedure THeaderFooterwithNavigation.btnCloseClick(Sender: TObject);
begin
fSvrClose := TRUE;
// SERVER CLOSE
TCPServer1.Active := FALSE;
btnListen.Enabled := TRUE;
edtStatus.Text := 'CLOSED';
fSvrClose := FALSE;
LV_Refresh;
end;
procedure THeaderFooterwithNavigation.btnListenClick(Sender: TObject);
var
port : TIdPort;
begin
port := StrToInt (edtPort.Text);
TCPServer1.Active := False;
TCPServer1.Bindings.Clear;
if (port > 200) and (port < 65535) then begin
TCPServer1.DefaultPort := port;
end else
TCPServer1.DefaultPort := 30000;
TCPServer1.Bindings.Add.IPVersion := Id_IPv4;
TCPServer1.Active := TRUE;
btnListen.Enabled := FALSE;
edtStatus.Text := 'LISTENING';
end;
procedure THeaderFooterwithNavigation.btnSendClick(Sender: TObject);
var
ip : string;
port : Word;
item : Integer;
begin
item := LV.ItemIndex;
if (item > -1) then begin
ip := ClientsList.Items[item].IP;
port := ClientsList.Items[item].Port;
SendMessage (ip, port, edtSend.Text);
end;
end;
procedure THeaderFooterwithNavigation.Get_ClientsNum;
begin
Clients_Num := TCPServer1.Contexts.Count;
end;
The problem is happening almost every time when disconnecting the client/clients and deactivating the Server. There are single cases when disconnect/deactivate event goes well, but only when one client is connected. When there is few clients connected the disconnect and deactivate event always goes wrong. I have tested my app even when there was all the UI functions disabled and no improvement.
The only case where my app works smooth and stable is on the Android 5.0 Lollipop API 21 on my mobile. I can disconnect all clients one after another and I can deactivate the server with connected clients and everything works fine even with UI functions enabled. Maybe there are some system configuration to do on older versions of Android like Jelly Bean or in Delphi? It is a pity that I can't upgrade my tablet to API 5.0.
To be exact I will show You the UI functions: (I'm making my own ClientsList because I have to remember more data like device name or serial number. It is easier to do with my own code.)
<code>
// ----------------------------------------------------------------- LIST VIEW
procedure THeaderFooterwithNavigation.LV_MakeLine;
var
Item : TListItem;
begin
Item := LV.Items.Add;
end;
procedure THeaderFooterwithNavigation.LV_AddData (index : Word);
var
Item : TListItem;
Client : TClientTcp;
ip : String;
port : String;
name : String;
begin
Client := ClientsList.Items [index];
Item := LV.Items.Item [index];
LV.Items.Item [index].Text := Client.Name + ' ' + Client.IP + ' : ' + IntToStr(Client.Port);
end;
procedure THeaderFooterwithNavigation.LV_Refresh;
var
i : Integer;
itms : Integer;
begin
LV.Items.Clear;
//LV.ClearItems;
itms := ClientsList.Count;
for i := 0 to itms-1 do begin
LV_MakeLine ();
LV_AddData (i);
end;
end;
procedure THeaderFooterwithNavigation.CL_DeleteClient (ip : String; port : Word);
var
cl_item : Integer;
begin
cl_item := ClientsList.FindClient_ByIpPort (ip, port);
if cl_item > (-1) then begin
// DELETE DISCONNECTED CLIENT FROM LIST AND SET LIST SIZE TO THE CLIENTS NUMBER
ClientsList.Delete (cl_item);
end;
end;
and the Clients List
unit ServerTcpA;
interface
{
uses
SysUtils, Variants, Classes, Generics.Collections;
}
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
System.Generics.Collections;
{
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, Contnrs, ComCtrls,
Buttons, WinSock, ScktComp;
}
type
// CLASS DECLARATIONS ----------------------------------------------------
// TClientTcp CLASS -----------------------------------------------------
TClientTcp = class (TObject)
public
Name : String;
IP : String;
Port : Integer;
RecFrames : Integer;
end;
// TClientsTcpList CLASS -------------------------------------------------
TClientsTcpList = class (TObjectList <TObject>)
private
function FGetItem (index : Integer) : TClientTcp;
public
property Items [index : Integer] : TClientTcp read FGetItem;
function Add (name : String; ip : String; port: Integer) : TClientTcp;
function FindClient_ByName (name : String) : TClientTcp;
function FindClient_ByIp (ip : String) : TClientTcp;
function FindClient_ByPort (port : Integer) : Integer;
function FindClient_ByIpPort (ip : String; port : Integer): Integer;
end;
// TTcpCfg CLASS ---------------------------------------------------------
TTcpCfg = class (TObject)
TcpClientsList : TClientsTcpList;
public
constructor Create;
destructor Destroy; override;
function AddClient (ip : String; port: Integer) : TClientTcp;
end;
// ENUM - Defined Column Names -------------------------------------------
type TColNames = (
COL_LP = 0,
COL_NAME,
COL_IP,
COL_PORT
);
const
NONE = -1;
var
//ServerTcpDK : TServerSocket;
//TCPCFG : TTcpCfg;
ClientsList : TClientsTcpList;
implementation
// =================================================== CLASS: TClientsTcpList
// GET ITEM
function TClientsTcpList.FGetItem (index : Integer) : TClientTcp;
begin
//Result := inherited GetItem (index) as TClientTcp;
Result := inherited Items [index] as TClientTcp;
end;
// ADD ITEM
function TClientsTcpList.Add (name : String; ip : String; port: Integer) : TClientTcp;
begin
if (FindClient_ByIpPort (ip, port) = NONE) then begin
Result := TClientTcp.Create;
Result.Name := name;
Result.IP := ip;
Result.Port := port;
Result.RecFrames := 0;
inherited Add (Result);
end;
end;
// FIND CLIENT: BY NAME
function TClientsTcpList.FindClient_ByName (name : String): TClientTcp;
var
i : integer;
begin
//Result := nil;
Result := nil;
for i:=0 to Count-1 do begin
if Items [i].Name = name then begin
Result := Items[i];
break;
end;
end;
end;
// FIND CLIENT: BY IP
function TClientsTcpList.FindClient_ByIp (ip : String): TClientTcp;
var
i : integer;
begin
//Result := nil;
Result := nil;
for i:=0 to Count-1 do begin
if Items [i].IP = ip then begin
Result := Items[i];
break;
end;
end;
end;
// FIND CLIENT: BY PORT ------------------------------------------------------
// @Ret: Item Index in the LIST
// -1: Not Found
function TClientsTcpList.FindClient_ByPort (port : Integer): Integer;
var
i : integer;
begin
Result := NONE;
for i:=0 to Count-1 do begin
if Items [i].Port = port then begin
Result := i;
break;
end;
end;
end;
// FIND CLIENT: BY IP AND PORT -----------------------------------------------
// @Ret: Item Index in the LIST
// -1: Not Found
function TClientsTcpList.FindClient_ByIpPort (ip : String; port : Integer): Integer;
var
i : integer;
begin
Result := NONE;
for i:=0 to Count-1 do begin
if (Items [i].IP = ip) and (Items [i].Port = port) then begin
Result := i;
break;
end;
end;
end;
// =========================================================== CLASS: TTcpCfg
constructor TTcpCfg.Create;
begin
inherited;
TcpClientsList := TClientsTcpList.Create;
end;
destructor TTcpCfg.Destroy;
begin
TcpClientsList.Free;
inherited;
end;
function TTcpCfg.AddClient (ip : String; port: Integer) : TClientTcp;
begin
Result := TClientTcp.Create;
//TcpClientsList.Add (Result);
Result.IP := ip;
Result.Port := port;
Result.RecFrames := 0;
end;
// ============================================================ INITIALIZATION
initialization
//ServerTcpDK := TServerSocket.Create (Nil);
//TCPCFG := TTcpCfg.Create;
ClientsList := TClientsTcpList.Create;
finalization
//ServerTcpDK.Free;
//TCPCFG.Free;
ClientsList.Free;
// @END OF FILE --------------------------------------------------------------
end.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.