虚拟列表视图，线程和内存消耗不下降

*更新：两个人告诉我，没有真正的/完整的代码很难帮助我。 你几乎有它，但万一我忘记了什么，在这里！ laserrental.ca/MemoryProblem.zip

---

使用的Delphi版本：2007

你好，

我是线程和虚拟列表视图的新手，所以我的问题可能很容易解决; 然而，我一直坚持了几天。 基本上，这是我拥有的：

http://image.noelshack.com/fichiers/2012/32/1344440638-urlsloader.png

用户点击加载URL ，URL存储在以下记录中：

type TVirtualList=record
  Item:Integer; // Index
  SubItem1:String; // Status
  SubItem2:String; // URL
end;

...

var
 LURLs : Array of TVirtualList;

记录用于填充虚拟列表视图。 这里是OnData代码：

procedure TForm1.ListViewData(Sender: TObject; Item: TListItem);
begin
 Item.Caption := IntToStr(LURLs[Item.Index].Item);
 Item.SubItems.Add(LURLs[Item.Index].SubItem1);
 Item.SubItems.Add(LURLs[Item.Index].SubItem2);
end;

当用户点击GO时 ，应用程序将启动一个线程来控制工作线程的创建。 每个工作线程都会接收一个URL，下载并解析它以获取更多信息。

现在，这是我的问题：内存消耗总是越来越高 - 至少，根据任务管理器。 如果我最小化应用程序并再次打开它，内存消耗会恢复正常......但虚拟内存消耗保持非常高。 现在，我知道很多人说任务管理器是不可靠的。 然而，一段时间后，内存消耗变得非常高，无法再下载URL。 我收到一个EOutOfMemory错误。 我的电脑变得非常慢。

根据FastMM4，没有内存泄漏。

有趣的是：如果我清除TVirtualList记录，内存消耗（包括“正常”和虚拟内存）将恢复正常。 但除非我这样做，它保持超高。 显然，这是一个问题，因为我希望应用程序能够下载成千上万的URL; 但是有了这个错误，我不能走得太远。

清除TVirtualList记录的代码

ListView.Items.BeginUpdate;
SetLength(LURLs,0);
ListView.Items.Count := Length(LURLs);
ListView.Clear;
ListView.Items.EndUpdate;

---

所以我将应用程序剥离到了必不可少的地步。 没有解析，而是下载文件，应用程序使用关键部分加载单个本地HMTL文件。 内存消耗问题仍然存在。

---

控制线程：

unit Loader;

interface

uses Classes, SysUtils, Windows, Thread, Forms;

type
  TLoader = class(TThread)
  private
    { Private declarations }
  protected
    procedure Execute; override;
    procedure UpdateButtons;
    procedure UpdateListView;
  public
    constructor Create;
  end;

implementation

uses Main;

constructor TLoader.Create;
begin
 inherited Create(False);
 FreeOnTerminate := True;
end;

procedure TLoader.UpdateButtons;
begin
 Form1.BSwitch(false); // Re-enable interface
end;

procedure TLoader.UpdateListView;
begin
 Form1.ListView.Items.Item[BarP].MakeVisible(false); // Scroll down the listview
 Application.ProcessMessages;
end;

procedure TLoader.Execute;
begin
 while (BarP < Length(LURLs)) and (not(Terminated)) do  // Is there any URL left?
 begin
  if (ThreadsR < StrToInt(Form1.Threads.Text)) then // Have we met the threads limit?
  begin
   Synchronize(UpdateListView);
   TThreadWorker.Create(LURLs[BarP].SubItem1, BarP);
   InterlockedIncrement(ThreadsR);
   Inc(BarP);
  end else Sleep(100);
 end;

 while (not(ThreadsR = 0)) do Sleep(100);

 Synchronize(UpdateButtons);
end;

end.

工作者线程：

unit Thread;

interface

uses Classes, SysUtils, Windows, Forms;

type
  TThreadWorker = class(TThread)
  private
    { Private declarations }
    Position : Integer;
    HtmlSourceCode : TStringList;
    StatusMessage, TURL : String;
    procedure UpdateStatus;
    procedure EndThread;
    procedure AssignVariables;
    procedure DownloadURL;
  protected
    procedure Execute; override;
  public
    constructor Create(URL : String ; LNumber : Integer);
  end;

implementation

uses Main;

var CriticalSection: TRTLCriticalSection;

constructor TThreadWorker.Create(URL : String ; LNumber : Integer);
begin
 inherited Create(False);
 TURL := URL;
 Position := LNumber;
 FreeOnTerminate := True;
