Speicherüberlauf?

[Stamper]

Hab ein Programm geschrieben, welches nach einer ganze Liste von Dateinamen suchen kann. Wenn ich ein Duzend Dateinamen eingebe, läuft alles reibungslos. Gebe ich aber ein paar hundert Dateinamen ein, stürzt das Programm ab. Vielleicht läuft der Speicher über!?

Hier der Auszug um die Suchprozedur:

Delphi-Quellcode:

procedure GetAllFiles (Mask_: String; Items_: TStrings);
const
  FileAttr = faReadOnly+faHidden+faArchive;
var
  Search: TSearchRec;
  SFName: String;
  SFPath: String;
begin
  SFName := ExtractFileName(Mask_);
  SFPath := ExtractFilePath(Mask_);

  if SFPath[Length(SFPath)]<>'\' then SFPath := SFPath+'\';
  // alle Dateien suchen
  if FindFirst(Mask_, FileAttr, Search)=0 then
  begin
    repeat
    begin
      Items_.Add(SFPath+Search.Name)
    end
    until FindNext(Search)<>0
  end;
  // Unterverzeichnisse durchsuchen
  if FindFirst(SFPath+'*.*',faDirectory,Search)=0 then
  begin
    repeat
    begin
      if ((Search.Attr and faDirectory)=faDirectory)
        and (Search.name[1]<>'.') then
        begin
        // Selbstaufruf von GetAllFiles
          GetAllFiles(SFPath+Search.Name+'\'+SFName,Items_)
        end
    end
    until FindNext(Search)<>0
  end;
  FindClose(Search);
end;

procedure TForm1.btnSuchenClick(Sender: TObject);
var
  Suchobjekt: String;
  i, i0: Integer;
  test: tmsgdlgbtn;
begin
   If Edit1.Text = 'Zu durchsuchendes Verzeichnis' then
   begin
    OrdnerauswahlClick;
   end else
   If Memo1.Lines[0] = 'Bitte geben Sie das/die zu suchende(n) Objekt(e) ein!' then
   begin
    Showmessage('Bitte geben Sie das/die zu suchende(n) Objekt(e) ein!');
   end
 else

 begin
 screen.Cursor := crHourglass;

 For i := 0 to Memo1.Lines.Count-1 do
 begin
  Suchobjekt := Memo1.Lines[i];
  If not CheckBox1.Checked then
  begin
    Suchobjekt := '*' + Suchobjekt + '*';
  end;
    GetAllFiles (Edit1.Text + '\' + Suchobjekt, clbSuchergebnisse.Items);
 end;

 If clbSuchergebnisse.Items.Count = 0 then
   StatusBar1.Panels[0].Text := 'Es wurden keine Objekte gefunden.';
 If clbSuchergebnisse.Items.Count = 1 then
   StatusBar1.Panels[0].Text := 'Es wurde 1 Objekt gefunden.';
 If clbSuchergebnisse.Items.Count > 1 then
   StatusBar1.Panels[0].Text := 'Es wurden ' + IntToStr(clbSuchergebnisse.Items.Count)
                                             + ' Objekte gefunden.';

  For i := Memo1.Lines.Count+1 downto 1 do
  begin
    For i0 := 1 to clbSuchergebnisse.Count do
    begin
      If Memo1.Lines[i-1] = ExtractFileName(clbSuchergebnisse.Items[i0-1]) then
      begin
        Memo1.Lines.Delete(i-1);
      end;
    end;
  end;
  screen.Cursor := crDefault;
  end;
end;

Kann mir jemand helfen?

[shmia]

Du musst neben dem Verzeichnisnamen "." auch ".." abfangen !!
Ansonsten geht deine Prozedure über ".." ein Verzeichnis nach oben, grasst alle Dateien ab, findet ein echtes Verzeichnis, durchläuft dieses, findet "..", geht rekursiv nach oben....
Ein Teufelskreis .

[DeddyH]

Zitat:

if ((Search.Attr and faDirectory)=faDirectory) and (Search.name[1]<>'.') then

Der Ansatz ist aber da.

[shmia]

Zitat von DeddyH:

Der Ansatz ist aber da.

Ja, hast recht, das wurde auch ".." erfassen.

[Stamper]

Also, ich bin mir gar nicht so sicher, dass es an der Suchroutine selber liegt. Hab die nicht selber geschrieben, sondern einfach ausem INet geklaut.^^ Aber vorher hatte ich eine andere und mit der hatte ich das gleiche Problem. Ich bin da einfach ratlos. Denn in der OnClick-Prozedur find ich nichts, was diesen Fehler rechtfertigt.

[Christian Seehase]

Moin Stamper,

also mir fallen da, auf Anhieb, ein paar unschöne Stellen auf

Erstens:

Delphi-Quellcode:

const
  FileAttr = faReadOnly+faHidden+faArchive;

Flags niemals mit + verknüpfen, sondern immer mit or.
Das hat hier zwar keine Auswirkungen, aber besser Du gewöhnst Dir das + gar nicht erst an (ich weiss, in der Delphi-Hilfe steht es auch mit +, aber dadurch wird's nicht besser )
Hintergrund:
Sollte bei verschiedenen Konstanten mal das gleiche Bit gesetzt sein, so erhält man bei +, unter Umständen, eine ungültige oder, schlimmer noch, unerwünschte Bitmaske. Bei or kann das nicht passieren.

Delphi-Quellcode:

const
  FileAttr = faReadOnly or faHidden or faArchive;

Zweitens:
Das hier:

if SFPath[Length(SFPath)]<>'\' then SFPath := SFPath+'\'; kann schief gehen, wenn die Länge von SFPath gleich 0 ist.
Besser wäre die Verwendung von IncludeTrailingPathDelimiter oder IncludeTrailingBackslash.


Drittens:

Zumindest beim ersten erfolgreich ausgeführten FindFirst fehlt das zugehörige FindClose.
Ausserdem fehlen jeweils die Resourcenschutzblöcke (try/finally)

Delphi-Quellcode:

if FindFirst ... = 0 then begin
  try
  finally
    FindClose...
  end;
end;

Viertens:
Diese Prüfung:

(Search.name[1]<>'.') ist schlicht falsch, da Datei und Verzeichnisnamen mit einem Punkt beginnen dürfen.
Es müssen explizit die Namen . und .. geprüft werden.

(Search.Name <> '.') and (Search.Name <> '..')

[DeddyH]

Moin Christian,
da hab ich lange drauf gewartet, aber ich wollte Dir nicht vorgreifen

[Stamper]

Ich hab die Tipps von Christian umgesetzt. Hat aber dennoch nicht funktioniert. Aber ihr habt trotzdem richtig gelegen. Ich hab ne neue Suchroutine von Delphi-Treff: Rekursive Dateisuche genommen und siehe da: es funktioniert.

Das sieht jetzt folgendermaßen aus:

Delphi-Quellcode:

procedure GetFilesInDirectory(Directory: String; Fileobject: String;
                              List: TStrings;
                              WithSubDirs, ClearList: Boolean);

procedure ScanDir(const Directory: String);
var
  SR: TSearchRec;
begin
  if FindFirst(Directory + Fileobject, faAnyFile and not faDirectory, SR) = 0 then try
    repeat
      List.Add(Directory + SR.Name)
    until FindNext(SR) <> 0;
  finally
    FindClose(SR);
  end;

  if WithSubDirs then begin
    if FindFirst(Directory + '*.*', faAnyFile, SR) = 0 then try
      repeat
        if ((SR.attr and faDirectory) = faDirectory) and
           (SR.Name <> '.') and (SR.Name <> '..') then
          ScanDir(Directory + SR.Name + '\');
      until FindNext(SR) <> 0;
    finally
      FindClose(SR);
    end;
  end;
end;

begin
  List.BeginUpdate;
  try
    if ClearList then
      List.Clear;
    if Directory = '' then Exit;
    if Directory[Length(Directory)] <> '\' then
      Directory := Directory + '\';
    ScanDir(Directory);
  finally
    List.EndUpdate;
  end;
end;

procedure TForm1.btnSuchenClick(Sender: TObject);
var
  Suchobjekt: String;
  i, i0: Integer;
  test: tmsgdlgbtn;
begin
   If Edit1.Text = 'Zu durchsuchendes Verzeichnis' then
   begin
    OrdnerauswahlClick;
   end else
   If Memo1.Lines[0] = 'Bitte geben Sie das/die zu suchende(n) Objekt(e) ein!' then
   begin
    Showmessage('Bitte geben Sie das/die zu suchende(n) Objekt(e) ein!');
   end
 else

 begin
 screen.Cursor := crHourglass;

 For i := 0 to Memo1.Lines.Count-1 do
 begin
  Suchobjekt := Memo1.Lines[i];
  If not CheckBox1.Checked then
  begin
    Suchobjekt := '*' + Suchobjekt + '*';
  end;
    GetFilesInDirectory(Edit1.Text, Suchobjekt, clbSuchergebnisse.Items, True, False);
 end;

 If clbSuchergebnisse.Items.Count = 0 then
   StatusBar1.Panels[0].Text := 'Es wurden keine Objekte gefunden.';
 If clbSuchergebnisse.Items.Count = 1 then
   StatusBar1.Panels[0].Text := 'Es wurde 1 Objekt gefunden.';
 If clbSuchergebnisse.Items.Count > 1 then
   StatusBar1.Panels[0].Text := 'Es wurden ' + IntToStr(clbSuchergebnisse.Items.Count)
                                             + ' Objekte gefunden.';

  For i := Memo1.Lines.Count+1 downto 1 do
  begin
    For i0 := 1 to clbSuchergebnisse.Count do
    begin
      If Memo1.Lines[i-1] = ExtractFileName(clbSuchergebnisse.Items[i0-1]) then
      begin
        Memo1.Lines.Delete(i-1);
      end;
    end;
  end;
  screen.Cursor := crDefault;
  end;
end;

Allerdings hängt er etwas bei längeren Listen. Also ich bin hingegangen und hab nach bestimmt 500 bis 600 Dateien suchen lassen, und wenn ich dann mal zwischendurch das Fenster wechsel und dann wieder zurückkehre, sehe ich das ganze Fenster erst mal nur in weiß, und wenn die Suche dann fertig ist, sehe ich aber alles wieder in ordentlicher Form.

[DeddyH]

Das ist normal, weil die Botschaftswarteschlange während der Ausführung nicht abgearbeitet wird. Abhilfe kann hier das Einstreuen vonApplication.ProcessMessages; schaffen, allerdings solltest Du das nicht nach jedem Treffer machen, sondern z.B. nach jedem 50. Dafür brauchst Du dann einen internen Zähler.

[Stamper]

Ja, so was in der Richtung habe ich gesucht. Danke!