15 мая 2023 года "Исходники.РУ" отмечают своё 23-летие!
Поздравляем всех причастных и неравнодушных с этим событием!
И огромное спасибо всем, кто был и остаётся с нами все эти годы!

Главная Форум Журнал Wiki DRKB Discuz!ML Помощь проекту


TFileFinder - механизм поиска файлов.

Автор: TADEX

История:

Было дело, надо было создать компонент, котрый производит поиск файлов. Он был создан и в периодически дополнялся новыми возможностями. Вот и получился компонент с огромными возможностями. Единственное "но" - он был опробован только на Delphi 5 + WinNT 4.0 SP6. Но !должен! без проблем работать и в других средах....

Краткие характеристики:
Компонент позволет производить поиск как на локальных дисках так и в локаольной сети.

Компонент использует многопотоковость.
- Для сканирования локальных дисков используется отдельный поток, что позволяет продолжать выполнение программы.
- Для сканирования удаленных компьютеров используется по одному потоку на каждый компьютер. То есть одновременно позволяет сканировать хоть все компьтеры сети.

Это усовершенствование должно заметно если не сказать "КОНКРЕТНО" повышает скорость сканирования.

Фильтрование файлов. Гарантируется, что один и тот же файл не будет дважды и более возвращен. Это может случиться при поиске файлов по нескольким маскам (Например поиск ведется по маскам [some*.*] и [*.txt] в этом случае файл somebody.txt попадает в две котегории)

Компонент ведет статистику:

- Кол-во найденых файлов.
- Кол-во просканированых директорий.
- Время проведенное в сканировании файлов (паузы исключаются).
- Время начала и конца сканирования.

Описание.

Имя: TCustomFileFinder.

procedure DoFindFile(var FileInfo: TFileInfo); virtual; protected;

Вызывает OnFindFile. Может быть отменена в производных классах.

 

procedure DoScanDir(const Dir: string); virtual; protected;
   Вызывает OnScanDirectory. Может быть отменена в производных классах.

property Dirs: TStrings; protected;
   Содержит список директорий в которых будет производиться посик.

Понимает следующие выражения:

[Drive:][\][Dir[\]] - Поиск в каталоге на локальном диске

\\ - Поиск во всех ресурсах каждого компьютера в сети
\\[Computer][\] - Поиск во всех ресурсах определенного компьютера в сети
\\[Computer][\Share][\] - Поиск в данном ресурсе определенного компьютера в сети

Комментарий: Список используется только при ScanDirs равном sdOther.

Замечание: Если указываются подкаталоги то при в включеной рекурсии они игнорируются.

Пример: Указан поиск в

c:\temp

\\
\\server <== (*)
d:\win95
d:\win95\temp <== (*)

Каталоги (*) будут игнориорваться т.к. [\\server] входит в множество [\\], а [d:\win95\temp] входит в [d:\win95]

property ScanDirs: TScanDirs; protected;
   Указывает, где будет производиться поиск.

sdOther - каталоги указаны в перменной Dirs
sdCurrentDir - В текущей директории
sdCurrentDrive - На текущем диске (диск откуда запускалась программа,

но не где находится исполняемый файл)

sdFixedDrives - Только на жестких дисках (исключаются дискеты, CDROM, сетевые диски и т.п.)
sdAllDrives - На всех дисках которые присутсвеют в системе
sdAllNetwork - По всем ресурсам сети (исключаются локальные ресурсы)

property Wildcards: TStrings; protected;
   Содержит список масок по которым будет производиться поиск файлов.

Например: Поиск всех файлов с расширением WAV и MP3:

*.wav
*.mp3

property Recurse: Boolean; protected;
   Если True, то поиск также будет производиться в поддиректориях.

property Attributes: TFileAttributes; protected;
   Указываются атрибуты искомых файлов.

Например:

[faArchive, faReadOnly] - будут найдены файлы у которых нет установленных атрибутов и файлы у которых установлены аттрибуты faArchive или faReadOnly или оба вместе.

property MaxThreads: Cardinal; protected;

Указывает максимальное количество одновременно работающих потоков. 0 - нет ограничений.

