Delphi：如何防止单线程应用程序丢失响应？

Question

我正在使用 Delphi 开发一个单线程应用程序，它会执行一项耗时的任务，如下所示：

// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
    DoTask();
End;

当循环开始时，应用程序将失去对最终用户的响应。那不是很好。由于它的复杂性，我也不想将其转换为多线程应用程序，因此我相应地添加了 Application.ProcessMessages，

// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
DoTask();
Application.ProcessMessages;
End;

不过，这一次应用虽然会响应用户操作，但在循环中消耗的时间比原来的循环要多很多，大约是10倍左右。

是否有解决方案可以确保应用程序不会丢失响应，同时又不会过多增加消耗的时间？

Answer 1

你真的应该使用工作线程。这就是线程的好处。

使用Application.ProcessMessages() 是一种创可贴，而不是解决方案。在DoTask() 工作时，您的应用程序仍将无响应，除非您乱扔DoTask() 并额外调用Application.ProcessMessages()。另外，如果不小心，直接调用Application.ProcessMessages() 会引入重入问题。

如果你必须直接调用Application.ProcessMessages()，那么除非有消息真正等待处理，否则不要调用它。您可以使用 Win32 API GetQueueStatus() 函数来检测该情况，例如：

// time-consuming loop
For I := 0 to 1024 * 65536 do
Begin
  DoTask();
  if GetQueueStatus(QS_ALLINPUT) <> 0 then
    Application.ProcessMessages;
End;

否则，将 DoTask() 循环移动到一个线程中（是的，是的），然后让你的 main 循环使用MsgWaitForMultipleObjects() 等待任务线程完成。 这仍然允许您检测何时处理消息，例如：

procedure TMyTaskThread.Execute;
begin
  // time-consuming loop
  for I := 0 to 1024 * 65536 do
  begin
    if Terminated then Exit;
    DoTask();
  end;
end;

var
  MyThread: TMyTaskThread;
  Ret: DWORD;
begin
  ...
  MyThread := TMyTaskThread.Create;
  repeat
    Ret := MsgWaitForMultipleObjects(1, Thread.Handle, FALSE, INFINITE, QS_ALLINPUT);
    if (Ret = WAIT_OBJECT_0) or (Ret = WAIT_FAILED) then Break;
    if Ret = (WAIT_OBJECT_0+1) then Application.ProcessMessages;
  until False;
  MyThread.Terminate;
  MyThread.WaitFor;
  MyThread.Free;
  ...
end;

Answer 2

你说：

我也不想将其转换为多线程应用程序 因为它的复杂性

我可以把它理解为两件事之一：

1. 您的应用程序是一团乱七八糟的遗留代码，它们如此庞大且编写​​得如此糟糕，以至于将 DoTask 封装在一个线程中意味着大量的重构，而无法为其制定可行的业务案例。
2. 您觉得编写多线程代码太“复杂”，不想学习如何去做。

如果情况是 #2，那么就没有任何借口 - 多线程是这个问题的明确答案。将方法滚动到线程中并不可怕，您将成为学习如何做的更好的开发人员。

如果情况是 #1，我让你来决定，那么我会注意到，在循环期间，你将调用 Application.ProcessMessages 6700 万次：

For I := 0 to 1024 * 65536 do
Begin
  DoTask();
  Application.ProcessMessages;
End;

掩盖这种罪行的典型方法是不每次运行循环时都调用Application.ProcessMessages。

For I := 0 to 1024 * 65536 do
Begin
  DoTask();
  if I mod 1024 = 0 then Application.ProcessMessages;
End;

但是如果Application.ProcessMessages 的执行时间实际上是DoTask() 的十倍，那么我真的怀疑DoTask 到底有多复杂，以及将其重构为线程是否真的是一项艰巨的工作。如果您使用ProcessMessages 解决此问题，您真的应该将其视为临时解决方案。

特别注意使用ProcessMessages 意味着您必须确保所有消息处理程序都是可重入的。

Answer 3

Application.ProcessMessages 应该避免。它可能会给您的程序带来各种奇怪的事情。必读：The Dark Side of Application.ProcessMessages in Delphi Applications。

在您的情况下，线程是解决方案，即使 DoTask() 可能需要稍微重构才能在线程中运行。

这是一个使用anonymous thread 的简单示例。 （需要 Delphi-XE 或更新版本）。

uses
  System.Classes;

procedure TForm1.MyButtonClick( Sender : TObject);
var
  aThread : TThread;
begin
  aThread :=
    TThread.CreateAnonymousThread(
      procedure
      var
        I: Integer;
      begin
        // time-consuming loop
        For I := 0 to 1024 * 65536 do
        Begin
          if TThread.CurrentThread.CheckTerminated then
            Break;
          DoTask();
        End;
      end
    );
  // Define a terminate thread event call
  aThread.OnTerminate := Self.TaskTerminated;
  aThread.Start;
  // Thread is self freed on terminate by default
end;

procedure TForm1.TaskTerminated(Sender : TObject);
begin
  // Thread is ready, inform the user
end;

线程是自毁的，你可以在你的表单中添加一个OnTerminate调用到一个方法。

Answer 4

在每次迭代时调用Application.ProcessMessages 确实会降低性能，如果你无法预测每次迭代需要多长时间，每隔几次调用它并不总是很好，所以我通常会使用GetTickCount 来100 毫秒过去的时间 (1)。这足够长，不会过多地降低性能，并且足够快以使应用程序看起来响应。

var
  tc:cardinal;
begin
  tc:=GetTickCount;
  while something do
   begin
    if cardinal(GetTickCount-tc)>=100 then
     begin
      Application.ProcessMessages;
      tc:=GetTickCount;
     end;
    DoSomething;
   end;
end;

(1)：不完全是 100 毫秒，但在某个接近的地方。有更精确的方法来测量时间，例如 QueryPerformanceTimer，但同样需要更多的工作并且可能会影响性能。

Answer 5

@user2704265，当您提到“应用程序将失去对最终用户的响应”时，您的意思是您希望您的用户继续在您的应用程序中点击和打字吗？在这种情况下 - 注意前面的答案并使用线程。

如果它足以提供您的应用程序正忙于冗长的操作[并且没有冻结]的反馈，那么您可以考虑一些选项：

• 禁用用户输入
• 将光标更改为“忙碌”
• 使用进度条
• 添加取消按钮

根据您对单线程解决方案的要求，我建议您首先禁用用户输入并将光标更改为“忙碌”。

procedure TForm1.ButtonDoLengthyTaskClick(Sender: TObject);
var i, j : integer;
begin
  Screen.Cursor := crHourGlass;
  //Disable user input capabilities
  ButtonDoLengthyTask.Enabled := false;

  Try
    // time-consuming loop
    For I := 0 to 1024 * 65536 do
    Begin
       DoTask();

      // Calling Processmessages marginally increases the process time
      // If we don't call and user clicks the disabled button while waiting then
      // at the end of ButtonDoLengthyTaskClick the proc will be called again
      // doubling the execution time.

      Application.ProcessMessages;

    End;
  Finally
    Screen.Cursor := crDefault;
    ButtonDoLengthyTask.Enabled := true;
  End;
End;