0

I have a TTimer on a TForm, where the timer is set to 5 seconds and creates 100 threads to fetch XML from a remote server.

Each time a thread is executed, I add the XML to a variable (FullXML_STR:String).

When all threads have finished, I am sending the FullXML_STR to all Clients connected to a TIdTCPServer.

unit Unit1;

interface

uses
  IdGlobal,IdContext, system.win.Comobj, system.syncObjs, MSXML2_TLB, activex,
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent,
  IdTCPConnection, IdTCPClient, IdHTTP, IdCustomTCPServer, IdCustomHTTPServer,
  IdHTTPServer, Vcl.ExtCtrls;

Type
  TxClientThread = class(TThread)
  private
    fHttpClient: TIdHTTP;
    furl: String;
    ftag:Integer;
    fResponseXML:String;
    fXML: IXMLDOMDocument;
    fNode: IXMLDomNode;
  protected
    procedure Execute; override;
    procedure DoTerminate; override; **//Added**

  public
    constructor Create(atag:Integer;AURL:string);reintroduce;
    destructor Destroy; override;
  end;

type
  TForm1 = class(TForm)
    IdTCPServer1: TIdHTTPServer;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure StartTimerAgain;
  end;

const
  maximumThreads=200;

var
  Form1: TForm1;
  Threads_downloaded:Integer;
  Total_threads:Integer;
  FullXML_STR:String;
  Clients:TList;
  CriticalSection:TCriticalSection;
  ClientThread:Array[0..maximumThreads] of TxClientThread;

implementation

{$R *.dfm}

{TxClientThread}

constructor TxClientThread.Create(atag:Integer;AURL:string);
begin
  inherited Create(false);
  furl:=Aurl;
  ftag:=Atag;
  fResponseXML:='';
  fHttpClient := TIdHTTP.Create(nil);
  fHttpClient.Tag:=ftag;
  fHttpClient.ConnectTimeout:=60000;
  fHttpClient.ReadTimeout:=60000;
  fHttpClient.Request.Accept:='*/*';
  fHttpClient.Request.UserAgent:='Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';

  FreeOnTerminate := True;
end;

destructor TxClientThread.Destroy;
begin
  fHttpClient.Free;
  inherited Destroy;
end;

procedure TxClientThread.Execute;
begin
  try
    fResponseXML:= fHttpClient.Get(furl);
  except
  end;
end;

procedure TxClientThread.DoTerminate;
begin
  inc(Threads_downloaded);

  ///******     parsing The XML
  try
    CoInitialize(nil);
    fXML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
    fXML.async := false;
    try
      fXML.loadXML(fResponseXML); 
      fNode := fXML.selectSingleNode('/games');
      if fNode<>nil then
      begin
        FullXML_STR:=FullXML_STR + fNode.attributes.getNamedItem('id').text+'^';
      end;
    finally
      fxml:=nil; //---> do i need this?
    end;
  finally
    CoUninitialize;
  end;

  if Threads_downloaded=Total_threads then
  begin
    TThread.Synchronize(nil,procedure/////////Sould i USe This or Synchronize
      var
        i:Integer;
      begin
        CriticalSection.enter;
        if not Assigned(Form1.IdTCPServer1.Contexts) then exit;
        try
          Clients:=Form1.IdTCPServer1.Contexts.LockList;
          try
            for i:=pred(Clients.Count)  downto 0 do
              try
                TIdContext(Clients[i]).Connection.IOHandler.Writeln(FullXML_STR,IndyTextEncoding_UTF8);
              except
              end;
            finally
              Form1.IdTCPServer1.Contexts.UnlockList;
            end;
        finally
          CriticalSection.leave;
        end;
        form1.StartTimerAgain; ///Startinmg againe Then timer
      end
    );
  end;
  /////////// End \ All threads downloaded

  inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  CriticalSection:=TCriticalSection.create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  CriticalSection.Free;
end;

procedure tform1.StartTimerAgain;
begin
  Form1.Timer1.Enabled:=true
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  x:Integer;
  aUrl:String;