Комментарий: Используется при поиске в локальной сети. Оптимальное значение не найдено. Но при малом значениии снижается скорость поиска, а при большом наблюдается большая загрузка ресурсов компьютера. Для поиска на локальных дисках используется один поток, т. к. использование нескольких потоков сколь нибудь заметного прироста производительности не дадут.

property OnFindFile(Sender: TObject; var FileInfo: TFileInfo); protected; event;
   Вызывается если файл отвечающий условиям поиска найден.

Информация о файле содержиться в структуре FileInfo;

Время обработки этого события старайтесь сделать как можно меньше, т. к. поиск файлов вызывающий поток возобонвит только после возврата из из события.

property OnScanDirectory(Sender: TObject; const Dir: string); protected; event;
   Вызывается перед поиском файлов в директории Dir.

   Не вижу сколь нибудь пользы от этого обработчика, кроме информационной. Можно пользователю показать, где в данные момент производиться поиск.

 

property OnEndScan(Sender: TObject; Terminated: Boolean); protected; event;
   Вызывается после того как все потоки завершили свою работу.

procedure Start(Wait: Boolean = False); public;
   Собственно дает команду начать поиск.

Если Wait = True, то процедура вернет управление только когда полностью закончиться поиск. Иначе функция сразу вернет управление. Если уже идет поиск, то выбрасывается исклчение.

procedure Terminate; public;
   Прерывавает поиск. Если поиск не происходит, то выбрасывается исклчение.

function Scaning: Boolean; public;
   Если возвращает True, то компонент осуществляет поиск.

property Pause: Boolean; public;
   Присваивание этому свойству True, приостанавливает поиск.

Присваивание этому свойству False, возобновляет поиск.

Статистика:

property Stat_DateTimeBegin: TDateTime; public; - время начала поиска (*)
property Stat_DateTimeEnd: TDateTime; public; - время окончания поиска (**)
property Stat_ScaningTime: TDateTime; public; - время сканирования (**)
property Stat_ScanedFiles: Integer; public; - количество найденных файлов
property Stat_ScanedDirs: Integer; public; - количество просмотренных директорий

(*) статистическая переменная доступны после начала поиска
(**) статистические переменные доступны после окончания поиска

Пожалуйста, все вопросы и предложения присылать по почте e-mail: tadex@yahoo.com

}

unit FileFinder;

interface

uses
Windows, SysUtils, Classes;

type
EFileFinderError = class(Exception);

TFileAttribute = (faArchive, faReadOnly, faHidden, faSystem, faCompressed, faOffline, faTemporary);
TFileAttributes = set of TFileAttribute;
TScanDirs = (sdOther, sdCurrentDir, sdCurrentDrive, sdFixedDrives, sdAllDrives, sdAllNetwork);

PFileInfo = ^TFileInfo;
TFileInfo = record
FileName: string;
FileSize: Longword;
Attributes: TFileAttributes;
CreationTime: TDateTime;
ModifyTime: TDateTime;
LastAccessTime: TDateTime;
end;

TFindFileEvent = procedure(Sender: TObject; var FileInfo: TFileInfo) of object;
TScanDirEvent = procedure(Sender: TObject; const Dir: string) of object;
TEndScanEvent = procedure(Sender: TObject; Terminated: Boolean) of object;
TCustomFileFinder = class(TComponent)
private
FThrManager: Pointer;
FScanDirs: TScanDirs;
FDirs: TStrings;
FWildcards: TStrings;
FRecurse: Boolean;
FAttributes: TFileAttributes;
FMaxThreads: Cardinal;
FOnFindFile: TFindFileEvent;
FOnScanDir: TScanDirEvent;
FOnEndScan: TEndScanEvent;

FStat_BeginTime: TDateTime;
FStat_EndTime: TDateTime;
FStat_IncTime: TDateTime;
FStat_BegScan: TDateTime;
FStat_NumFiles: Integer;
FStat_NumDirs: Integer;

function GetPause: Boolean;
procedure SetPause(Value: Boolean);
procedure SetDirs(Value: TStrings);
procedure SetScanDirs(Value: TScanDirs);
procedure SetWildcards(Value: TStrings);
procedure SetRecurse(Value: Boolean);
procedure SetAttributes(Value: TFileAttributes);
procedure SetMaxThreads(Value: Cardinal);
procedure FindFileCB(var FileInfo: TFileInfo);
procedure ScanDirCB(const Dir: string);
procedure TMTerminated;
function GetStat_DateTimeBegin: TDateTime;
function GetStat_DateTimeEnd: TDateTime;
function GetStat_ScaningTime: TDateTime;
protected
procedure DoFindFile(var FileInfo: TFileInfo); virtual;
procedure DoScanDir(const Dir: string); virtual;