end;

procedure TThreadWorker.UpdateStatus;
begin
 LURLs[Position].SubItem1 := StatusMessage;
 Form1.ListView.UpdateItems(Position,Position);
end;

procedure TThreadWorker.EndThread;
begin
 StatusMessage := 'Success';
 Synchronize(UpdateStatus);
 InterlockedIncrement(NDone);

 // I free Synapse THTTPSend variable.

 HtmlSourceCode.Free;
 InterlockedDecrement(ThreadsR);
end;

procedure TThreadWorker.AssignVariables;
begin
 StatusMessage := 'Working...';
 Synchronize(UpdateStatus);

 // I initialize Synapse THTTPsend variable.

 HtmlSourceCode := TStringList.Create;
end;

procedure TThreadWorker.DownloadURL;
begin
 (* This is where I download the URL with Synapse. The result file is then loaded
 with HtmlSourceCode for further parsing. *)

 EnterCriticalSection(CriticalSection);
  HtmlSourceCode.LoadFromFile(ExtractFilePath(application.exename)+'testfile.html');
 LeaveCriticalSection(CriticalSection);

 Randomize;
 Sleep(1000+Random(1500)); // Only for simulation
end;

procedure TThreadWorker.Execute;
begin
 AssignVariables;
 DownloadURL;
 EndThread;
end;

initialization
  InitializeCriticalSection(CriticalSection);

finalization
  DeleteCriticalSection(CriticalSection);

end.

---

你所描述的听起来像是内存泄漏或内存碎片。 无论哪种方式，很难说，因为你不显示如何分配和填充URL数组本身。

我会建议彻底摆脱TLoader ，而不是使用throttled队列。 当下载一个url时，检查一个空闲的TWorker已经存在，如果存在，那么让它下载URL，否则，如果你还没有达到你的限制，请启动一个新的TWorker ，否则把URL放到队列中供以后处理。 每次TWorker完成时，它都可以检查队列中是否有要下载的新URL，如果队列为空， TWorker可以终止该TWorker 。

尝试这样的事情：

type
  TURLInfo = record 
    Index: Integer;
    Status: String;
    URL: String;
  end; 

...

private 
  LURLs: array of TURLInfo; 
  LURLQueue: TList;
  LWorkers : TList; 

...

uses
  ..., Worker;

const
  WM_REMOVE_WORKER := WM_USER + 100;

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  LURLQueue := TList.Create;
  LWorkers := TList.Create; 
end; 

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

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  StopWorkers;
end;

procedure TForm1.WndProc(var Message: TMessage);
var
  Worker: TWorker;
begin
  if Message.Msg = WM_REMOVE_WORKER then
  begin
    Worker := TWorker(Message.LParam);
    if LWorkers.Remove(Worker) <> -1 then
    begin
      Worker.Stop;
      Worker.WaitFor;
      Worker.Free;
    end;
  end else
    inherited;
end;

procedure TForm1.ListViewData(Sender: TObject; Item: TListItem); 
var
  Index: Integer;
begin 
  Index := Item.Index;
  Item.Caption := IntToStr(LURLs[Index].Index); 
  Item.SubItems.Add(LURLs[Index].Status); 
  Item.SubItems.Add(LURLs[Index].URL); 
end; 

procedure TForm1.ClearURLs;
begin 
  StopWorkers;
  ListView.Items.Count := 0; 
  SetLength(LURLs, 0); 
end;

procedure TForm1.DownloadURL(Number: Integer);
var
  I: Integer;
  Worker: TWorker;
begin
  for I := 0 to LWorkers.Count-1 do
  begin
    Worker := TWorker(LWorkers[I]);
    if Worker.Idle then
    begin
      if Worker.Queue(LURLs[Number].URL, Number) then
        Exit;
    end;
  end;
  if LWorkers.Count < StrToInt(Threads.Text) then
  begin
    Worker := TWorker.Create;
    try
      Worker.OnStatus := WorkerStatus;
      Workers.Add(Worker);
    except
      Worker.Free;
      raise;
    end;
    Worker.Resume;
    if Worker.Queue(LURLs[Number].URL, Number) then
      Exit;
  end;

  LURLQueue.Add(TObject(Number));

  LURLs[Number].Status := 'Queued'; 
  ListView.UpdateItems(Number, Number); 
end;

procedure TForm1.DownloadURLs;
var
  I: Integer;
begin 
  LURLQueue.Clear;
  for I := 0 to High(LURLs) do
    DownloadURL(I);
end; 