begin
  FullXML_STR:='';
  Timer1.Enabled:=false;
  Threads_downloaded:=0;
  Total_threads=100;
  for x:=0 to Pred(Total_threads) do
  begin
    aUrl:='http://example.com/myxml'+Formatfloat('0',x)+'.xml';
    ClientThread[Threads_downloaded]:=TxClientThread.Create(x,aUrl);
  end;
end;

end.

main problem is that after 1-2 Hours programm is not responding.

  1. in each thread's Execute(), I check if all Threads have finished downloading. Is there a better way to know that all my threads are finished?

  2. is it better to call Contexts.LockList() on the TIdTCPServer before the timer starts creating the threads, and unlock it after the threads are finished?

  3. What can I do to optimize my code so I can be sure that the timer will be alive all the time? I am restarting the timer after all threads are finished. Is this the correct way to do it?

Request:

How is it possible to accept a string like hi from a client connected on the TIdTCPServer and send back a string.

I try to add the following code:

var
  RxBuf: TIdBytes;

Data := TxClientContext(AContext).ExtractQueuedStrings;
if Data <> nil then
try
  for i := 0 to Pred(Data.Count) do
    AContext.Connection.IOHandler.WriteLn(Data[i]);
finally
  Data.Free;
end;

RxBuf := nil;
with AContext.Connection do
begin
  IOHandler.CheckForDataOnSource(100);
  if not IOHandler.InputBufferIsEmpty then
  begin
    InputBuffer.ExtractToBytes(RxBuf); //for TIdBytes
    AContext.Connection.IOHandler.WriteLn('hello');
  end;
end;

After sending hello the app never sends data from the queue.

How can I add the hello to Data extract from queue?

Something like this:

Data := TxClientContext(AContext).ExtractQueuedStrings;

and then

data.text:=data.text +'hello data';

or how can I add the 'hello data' in the queue?

Remy Lebeau
  • 555,201
  • 31
  • 458
  • 770
