GUI中的tIdHttp内部线程和IdTCPServer

Question

我在TForm 上有一个TTimer，其中计时器设置为 5 秒并创建 100 个线程以从远程服务器获取 XML。

每次执行线程时，我都会将 XML 添加到变量 (FullXML_STR:String)。

当所有线程都完成后，我会将FullXML_STR 发送给连接到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.

主要问题是程序在 1-2 小时后没有响应。

1. 在每个线程的Execute()，我检查是否所有线程都已完成下载。有没有更好的方法来知道我的所有线程都已完成？

2. 在定时器开始创建线程之前调用TIdTCPServer上的Contexts.LockList()，线程完成后解锁是否更好？

3. 我可以做些什么来优化我的代码，这样我就可以确定计时器将一直处于活动状态？所有线程都完成后，我正在重新启动计时器。 这是正确的做法吗？

请求：

如何从连接在TIdTCPServer 上的客户端接受hi 之类的字符串并返回一个字符串。

我尝试添加以下代码：

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;

在发送hello 后，该应用永远不会从队列中发送数据。

如何将hello 添加到从队列中提取的数据中？

类似这样的：

Data := TxClientContext(AContext).ExtractQueuedStrings;

然后

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

或者如何在队列中添加'hello data'？

Answer 1

我发现您的代码中有很多错误。我建议不要单独指出它们，而是重写整个代码，尤其是因为您还要求优化。

尝试类似的方法：

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.

Answer 2

在每个线程中，将生成的字符串添加到全局变量中。这不是一个安全的操作。相反，将OnTerminate 处理程序添加到您的线程，您可以在其中添加结果并且还可以跟踪线程。

这是安全的，因为OnTerminate 处理程序在主线程中执行。 我建议通过一个回调方法来传递结果。声明如下：

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

相应地更改线程：

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;

在表单中添加回调方法：

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; 

实现部分：

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;

---

其他一些提示：

将您的全局变量放入TForm1 的私有部分。这是他们所属的地方。

删除ClientThread 数组，因为不应使用对带有FreeOnTerminate = true 的线程的引用。

不要吞下异常，即空 except end 子句不是一个好习惯。

通过使用回调方法，您可以将线程与不属于该线程的代码/数据分离。这是编程时要学习的最重要的课程之一（即避免制作意大利面条式代码）。