3

*更新: 2 人の人が、実際の/完全なコードがなければ、私を助けるのは難しいと言いました. ほとんどは下にありますが、何か忘れた場合はここにあります。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をクリックすると、アプリはワーカー スレッドの作成を制御する 1 つのスレッドを起動します。各ワーカー スレッドは 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.
4

1 に答える 1

1

あなたが説明することは、メモリリークまたはメモリの断片化のように聞こえます。いずれにせよ、URL 配列自体をどのように割り当てて埋めるかを示していないため、わかりにくいです。

TLoader完全に削除して、代わりに調整されたキューを使用することをお勧めします。URL をダウンロードするときは、アイドル状態TWorkerが既に存在するかどうかを確認し、存在する場合は URL をダウンロードさせます。それ以外のTWorker場合は、まだ制限に達していない場合は新しいものを開始し、そうでない場合は後で処理するために URL をキューに入れます。が終了するたびに、TWorkerダウンロードする新しい URL のキューをチェックし、キューが空の場合は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.
于 2012-08-09T02:11:23.163 に答える