xrealtv xrealtv
  • 67
  • 7
  • 1
    In each thread, you add the resulting string into a global variable. That is not a safe operation. Instead, add an `OnTerminate` handler to your threads, where you add the result and also can keep track of the threads. This is safe, since the `OnTerminate` handler is executed in the main thread. – LU RD Apr 10 '19 at 08:39
  • and on procedure onterminate i will create i will add the result on global vairable ? – xrealtv xrealtv Apr 10 '19 at 08:41
  • An advice, stop using global variables. In this case, they belong to the `TForm1` class and should be declared within. – LU RD Apr 10 '19 at 08:42
  • Yes, the process to hand over the result should be done in the `OnTerminate` event. Search how to do this best with a callback method. – LU RD Apr 10 '19 at 08:45
  • it works is it correct now? – xrealtv xrealtv Apr 10 '19 at 08:48
  • please post your answer to accept it. – xrealtv xrealtv Apr 10 '19 at 08:59
  • No it does not work, please slow down and take some time to study how threading works. See [How to manage the return value of a thread?](https://stackoverflow.com/q/4136530/576719) for an example that uses Synchronize() to return a result from the thread. – LU RD Apr 10 '19 at 11:20

2 Answers2

1

In each thread, you add the resulting string into a global variable. That is not a safe operation. Instead, add an OnTerminate handler to your threads, where you add the result and also can keep track of the threads.

This is safe, since the OnTerminate handler is executed in the main thread. I suggest to pass a callback method to pass the result. It is declared like:

type
  TSyncMethod = procedure(const ReturnValue: String) of object;

Change the thread accordingly:

Type 
  TxClientThread = class(TThread)
    private
      furl : String;
      ftag : Integer;
      fCallbackMethod : TSyncMethod;
      fXMLResult : String;
      procedure AfterWork(Sender : TObject);
      ...
    public
      constructor Create(atag: Integer; AURL: string; CallbackMethod : TSyncMethod); reintroduce;
    ...
  end;

Add a callback method to your form:

Type
  TForm1 = Class(TForm1)
  private
    // Put your "global" variables here
    Threads_downloaded : Integer;
    Total_threads      : Integer;
    FullXML_STR        : String;
    procedure ManageThreadReturnValue(const ReturnValue : String); // Callback from threads
  ...
  end;

The implementation part:

constructor TxClientThread.Create(atag: Integer; AURL: string; CallbackMethod : TSyncMethod);
begin
  inherited Create(false);
  furl := Aurl;
  ftag := Atag;
  fCallbackMethod := CallbackMethod;
  fXMLResult := '';
  OnTerminate := AfterWork;  // Execute AfterWork when thread terminates (in main thread)
  FreeOnTerminate := True;
end;

procedure TxClientThread.Execute;
var
  lHttpClient : TIdHTTP;
  lResponseXML :String;
  lXML : IXMLDOMDocument;
  lNode : IXMLDomNode;
begin
  lHttpClient := TIdHTTP.Create(nil);
  try
    lHttpClient.Tag := ftag;
    lHttpClient.ConnectTimeout := 60000;
    lHttpClient.ReadTimeout := 60000;
    lHttpClient.Request.Accept := '*/*';
    lHttpClient.Request.UserAgent := 
      'Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';

    try 
      lResponseXML:= lHttpClient.Get(fUrl);
    except 
    end;
  finally
    lHttpClient.Free;
  end;

  ///******     parsing The XML
  CoInitialize(nil);
  try        
    lXML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
    lXML.async := false;
    try
      lXML.loadXML(lResponseXML); 
      lNode := lXML.selectSingleNode('/games');
      if lNode<>nil then
      begin
        fXMLResult := lNode.attributes.getNamedItem('id').text+'^';
      end;
    finally
      lnode := nil;
      lxml := nil; //---> Q: do i need this? 
                   //---> A: Yes, it must be finalized before CoUnitialize
    end;
  finally
    CoUninitialize;
  end;
end;

procedure TxClientThread.AfterWork;
begin
  if Assigned(fCallbackMethod) then
     fCallbackMethod(fXMLResult);  // Pass data
end;

procedure TForm1.ManageThreadReturnValue(const ReturnValue : String);
var
 i : Integer;
 Clients : TList;
begin
  // Take care of the return value and other things related to 
  // what happens when a thread ends.
  FullXML_STR := FullXML_STR + ReturnValue;
  Inc(threads_downloaded);
  if Threads_downloaded = Total_threads then
  begin
    if Assigned(IdTCPServer1.Contexts) then 
    begin
      Clients:= IdTCPServer1.Contexts.LockList;
      try
        for i:= Pred(Clients.Count) downto 0 do
        begin
          try
            TIdContext(Clients[i]).Connection.IOHandler.Writeln( 
              FullXML_STR,IndyTextEncoding_UTF8);
          except
          end;
        end;
      finally
        IdTCPServer1.Contexts.UnlockList;
      end;
    end;
    StartTimerAgain; ///Starting again The timer
  end;      
end;    

// Initiate threads 
FullXML_STR:='';
Timer1.Enabled:=false;
Threads_downloaded:=0;
Total_threads=100;    
for x:= 0 to Pred(Total_threads) do
begin
  aUrl:='http://example.com/myxml'+Formatfloat('0',x)+'.xml';
  TxClientThread.Create(x,aUrl,ManageThreadReturnValue);  // !! Never keep a reference to a thread with FreeOnTerminate = true
end;

Some other hints:

Put your global variables into the private section of TForm1. This is the place where they belong.

Remove the ClientThread array, since a reference to a thread with FreeOnTerminate = true should never be used.

Do not swallow exceptions, i.e. empty except end clauses are not a good practice.

By using the callback method, you decouple the thread from code/data that does not belong to the thread. That is one of the most important lessons to learn when programming (i.e. avoid making spaghetti code).

LU RD
  • 34,438
  • 5
  • 88
  • 296
  • if you check my edited code i have an procedure DoTerminate; override; and now as i said working fine Thanks to you ;) – xrealtv xrealtv Apr 10 '19 at 12:19
  • yes and there i get thre resultXMl and i add it to FullXML and works fine.Where is the wrong that way?Offcorse i will add your code to see.Until now the programm has nt stop respoding. – xrealtv xrealtv Apr 10 '19 at 12:49
  • I tested your code but is not compiled i get error E2009 Incompatible types: 'Parameter lists differ' on line fCallbackMethod := CallbackMethod; oncreate thread – xrealtv xrealtv Apr 10 '19 at 16:50
  • Fixed the types mistake and added a more complete handling of what should happen in the callback method. Note that a critical section will not be needed anymore. – LU RD Apr 10 '19 at 18:38
  • "*`lxml := nil; //---> Q: do i need this? //---> A: Not really, auto-releases when it goes out of scope`*" - except that is TOO LATE in this example. All COM interfaces MUST be released/nil'ed BEFORE `CoUninitialize()` is called. So either move the XML parsing into its own procedure with its own local COM variables, so else you have to explicitly nil all the COM variables manually. – Remy Lebeau Apr 10 '19 at 21:37