property Dirs: TStrings read FDirs write SetDirs;
property ScanDirs: TScanDirs read FScanDirs write SetScanDirs;
property Wildcards: TStrings read FWildcards write SetWildcards;
property Recurse: Boolean read FRecurse write SetRecurse default TRUE;
property Attributes: TFileAttributes read FAttributes write SetAttributes;
property MaxThreads: Cardinal read FMaxThreads write SetMaxThreads;
property OnFindFile: TFindFileEvent read FOnFindFile write FOnFindFile;
property OnScanDirectory: TScanDirEvent read FOnScanDir write FOnScanDir;
property OnEndScan: TEndScanEvent read FOnEndScan write FOnEndScan;
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
procedure Start(Wait: Boolean = False);
procedure Terminate;
function Scaning: Boolean;
property Pause: Boolean read GetPause write SetPause;

property Stat_DateTimeBegin: TDateTime read GetStat_DateTimeBegin;
property Stat_DateTimeEnd: TDateTime read GetStat_DateTimeEnd;
property Stat_ScaningTime: TDateTime read GetStat_ScaningTime;
property Stat_ScanedFiles: Integer read FStat_NumFiles;
property Stat_ScanedDirs: Integer read FStat_NumDirs;
end;

TFileFinder = class(TCustomFileFinder)
published
property Dirs;
property ScanDirs;
property Wildcards;
property Recurse;
property Attributes;
property MaxThreads;
property OnFindFile;
property OnScanDirectory;
property OnEndScan;
end;

procedure Register;

implementation

type
PQueueRecord = ^TQueueRecord;
TQueueRecord = record
Dir: string;
Thread: Pointer;
end;

TThreadManager = class
private
FWildcards: array of string;
FTerminated: Boolean;
FFF: TCustomFileFinder;
ThreadList: TThreadList;
TermEvent: THandle;
FQueue: TThreadList;
constructor Create(AFF: TCustomFileFinder);
destructor Destroy; override;
function GetDir(Sender: TObject): string;
procedure AddDir(const Dir: string);
procedure ExamineAndStart;
procedure Terminate;
procedure Suspend;
procedure Resume;
procedure WaitForAll;
function GetSuspended: Boolean;
procedure FFTTerminated(Sender: TObject);
end;

TFileFinderThread = class(TThread)
private
ThrManager: TThreadManager;
FilesInfo: array of TFileInfo;
Bounds: array of Integer;
FilesCount: Integer;
CurFileInfo: PFileInfo;
CurrentDir: string;
ProcFileName: string;
ProcFileAttr: Cardinal;
NetRes: TNetResource;
ServerProc: string;

procedure EnumNetRes(Ptr: PNetResource);
function PartNetworkPath(const Dir: string): Boolean;
function TestFile(var ft: TFileAttributes): Boolean;
procedure WildcardProc(const Wildcard: string);
procedure DirProc(const Dir: string);
function SubSearch(Low, High: Integer): Boolean;
function SearchFile: Boolean;
procedure IncFilesCount;
procedure SafeCallFind;
procedure SafeCallNotify;
protected
procedure DoTerminate; override;
procedure Execute; override;
public
constructor Create(ATM: TThreadManager);
end;

resourcestring
NamePalette = 'Tadex''s Components';
ScaningProcessError = 'Scaning in progress. Can not change this parameter.';
ProcThreadError = 'Scaning don''t started';
BeginScaningError = 'Scaning already in progress.';
StatNotCollected = 'This statistic information isn''t collected yet';

//============================================================================

function DrivePath(Letter: char): string;
begin
Result := Letter + ':\';
end;

