Поиск на всем ПК не чуств. к регистру

[Человек_Борща]

Доброго времени суток!


Собственно пишу приложение.

Перед мною стоит задачка:
Реализовать поиск файлов на всех логических(фиксированных) дисках.
Поиск не чувствителен к регистру символов.

Порыскал по форуму, в итоге у меня есть такой код:
Получение списка дисков:

procedure GetLogicalFixedDrives(aReciver: Tstrings);
var drives: set of 0..25;
  drive: integer;
  dChar: Char;
begin
  DWORD(drives) := GetLogicalDrives;
  for drive := 0 to 25 do
  begin
    if drive in drives then
    begin
      dChar := Chr(drive + Ord('A'));
      if TDriveType(GetDriveType(PChar(dChar + ':\'))) = dtFIXED then
      begin
        aReciver.Add(dChar + ':\');
      end;
    end;
  end;
end;

Функция поиска:

procedure FindRecursive(path: string; mask: string; Reciver:TStrings);
var
  fullpath: string;
  function Recurse(path: string; mask: string): Boolean;
  var
    SRec: TSearchRec;
    retval: Integer;
    oldlen: Integer;
  begin
    Recurse := True;
    oldlen := Length(path);
    retval := FindFirst(path + mask, faAnyFile, SRec);
    while retval = 0 do
    begin
      if (SRec.Attr and (faDirectory or faVolumeID)) = 0 then
      Reciver.Add(path + SRec.name);
      retval := FindNext(SRec);
    end;
    FindClose(SRec);
    if not Result then
      Exit;
    retval := FindFirst(path + '*.*', faDirectory, SRec);
    while retval = 0 do
    begin
      if (SRec.Attr and faDirectory) <> 0 then
        if (SRec.name <> '.') and (SRec.name <> '..') then
        begin
          path := path + SRec.name + '\';
          if not Recurse(path, mask) then
          begin
            Result := False;
            Break;
          end;
          Delete(path, oldlen + 1, 255);
        end;
      retval := FindNext(SRec);
    end;
    FindClose(SRec);
  end; { Recurse }

begin
  if path = '' then
    GetDir(0, fullpath)
  else
    fullpath := path;
  if fullpath[Length(fullpath)] <> '\' then
    fullpath := fullpath + '\';
  if mask = '' then
    Recurse(fullpath, '*.*')
  else
    Recurse(fullpath, mask);
end;

Использование:

unit Unit1;

interface

uses
  Windows,
  SysUtils,
  Classes,
  Controls,
  Forms,
  StdCtrls,
  sButton,
  sListBox,
  FileCtrl;

type
  TForm1 = class(TForm)
    sListBox1: TsListBox;
    sButton1: TsButton;
    Button1: TButton;
    Memo1: TMemo;
    Memo2: TMemo;
    Label1: TLabel;
    procedure sButton1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.sButton1Click(Sender: TObject);
begin
  sListBox1.Items.Clear;
  GetLogicalFixedDrives(sListBox1.Items);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i,i2:integer;
begin
  for i:=1 to Memo1.Lines.Count do
  begin
     for i2:=1 to sListBox1.Items.Count do
     begin
       FindRecursive(sListBox1.Items[i2],Memo1.Lines.Strings[i],Memo2.Lines);
     end;
  end;
end;

end.

Memo1 - список имён файлов которые надо найти.
memo2 - приёмник результатов поиска
slistBox1 - список дисков


Помогите с решением проблем....

[raxp]

...каких проблем? lowercase, uppercase

[Пепел Феникса]

добавлю к верному ответу, что приводить к одному регистру в винде можно спокойно, ФС не регистрозависимая.

[Человек_Борща]

Вот наклацал рекурсивный поиск. Но почему он не копает файлы в под папках?

procedure FindFilesMy(StartDir: string; Mask: string; List: TStrings);
var
  SearchRec: TSearchRec;
  Buff: string;
begin
  //извлепкаем путь до данного exe-файла независимо от того где ое лежит
  if Mask = '' then
    Mask := '*.*';
  //если неуказана маска файлов ставим по умолчанию все.
  IncludeTrailingPathDelimiter(StartDir);
  //
  if FindFirst(StartDir + Mask, faAnyFile, SearchRec) = 0 then
  begin
    repeat Application.ProcessMessages;
      if (SearchRec.Attr and faDirectory) <> faDirectory then
      begin
        if StartDir + SearchRec.Name <> StartDir then
        begin
          List.Add(StartDir + SearchRec.Name);
          Application.ProcessMessages;
        end;
      end
      else if (SearchRec.Name <> '..') and (SearchRec.Name <> '.') then
      begin
        FindFilesMy(StartDir + SearchRec.Name + '\', Mask, List);
      end;
    until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
  end;
end;

т.е. есть файл file1.txt, он лежит на C:\ диске.
Его этот код находит.

Но этот файл я раскопировал по всей папке windows и её подпапках. Почему туда не заходит, и не показывает что там тоже есть эти файлы...?

[Аватар]

Маска и на имена каталогов распространяется, вот каталоги и не находит и, как следствие, рекурсия не распространяется на вложенные каталоги

[Человек_Борща]

Окей. Спасибо, чуток изменил...

Теперь другая прооблема. По скольку поиск в один поток по всему винту - это доолго. Я решил проблему многопоточностью.

Схема такая:
Потоку передаём диск, и список файлов которые надо искать.
Поток ищет файлы на заданом диске, и выводит их в общий TStrings.

Но тут проблема - потоков несколько. Список с результатами только один.
Есть вариант что у потока будет свой список результатов. Потом эти результаты будут сложены в единое целое.

Но я пытаюсь решить это с помощью критических секций...

Код основной программы:

  DriveList: TStringList; //Список дисков


implementation

uses SearchThreadUnit;

{$R *.dfm}

procedure GetLogicalFixedDrives(aReciver: Tstrings);
var drives: set of 0..25;
  drive: integer;
  dChar: Char;
begin
  DWORD(drives) := GetLogicalDrives;
  for drive := 0 to 25 do
  begin
    if drive in drives then
    begin
      dChar := Chr(drive + Ord('A'));
      if TDriveType(GetDriveType(PChar(dChar + ':\'))) = dtFIXED then
      begin
        aReciver.Add(dChar + ':\');
      end;
    end;
  end;
end;

procedure TForm1.GoSearchBtnClick(Sender: TObject);
var
  i: integer;
begin
  for i := 0 to DriveList.Count - 1 do
  begin
    RunSRThread(DriveList.Strings[i], FilesForFindMemo.Lines, ResultsMemo.Lines);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DriveList := TStringList.Create;
  GetLogicalFixedDrives(DriveList);
end;

procedure TForm1.RunSRThread(aDir: string; aFilesList: Tstrings; aOut: Tstrings);
var
  Thr: TSearchThread;
begin
  Thr := TSearchThread.Create(True);
  Thr.FreeOnTerminate := True;
  Thr.Priority := tpNormal;
  Thr.Directory := adir;
  Thr.FilesForFind := aFilesList;
  Thr.OutList := aOut;
  Thr.Resume;
end;

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

end.

Код потока:

type
  TSearchThread = class(TThread)
  private
    { Private declarations }
    fDirForScan: string; //что сканируем
    fFilesForFind: Tstrings; //Cписок файлов для поиска
    fOutList: Tstrings; //Куда выводим
    CS: TCriticalSection;
  protected
    procedure Execute; override;
  public
    property Directory: string read fDirForScan write fDirForScan;
    property OutList: Tstrings read fOutList write fOutList;
    property FilesForFind: TStrings read fFilesForFind write fFilesForFind;

    procedure RecursiveFilesSearch(aFolder, aMask: string; aOutList: TStrings; AllowSubFolders: boolean = True);
  end;

implementation

procedure TSearchThread.RecursiveFilesSearch(aFolder, aMask: string;
  aOutList: TStrings; AllowSubFolders: boolean);
var
  SearchRec: TSearchRec;
  FindResult: Integer;
begin
  CS := TCriticalSection.Create;
  aOutList.BeginUpdate;
  try
    aFolder := IncludeTrailingBackslash(aFolder);
    FindResult := Sysutils.FindFirst(aFolder + '*.*', faAnyFile, SearchRec);
    try
      while FindResult = 0 do
        with SearchRec do
        begin
          if (Attr and faDirectory) <> 0 then
          begin
            if AllowSubFolders and (Name <> '.') and (Name <> '..') then
              RecursiveFilesSearch(aFolder + Name, aMask, aOutList, AllowSubFolders);
          end
          else
          begin
            if MatchesMask(Name, aMask) then
              Cs.Enter;
            aOutList.Add(aFolder + Name);
            application.ProcessMessages;
            Cs.Leave;
          end;
          FindResult := Sysutils.FindNext(SearchRec);
        end;
    finally
      Sysutils.FindClose(SearchRec);
    end;
  finally
    aOutList.EndUpdate;
    Cs.Free;
  end;
end;

{ TSearchThread }

procedure TSearchThread.Execute;
var
  i: Integer;
begin
  while not terminated do
  begin
   for i:=0 to fFilesForFind.Count -1 do
   begin
   RecursiveFilesSearch(fDirForScan, fFilesForFind.Strings[i], fOutList, TRUE); //Запускаем!
   end;
  end;
end;

end.

Но что-то не работает. Вылетает AV с обрашщением в никуда. Подскажите что я не так делаю?

[Аватар]

1. Критическую секцию по идее нужно создать одну в основном потоке, а в дочерних потоках к ней обращаться перед и после записи в StringList
2. BeginUpdate - зачем вынесена так далеко? Если и использовать, то перед и после записи в StringList или вообще не нужно, разве крит.секция не защищает в этот момент StringList?
3. Слабо верится что несколько потоков существенно скорость повысят, особенно если логические диски на одном носителе
4. А если вместо крит.секции сообщения посылать форме и в них заполнять StringList. Должно прокатить

[Человек_Борща]

Сообщение от Аватар

1. Критическую секцию по идее нужно создать одну в основном потоке, а в дочерних потоках к ней обращаться перед и после записи в StringList

Окей, допусти в основном модуле обьявить глоб. переменной.
Но тут проблема, SearchUnit использует MainUnit и на оборот.
Создавать третий модуль, ради одной переменной?

Сообщение от Аватар

2. BeginUpdate - зачем вынесена так далеко? Если и использовать, то перед и после записи в StringList или вообще не нужно, разве крит.секция не защищает в этот момент StringList?

Учёл=)

Сообщение от Аватар

3. Слабо верится что несколько потоков существенно скорость повысят, особенно если логические диски на одном носителе

Ну да, против лома нет приема. Читающая головка у hdd только одна .

Я пака не понимаю почему так будет быстрее, но думаю что будет быстрее.

Но думаю что система построит работу так:
1 поток ищет 1 файл на c
2 поток ищет 1 файл на d
3 поток ищет 1 файл на e
4 поток ищет 1 файл на f

1 поток ищет 2 файл на c
2 поток ищет 2 файл на d
3 поток ищет 2 файл на e
4 поток ищет 2 файл на f

1 поток ищет n файл на c
2 поток ищет n файл на d
3 поток ищет n файл на e
4 поток ищет n файл на f

Но это предположение...

Сообщение от Аватар

4. А если вместо крит.секции сообщения посылать форме и в них заполнять StringList. Должно прокатить

SendMessage? т.е. предложение выстроить цепочку сообщений к StringList?.

Можно пример , как посылать текст и откуда его читать(Из какого параметра TMessage)?

[Аватар]

Окей, допусти в основном модуле обьявить глоб. переменной.
Но тут проблема, SearchUnit использует MainUnit и на оборот.
Создавать третий модуль, ради одной переменной?

Весь смысл КС, чтобы с помощью одной и той же КС в разных процессах блокировать некие действия. Ну создали в потоке свою КС, каким она образом повлияет на другой поток, если там другая КС?

Если ничего не напутал:

//передать строку
var: p: Pointer;
     i: Integer;
     s: String;
'''
  s:='Бла-бла';
  i:=Length(s);
  GetMem(p,i+1);  
  FillMemory(p,i+1,0);
  Move(s[1],p^,i);
//Integer(p) засунуть как параметр при передаче сообщения 
...
//принять строку
var c: PChar;
    adr: Integer;
    s: String;
...
//  adr - здесь принятый параметр
  c:=Pointer(adr);
  s:=c;  //принятая строка
  FreeMem(c);  //освободили память

Если надумаете в качестве StringList использовать нечто типа Memo.Lines то КС не поможет, синхронизировать прийдется

[Человек_Борща]

Ну тогда откажусь от многопоточности. т.к. быстрее искать всеравно не будет.