1

I see a lot of mistakes in your code. Rather than pointing them out individually, I would suggest just rewritting the entire code, especially since you are also asking for optimizations.

Try something more like this instead:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
  IdGlobal, IdContext, IdBaseComponent, IdComponent, IdTCPConnection, IdCustomTCPServer,
  IdTCPServer, IdThreadSafe;

type
  TIdTCPServer = class(IdTCPServer.TIdTCPServer)
  protected
    procedure DoTerminateContext(AContext: TIdContext); override;
  end;

  TForm1 = class(TForm)
    IdTCPServer1: TIdTCPServer;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure IdTCPServer1Connect(AContext: TIdContext);
    procedure IdTCPServer1Execute(AContext: TIdContext);
  private
    { Private declarations }
    IDs: TIdThreadSafeString;
    Threads: TList;
    procedure ThreadTerminated(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  System.Win.Comobj, MSXML2_TLB, ActiveX, System.SyncObjs, IdHTTP, IdYarn;

{$R *.dfm}

const
  maximumThreads = 100;//200;

{TxClientContext}

type 
  TxClientContext = class(TIdServerContext)
  private
    fQueue: TIdThreadSafeStringList;
    fInQueue: TEvent;
  public
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
    destructor Destroy; override;
    procedure AddStringToQueue(const S: string);
    function ExtractQueuedStrings: TStrings;
  end;

constructor TxClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
  inherited;
  fQueue := TIdThreadSafeStringList.Create;
  fInQueue := TEvent.Create(nil, True, False, '');
end;

destructor TxClientContext.Destroy; override;
begin
  fQueue.Free;
  fInQueue.Free;
  inherited;
end;

procedure TxClientContext.AddStringToQueue(const S: string);
var
  List: TStringList;
begin
  List := fQueue.Lock;
  try
    List.Add(S);
    fInQueue.SetEvent;
  finally
    fQueue.Unlock;
  end;
end;

function TxClientContext.ExtractQueuedStrings: TStrings;
var
  List: TStringList;
begin
  Result := nil;
  if fInQueue.WaitFor(INFINITE) <> 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;
    fInQueue.ResetEvent;
  finally
    fQueue.Unlock;
  end;
end;

{TxClientThread}

type
  TxClientThread = class(TThread)
  private
    fURL: String;
  protected
    procedure Execute; override;
  public
    GameID: string;
    constructor Create(AURL: string; AOnTerminate: TNotifyEvent); reintroduce;
  end;

constructor TxClientThread.Create(AURL: string; AOnTerminate: TNotifyEvent);
begin
  inherited Create(False);
  fURL := AURL;
  OnTerminate := AOnTerminate;
  FreeOnTerminate := True;
end;

procedure TxClientThread.Execute;
var
  HttpClient: TIdHTTP;
  ResponseXML: String;
  XML: IXMLDOMDocument;
  Node: IXMLDomNode;
begin
  HttpClient := TIdHTTP.Create(nil);
  try
    HttpClient.ConnectTimeout := 60000;
    HttpClient.ReadTimeout := 60000;
    HttpClient.Request.Accept := '*/*';
    HttpClient.Request.UserAgent := 'Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/73.0.3683.86 Safari/537.36';

    ResponseXML := HttpClient.Get(fURL);
  finally
    HttpClient.Free;
  end;

  CoInitialize(nil);
  try
    XML := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
    try
      XML.async := False;
      XML.loadXML(ResponseXML); 
      Node := XML.selectSingleNode('/games');
      if Node <> nil then
      try
        GameID := Node.attributes.getNamedItem('id').text;
      finally
        Node := nil;
      end;
    finally
      XML := nil;
    end;
  finally
    CoUninitialize;
  end;
end;

{TIdTCPServer}

procedure TIdTCPServer.DoTerminateContext(AContext: TIdContext);
begin
  inherited; // <-- closes the socket
  TxClientContext(AContext).FInQueue.SetEvent; // unblock OnExecute if it is waiting for data...
end;

{TForm1}

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdTCPServer1.ContextClass := TxClientContext;
  IDs := TIdThreadSafeString.Create;
  Threads := TList.Create;
  Threads.Capacity := maximumThreads;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  IDs.Free;
  Threads.Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  x: Integer;
  Thread: TxClientThread;
begin
  Timer1.Enabled := False;
  IDs.Value := '';
  for x := 0 to Pred(maximumThreads) do
  begin
    Thread := TxClientThread.Create('http://example.com/myxml' + IntToStr(x) + '.xml', ThreadTerminated);
    try
      Threads.Add(TObject(Thread));
    except
      Thread.Free;
      raise;
    end;
  end;
end;

proccedure TForm1.ThreadTerminated(Sender: TObject);
var
  Clients: TList;
  s: string;
  i: Integer;
begin
  try
    s := TxClientThread(Sender).GameID;
    if s <> '' then IDs.Append(s + '^');
  finally
    Threads.Remove(Sender);
  end;

  if (Threads.Count > 0) or (not Assigned(IdTCPServer1.Contexts)) then Exit;

  s := IDs.Value;
  if s = '' then Exit;

  Clients := IdTCPServer1.Contexts.LockList;
  try
    for i := Pred(Clients.Count) downto 0 do
    try
      TxClientContext(TIdContext(Clients[i])).AddStringToQueue(s);
    except
    end;
  finally
    IdTCPServer1.Contexts.UnlockList;
  end;

  Timer1.Enabled := True;
end;

procedure TForm1.IdTCPServer1Connect(AContext: TIdContext);
begin
  AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
end;

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
  Data: TStrings;
  i: Integer;
begin
  Data := TxClientContext(AContext).ExtractQueuedStrings;
  if Data <> nil then
  try
    for i := 0 to Pred(Data.Count) do
      AContext.Connection.IOHandler.WriteLn(Data[i]);
  finally
    Data.Free;
  end;
end;

end.
Remy Lebeau
  • 555,201
  • 31
  • 458
  • 770
  • I Dont Know How to Thank you.I really dont.Amazing as always – xrealtv xrealtv Apr 11 '19 at 06:41
  • well my app is running i must thank you again not even in 100 years i could manage to do it so elegend.You are a true master of delphi. – xrealtv xrealtv Apr 11 '19 at 09:32
  • The only Problem is that IDs keep growing all the time first i get 1^2^3 Then i send again 1^2^3^1^2^3 how can i clear the ids list before timer starts getting all xml? – xrealtv xrealtv Apr 11 '19 at 10:28
  • I added inside timer IDs.free; IDs := TIdThreadSafeString.Create; and is fixed. now – xrealtv xrealtv Apr 11 '19 at 10:35
  • @xrealtvxrealtv `IDs` is cleared by the `IDs.Value := '';` statement every time the timer is triggered, before it starts a new set of threads. There is no need to `Free` and re-`Create` it – Remy Lebeau Apr 11 '19 at 15:54
  • everything works fine now except that i cannot wait for text on idtcpserver.I edit my question if you can help also on this i will appreciate it a lot. – xrealtv xrealtv Apr 13 '19 at 20:45
  • @xrealtvxrealtv `ExtractQueuedStrings` uses an `INFINITE` timeout when waiting for outbound data to send to the client. I did that so `OnExecute` would sleep when it didn't have anything to do. But now, in order to check for inbound data periodically, you need to lower that wait timeout so `ExtractQuotedStrings` will exit even if no outbound data is pending. – Remy Lebeau Apr 14 '19 at 02:33