function MakePath(const Path, FileName: string): string;
begin
if Path[Length(Path)] = '\' then Result := Concat(Path, FileName)
else Result := Concat(Path, '\', FileName);
end;

function ExtractServerName(const UNCPath: string): string;
var
DelimPos: Integer;
begin
Result := '.';
if (UNCPath[1] <> '\') or (UNCPath[2] <> '\') then Exit;
Result := Copy(UNCPath, 3, Length(UNCPath) - 2);
DelimPos := Pos('\', Result);
if DelimPos > 0 then Result := Copy(Result, 1, DelimPos - 1);
if Result = '' then Result := '*';
end;

function ExpandPath(const Path: string): string;
var
Dir, Drive, Name: string;
i, Count: Integer;
Dirs: array [0..127] of string;
Buffer: array [0..MAX_PATH - 1] of Char;
FName: PChar;
FD: WIN32_FIND_DATA;
HDir: THandle;
NxtFile: Boolean;
begin
Result := '';
SetString(Dir, Buffer, GetFullPathName(PChar(Path), SizeOf(Buffer), Buffer, FName));
Drive := ExtractFileDrive(Dir);
Count := 0;
for i := Low(Dirs) to High(Dirs) do begin
if (Length(Dir) = 3) or (Length(Dir) = Length(Drive)) then Break;
Name := ExtractFileName(Dir);
Dir := ExtractFileDir(Dir);
if Name <> '' then begin
Dirs[Count] := Name;
Inc(Count);
end;
end;
if Count > 0 then
Dir := Drive;
Name := UpperCase(Dir);
for i := Count - 1 downto 0 do begin
Dir := Concat(Dir, '\', Dirs[i]);
HDir := FindFirstFile(PChar(Dir), FD);
if HDir = INVALID_HANDLE_VALUE then Exit;
try
NxtFile := FindNextFile(HDir, FD);
finally
Windows.FindClose(HDir);
end;
if NxtFile then Exit;
if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then Exit;
Name := Concat(Name, '\', FD.cFileName);
end;
Result := Name;
end;

function FT2DT(FileTime: TFileTime): TDateTime;
var
LocalFileTime: TFileTime;
Tmp: Int64;
begin
FileTimeToLocalFileTime(FileTime, LocalFileTime);
with Int64Rec(Tmp), LocalFileTime do begin
Hi := dwHighDateTime;
Lo := dwLowDateTime;
end;
Result := (Tmp - 94353120000000000) / 8.64e11;
end;

function LowBound(Arr: array of Integer; Index: Integer): Integer;
begin
if Index = 0 then Result := 0
else Result := Arr[Index - 1];
end;

//============================================================================

constructor TFileFinderThread.Create(ATM: TThreadManager);
begin
inherited Create(True);
FreeOnTerminate := True;
ThrManager := ATM;
SetLength(Bounds, Length(ThrManager.FWildcards));
SetLength(FilesInfo, 8);
ServerProc := '';
with NetRes do begin
dwScope := RESOURCE_GLOBALNET;
dwType := RESOURCETYPE_DISK;
dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
dwUsage := RESOURCEUSAGE_CONTAINER;
lpLocalName := '';
lpComment := '';
lpProvider := '';
end;
end;

procedure TFileFinderThread.SafeCallFind;
begin
ThrManager.FFF.FindFileCB(CurFileInfo^);
end;

procedure TFileFinderThread.SafeCallNotify;
begin
ThrManager.FFF.ScanDirCB(CurrentDir);
end;

function TFileFinderThread.SubSearch(Low, High: Integer): Boolean;
var
Tmp: Integer;
begin
Tmp := High - Low;
if Tmp <= 0 then Result := False
else if Tmp = 1 then Result := FilesInfo[Low].FileName = ProcFileName
else begin
Tmp := Low + Tmp div 2;
if FilesInfo[Tmp].FileName <= ProcFileName then Result := SubSearch(Tmp, High)
else Result := SubSearch(Low, Tmp);
end;
end;

function TFileFinderThread.SearchFile: Boolean;
var
i: Integer;
begin
Result := True;
for i := 0 to High(Bounds) do
if SubSearch(LowBound(Bounds, i), Bounds[i]) then Exit;
Result := False;
end;

function TFileFinderThread.TestFile(var FT: TFileAttributes): Boolean;
begin
Result := False;
FT := [];
if ProcFileAttr and FILE_ATTRIBUTE_DIRECTORY <> 0 then Exit;
if ProcFileAttr and FILE_ATTRIBUTE_ARCHIVE <> 0 then Include(FT, faArchive);
if ProcFileAttr and FILE_ATTRIBUTE_READONLY <> 0 then Include(FT, faReadOnly);
if ProcFileAttr and FILE_ATTRIBUTE_HIDDEN <> 0 then Include(FT, faHidden);
if ProcFileAttr and FILE_ATTRIBUTE_SYSTEM <> 0 then Include(FT, faSystem);
if ProcFileAttr and FILE_ATTRIBUTE_COMPRESSED <> 0 then Include(FT, faCompressed);
if ProcFileAttr and FILE_ATTRIBUTE_TEMPORARY <> 0 then Include(FT, faTemporary);
if ProcFileAttr and FILE_ATTRIBUTE_OFFLINE <> 0 then Include(FT, faOffline);
Result := ((FT * ThrManager.FFF.FAttributes <> []) or (FT = [])) and not SearchFile;
end;

procedure TFileFinderThread.IncFilesCount;
begin
Inc(FilesCount);
if FilesCount >= Length(FilesInfo) then
SetLength(FilesInfo, Length(FilesInfo) * 3 div 2);
end;

procedure TFileFinderThread.WildcardProc(const Wildcard: string);
var
FD: WIN32_FIND_DATA;
Files: THandle;
Attr: TFileAttributes;
begin
if Terminated then Exit;
Files := FindFirstFile(PChar(Wildcard), FD);
if Files <> INVALID_HANDLE_VALUE then
try
repeat
ProcFileName := FD.cFileName;
ProcFileAttr := FD.dwFileAttributes;
if TestFile(Attr) then
with FilesInfo[FilesCount], FD do begin
FileName := ProcFileName;
FileSize := nFileSizeLow;
Attributes := Attr;
CreationTime := FT2DT(ftCreationTime);
ModifyTime := FT2DT(ftLastWriteTime);
LastAccessTime := FT2DT(ftLastAccessTime);
IncFilesCount;
end
until Terminated or not FindNextFile(Files, FD)
finally
Windows.FindClose(Files);
end
end;

procedure TFileFinderThread.EnumNetRes(Ptr: PNetResource);
type
PNetResArray = ^TNetResArray;
TNetResArray = array[0..MaxInt div sizeof(TNetResource) - 1] of TNetResource;
var
I, BufSize, NetResult: Integer;
Count, Size: LongWord;
NetHandle: THandle;
NetResources: PNetResArray;
begin
if Terminated then Exit;
if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, Ptr, NetHandle) <> NO_ERROR then Exit;
NetResources := nil;
try
BufSize := 10 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
repeat
Count := $FFFFFFFF; Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
if NetResult <> ERROR_MORE_DATA then Break;
BufSize := Size;
ReallocMem(NetResources, BufSize);
until False;
if NetResult = NO_ERROR then
for I := 0 to Count - 1 do
with NetResources^[I] do
if dwDisplayType in [RESOURCEDISPLAYTYPE_SHARE, RESOURCEDISPLAYTYPE_SERVER] then
ThrManager.AddDir(lpRemoteName)
else if (dwUsage and RESOURCEUSAGE_CONTAINER) = RESOURCEUSAGE_CONTAINER then
EnumNetRes(@NetResources^[I]);
finally
if NetResources <> nil then FreeMem(NetResources);
WNetCloseEnum(NetHandle);
end;
end;

function TFileFinderThread.PartNetworkPath(const Dir: string): Boolean;
begin
Result := False;
if (Length(Dir) < 2) or (Dir[1] <> '\') or (Dir[2] <> '\') then Exit;
if (Length(Dir) > 2) and (LastDelimiter('\', Dir) > 2) then Exit;
if Length(Dir) = 2 then
EnumNetRes(nil)
else begin
NetRes.lpRemoteName := PChar(Dir);
EnumNetRes(@NetRes);
end;
Result := True;
end;

procedure TFileFinderThread.DirProc(const Dir: string);
var
FD: WIN32_FIND_DATA;
Dirs: THandle;
i: Integer;
begin
if Terminated then Exit;
CurrentDir := Dir;
Synchronize(SafeCallNotify);
if PartNetworkPath(Dir) then Exit;
FilesCount := 0;
for i := 0 to High(Bounds) do
Bounds[i] := -1;
for i := 0 to High(ThrManager.FWildcards) do begin
WildcardProc(MakePath(Dir, ThrManager.FWildcards[i]));
Bounds[i] := FilesCount;
end;
for i := 0 to FilesCount - 1 do begin
if Terminated then Exit;
CurFileInfo := @FilesInfo[i];
with CurFileInfo^ do begin
FileName := MakePath(Dir, FileName);
Synchronize(SafeCallFind);
FileName := '';
end;
end;
if ThrManager.FFF.FRecurse and not Terminated then begin
Dirs := FindFirstFile(PChar(MakePath(Dir, '*.*')), FD);
if Dirs <> INVALID_HANDLE_VALUE then
try
repeat
with FD do
if ((dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) and
(cFileName <> string('.')) and (cFileName <> string('..')) then
DirProc(MakePath(Dir, cFileName));
until Terminated or not FindNextFile(Dirs, FD);
finally
Windows.FindClose(Dirs);
end
end
end;

procedure TFileFinderThread.Execute;
var
Dir: string;
begin
repeat
Dir := ThrManager.GetDir(Self);
if Dir = '' then Break;
DirProc(Dir);
until Terminated;
end;

procedure TFileFinderThread.DoTerminate;
begin
ThrManager.FFTTerminated(Self);
end;

//============================================================================

constructor TThreadManager.Create(AFF: TCustomFileFinder);
var
i, j, Count: Integer;
ch: Char;
Dirs: array of string;
begin
inherited Create;
FFF := AFF;
FTerminated := False;
FQueue := TThreadList.Create;
ThreadList := TThreadList.Create;
TermEvent := CreateEvent(nil, False, False, nil);
SetLength(FWildcards, FFF.Wildcards.Count);
Count := 0;
for i := 0 to High(FWildcards) do
if Trim(FFF.Wildcards.Strings[i]) <> '' then begin
FWildcards[Count] := FFF.Wildcards.Strings[i];
Inc(Count);
end;
SetLength(FWildcards, Count);
SetLength(Dirs, FFF.FDirs.Count);
for i := 0 to High(Dirs) do
Dirs[Count] := FFF.FDirs.Strings[i];
case FFF.FScanDirs of
sdOther:
begin
for i := 0 to High(Dirs) do
Dirs[i] := ExpandPath(Dirs[i]);
for i := 0 to High(Dirs) do
for j := 0 to High(Dirs) do
if (i <> j) and (Dirs[i] <> '') and (Dirs[j] <> '') then
if FFF.FRecurse then begin
if Pos(Dirs[j], Dirs[i]) > 0 then Dirs[i] := '';
end else begin
if Dirs[i] = Dirs[j] then Dirs[i] := '';
end;
for i := 0 to High(Dirs) do
if Dirs[i] <> '' then
AddDir(Dirs[i]);
end;
sdCurrentDir:
AddDir(GetCurrentDir);
sdCurrentDrive:
AddDir(DrivePath(GetCurrentDir[1]));
sdAllNetwork:
AddDir('\\');
else
for ch := 'A' to 'Z' do
case GetDriveType(PChar(DrivePath(ch))) of
DRIVE_REMOVABLE, DRIVE_REMOTE, DRIVE_CDROM:
if FFF.FScanDirs = sdAllDrives then
AddDir(DrivePath(ch));
DRIVE_FIXED:
if FFF.FScanDirs in [sdAllDrives, sdFixedDrives] then
AddDir(DrivePath(ch));
end;
end;
end;

destructor TThreadManager.Destroy;
begin
Terminate;
WaitForAll;
CloseHandle(TermEvent);
ThreadList.Free;
FQueue.Free;
inherited Destroy;
end;

procedure TThreadManager.Terminate;
var
List: TList;
i: Integer;
begin
FTerminated := True;
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
with TFileFinderThread(List.Items[i]) do begin
Suspended := False;
Terminate;
end;
ThreadList.UnlockList;
end;

procedure TThreadManager.Suspend;
var
List: TList;
i: Integer;
begin
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
TFileFinderThread(List.Items[i]).Suspended := True;
ThreadList.UnlockList;
end;

procedure TThreadManager.Resume;
var
List: TList;
i: Integer;
begin
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
TFileFinderThread(List.Items[i]).Suspended := False;
ThreadList.UnlockList;
end;

procedure TThreadManager.WaitForAll;
var
Msg: TMsg;
H: THandle;
begin
H := TermEvent;
if GetCurrentThreadID = MainThreadID then
while MsgWaitForMultipleObjects(1, H, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
else WaitForSingleObject(H, INFINITE);
end;

procedure TThreadManager.FFTTerminated(Sender: TObject);
var
List: TList;
Termination: Boolean;
begin
ThreadList.Remove(Sender);
ExamineAndStart;
List := ThreadList.LockList;
Termination := List.Count = 0;
ThreadList.UnlockList;
if Termination then begin
SetEvent(TermEvent);
FFF.TMTerminated;
end;
end;

function TThreadManager.GetSuspended: Boolean;
var
List: TList;
i: Integer;
begin
Result := False;
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
Result := Result or TFileFinderThread(List.Items[i]).Suspended;
ThreadList.UnlockList;
end;

function TThreadManager.GetDir(Sender: TObject): string;
var
List: TList;
i: Integer;
ServerProc: string;
begin
Result := '';
List := FQueue.LockList;
for i := 0 to List.Count - 1 do
with PQueueRecord(List.Items[i])^ do
if Thread = Sender then begin
Result := Dir;
Dispose(List.Items[i]);
List.Delete(i);
Break;
end;
if Result = '' then begin
ServerProc := '';
for i := 0 to List.Count - 1 do
with PQueueRecord(List.Items[i])^ do
if Thread = nil then begin
ServerProc := ExtractServerName(Dir);
Result := Dir;
Dispose(List.Items[i]);
List.Delete(i);
Break;
end;
if ServerProc <> '' then begin
if Sender is TFileFinderThread then
TFileFinderThread(Sender).ServerProc := ServerProc;
for i := 0 to List.Count - 1 do
with PQueueRecord(List.Items[i])^ do
if ExtractServerName(Dir) = ServerProc then Thread := Sender;
end;
end;
FQueue.UnlockList;
end;

procedure TThreadManager.AddDir(const Dir: string);
var
i: Integer;
List: TList;
QRec: PQueueRecord;
Caller: TFileFinderThread;
ServerProc: string;
begin
ServerProc := ExtractServerName(Dir);
Caller := nil;
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
if TFileFinderThread(List.Items[i]).ServerProc = ServerProc then begin
Caller := TFileFinderThread(List.Items[i]);
Break;
end;
ThreadList.UnlockList;
New(QRec);
QRec.Dir := Dir;
QRec.Thread := Caller;
FQueue.Add(QRec);
ExamineAndStart;
end;

procedure TThreadManager.ExamineAndStart;
var
Threads, Queue: TList;
i: Integer;
NewThread: TFileFinderThread;
ServerProc: string;
begin
if FTerminated then Exit;
Threads := ThreadList.LockList;
Queue := FQueue.LockList;
repeat
ServerProc := '';
if (FFF.FMaxThreads = 0) or (Cardinal(Threads.Count) < FFF.FMaxThreads) then begin
for i := 0 to Queue.Count - 1 do
with PQueueRecord(Queue.Items[i])^ do
if Thread = nil then begin
ServerProc := ExtractServerName(Dir);
Break;
end;
if ServerProc <> '' then begin
NewThread := TFileFinderThread.Create(Self);
Threads.Add(NewThread);
NewThread.ServerProc := ServerProc;
for i := 0 to Queue.Count - 1 do
with PQueueRecord(Queue.Items[i])^ do
if ExtractServerName(Dir) = ServerProc then Thread := NewThread;
NewThread.Resume;
end;
end;
until ServerProc = '';
FQueue.UnlockList;
ThreadList.UnlockList;
end;

//============================================================================

constructor TCustomFileFinder.Create(Owner: TComponent);
begin
inherited Create(Owner);
FDirs := TStringList.Create;
FWildcards := TStringList.Create;
FAttributes := [faArchive, faReadOnly];
FRecurse := True;
FScanDirs := sdFixedDrives;
FMaxThreads := 10;
FThrManager := nil;
FWildcards.Add('*.*');
FStat_BeginTime := 0;
FStat_EndTime := 0;
FStat_IncTime := 0;
FStat_NumFiles := 0;
FStat_NumDirs := 0;
end;

destructor TCustomFileFinder.Destroy;
begin
if Assigned(FThrManager) then
TThreadManager(FThrManager).Free;
FDirs.Free;
FWildcards.Free;
inherited Destroy;
end;

procedure TCustomFileFinder.FindFileCB(var FileInfo: TFileInfo);
begin
Inc(FStat_NumFiles);
DoFindFile(FileInfo);
end;

procedure TCustomFileFinder.ScanDirCB(const Dir: string);
begin
Inc(FStat_NumDirs);
DoScanDir(Dir);
end;

procedure TCustomFileFinder.DoFindFile(var FileInfo: TFileInfo);
begin
if Assigned(FOnFindFile) then FOnFindFile(self, FileInfo);
end;

procedure TCustomFileFinder.DoScanDir(const Dir: string);
begin
if Assigned(FOnScanDir) then FOnScanDir(self, Dir);
end;

function TCustomFileFinder.Scaning: Boolean;
begin
Result := Assigned(FThrManager);
end;

procedure TCustomFileFinder.SetDirs(Value: TStrings);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FDirs.Assign(Value);
FScanDirs := sdOther;
end;

procedure TCustomFileFinder.SetWildcards(Value: TStrings);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FWildcards.Assign(Value);
end;

procedure TCustomFileFinder.SetScanDirs(Value: TScanDirs);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FScanDirs := Value;
end;

procedure TCustomFileFinder.SetRecurse(Value: Boolean);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FRecurse := Value;
end;

procedure TCustomFileFinder.SetAttributes(Value: TFileAttributes);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FAttributes := Value;
end;

procedure TCustomFileFinder.SetMaxThreads(Value: Cardinal);
begin
FMaxThreads := Value;
end;

procedure TCustomFileFinder.Terminate;
begin
if not Assigned(FThrManager) then
raise EFileFinderError.Create(ProcThreadError);
TThreadManager(FThrManager).Terminate;
end;

function TCustomFileFinder.GetPause: Boolean;
begin
if not Assigned(FThrManager) then
raise EFileFinderError.Create(ProcThreadError);
Result := TThreadManager(FThrManager).GetSuspended;
end;

procedure TCustomFileFinder.SetPause(Value: Boolean);
var
Suspended: Boolean;
begin
if not Assigned(FThrManager) then
raise EFileFinderError.Create(ProcThreadError);
Suspended := TThreadManager(FThrManager).GetSuspended;
if not Suspended and Value then begin
TThreadManager(FThrManager).Suspend;
FStat_IncTime := FStat_IncTime + (Now - FStat_BegScan);
end;
if Suspended and not Value then begin
FStat_BegScan := Now;
TThreadManager(FThrManager).Resume;
end;
end;

procedure TCustomFileFinder.Start(Wait: Boolean);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(BeginScaningError);
FStat_BeginTime := Now;
FStat_BegScan := FStat_BeginTime;
FStat_IncTime := 0;
FStat_NumFiles := 0;
FStat_NumDirs := 0;
FThrManager := TThreadManager.Create(Self);
if Wait then TThreadManager(FThrManager).WaitForAll;
end;

procedure TCustomFileFinder.TMTerminated;
var
Tmp: Boolean;
begin
Tmp := TThreadManager(FThrManager).FTerminated;
FreeAndNil(FThrManager);
FStat_EndTime := Now;
FStat_IncTime := FStat_IncTime + (FStat_EndTime - FStat_BegScan);
if Assigned(FOnEndScan) then FOnEndScan(self, Tmp);
end;

function TCustomFileFinder.GetStat_DateTimeBegin: TDateTime;
begin
if FStat_BeginTime = 0 then
raise EFileFinderError.Create(StatNotCollected);
Result := FStat_BeginTime;
end;

function TCustomFileFinder.GetStat_DateTimeEnd: TDateTime;
begin
if (FStat_EndTime = 0) or Assigned(FThrManager) then
raise EFileFinderError.Create(StatNotCollected);
Result := FStat_EndTime;
end;

function TCustomFileFinder.GetStat_ScaningTime: TDateTime;
begin
Result := FStat_IncTime;
if Assigned(FThrManager) and not TThreadManager(FThrManager).GetSuspended then
Result := Result + (Now - FStat_BegScan);
end;

procedure Register;
begin
RegisterComponents(NamePalette, [TFileFinder]);
end;

end.