procedure TForm1.StopWorkers;
var
  I: Integer;
  Worker: Tworker;
begin
  LURLQueue.Clear;

  for I := 0 to LWorkers.Count-1 do
    TWorker(LWorkers[I]).Stop;

  for I := 0 to LWorkers.Count-1 do
  begin
    Worker := TWorker(LWorkers[I]);
    Worker.WaitFor;
    Worker.Free;
  end;

  LWorkers.Clear;
end;

procedure TForm1.WorkerStatus(Sender: TWorker; APosition: Integer; const Status: String; Done: Boolean);
var
  URL: String;
  Number: Integer;
begin
  LURLs[APosition].Status := Status; 
  ListView.UpdateItems(APosition, APosition); 

  if not Done then Exit;

  if LURLQueue.Count = 0 then
  begin
    Sender.Stop;
    PostMessage(Handle, WM_REMOVE_WORKER, 0, Sender);
    Exit;
  end;

  Number := Integer(LURLQueue[0]);

  if Sender.Queue(LURLs[Number].URL, Number) then
    LURLQueue.Delete(0);
end;

。

unit Worker; 

interface 

uses
  Classes, SysUtils, HttpSend; 

type 
  TWorker = class;
  TWorkerStatusEvent = procedure(Sender: TWorker; ANumber: Integer; const Status: String; Done: Boolean) of object;

  TWorker = class(TThread) 
  private 
    { Private declarations } 
    Http: THTTPsend;
    Signal: TEvent;
    Number : Integer; 
    HtmlSourceCode : TStringList; 
    StatusMessage, URL : String; 
    StatusDone : Boolean; 
    FOnStatus: TWorkerEvent;
    procedure UpdateStatus(const Status: String; Done: Boolean); 
    procedure DoUpdateStatus; 
    procedure DownloadURL; 
  protected 
    procedure Execute; override; 
    procedure DoTerminate; override; 
  public 
    Idle: Boolean;
    constructor Create; 
    destructor Destroy; override; 
    function Queue(AURL: String; ANumber: Integer): Boolean;
    procedure Stop;
    property OnStatus: TWorkerStatusEvent read FOnStatus write FOnStatus;
  end; 

implementation 

constructor TWorker.Create; 
begin 
  inherited Create(True); 
  Signal := TEvent.Create(nil, False, False, '');
  Http := THTTPsend.Create;
  HtmlSourceCode := TStringList.Create; 
end; 

constructor TWorker.Destroy; 
begin 
  Signal.Free;
  HtmlSourceCode.Free; 
  Http.Free;
  inherited Destroy; 
end; 

function TWorker.Queue(AURL: String; ANumber: Integer): Boolean;
begin
  if (not Terminated) and Idle then
  begin
    URL := AURL; 
    Number := ANumber;
    Signal.SetEvent;
    Result := True;
  end else
    Result := False;
end;

procedure TWorker.Stop;
begin
  Terminate;
  Signal.SetEvent;
end;

procedure TWorker.UpdateStatus(const Status: String; Done: Boolean); 
begin
  if Assigned(FOnStatus) then
  begin
    StatusMessage := Status;
    StatusDone := Done;
    Synchronize(DoUpdateStatus); 
  end;
end;

procedure TWorker.DoUpdateStatus; 
begin 
  if Assigned(FOnStatus) then
    FOnStatus(Self, Number, StatusMessage, StatusDone);
end; 

var
  HtmlFileName: String;

procedure TWorker.Execute; 
begin 
  Randomize; 
  while not Terminated do
  begin
    Idle := True;

    if Signal.WaitFor(Infinite) <> wrSignaled then Exit;
    if Terminated then Exit;

    Idle := False;
    try
      try
        UpdateStatus('Working...', False); 
        if Terminated then Exit;

        // initialize THTTPsend...
        // download URL...
        // parse HTML...
        //
        HtmlSourceCode.LoadFromFile(HtmlFileName); 
        Sleep(1000+Random(1500)); // Only for simulation 

        UpdateStatus('Success', True); 
      finally
        HtmlSourceCode.Clear; 
      end;
    except
      UpdateStatus('Error', True); 
    end;
  end;
end; 

procedure TWorker.DoTerminate;
begin
  Idle := False;
  Terminate;
  inherited;
end; 

initialization
  HtmlFileName := ExtractFilePath(ParamStr(0)) + 'testfile.html';

end. 

链接地址: http://www.djcxy.com/p/5971.html

上一篇: Virtual Listview, threads and memory consumption that doesn't go down

下一篇: VirtualTreeView Finalize in C++ Builder for UnicodeString