paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-07 16:38:02 +02:00
Code Issues Packages Projects Releases Wiki Activity

FileUtil: implement TFileSearcher.OnQueryFileFound and OnQueryDirectoryFound. Gives the user the possibility

Browse Source 
to reject files and/or directories. If rejected OnFileFound/OnDirectoryFound/OnDirectoryEnter will not be fired.
This commit is contained in:
Bart 2023-11-06 15:16:32 +01:00
parent 54e9cc9171
commit 9ec85e5d2a
2 changed files with 42 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
components/lazutils/fileutil.inc
View File

@ -767,6 +767,19 @@ begin
if Assigned(FOnFileFound) then OnFileFound(Self);
end;
procedure TFileSearcher.DoQueryFileFound(const Fn: String; var Accept: Boolean);
begin
if Assigned(FOnQueryFileFound) then
FOnQueryFileFound(Self, Fn, Accept);
end;
procedure TFileSearcher.DoQueryDirectoryFound(const Dir: String;
var Accept: Boolean);
begin
if Assigned(FOnQueryDirectoryFound) then
FOnQueryDirectoryFound(Self, Dir, Accept);
end;
constructor TFileSearcher.Create;
begin
inherited Create;
@ -785,12 +798,22 @@ var
SearchDirectories: TStringList;
procedure DoSearch(const APath: String; const ALevel: Integer);
function AcceptFile(const Fn: String): Boolean;
begin
Result := True;
DoQueryFileFound(Fn, Result);
end;
function AcceptDir(const Dir: String): Boolean;
begin
Result := True;
DoQueryDirectoryFound(Dir, Result);
end;
var
P: String;
PathInfo: TSearchRec;
begin
P := APath + AllDirectoryEntriesMask;
if FindFirstUTF8(P, FileAttribute, PathInfo) = 0 then
try
repeat
@ -800,7 +823,7 @@ var
// Deal with both files and directories
if (PathInfo.Attr and faDirectory) = 0 then
begin // File
if (MaskList = nil) or MaskList.Matches(PathInfo.Name) then
if ((MaskList = nil) or MaskList.Matches(PathInfo.Name)) and AcceptFile(PathInfo.Name) then
begin
FPath := APath;
FLevel := ALevel;
@ -809,10 +832,13 @@ var
end;
end
else begin // Directory
FPath := APath;
FLevel := ALevel;
FFileInfo := PathInfo;
DoDirectoryFound;
if AcceptDir(PathInfo.Name) then
begin
FPath := APath;
FLevel := ALevel;
FFileInfo := PathInfo;
DoDirectoryFound;
end;
end;
until (FindNextUTF8(PathInfo) <> 0) or not FSearching;
@ -827,7 +853,8 @@ var
repeat
if (PathInfo.Name = '.') or (PathInfo.Name = '..') or
(PathInfo.Name = '') or ((PathInfo.Attr and faDirectory) = 0) or
(not FFollowSymLink and FileIsSymlink(APath + PathInfo.Name))
(not FFollowSymLink and FileIsSymlink(APath + PathInfo.Name)) or
(not AcceptDir(PathInfo.Name))
then Continue;
FPath := APath;

8
components/lazutils/fileutil.pas
View File

@ -121,6 +121,8 @@ type
TFileFoundEvent = procedure (FileIterator: TFileIterator) of object;
TDirectoryFoundEvent = procedure (FileIterator: TFileIterator) of object;
TDirectoryEnterEvent = procedure (FileIterator: TFileIterator) of object;
TQueryFileFoundEvent = procedure (FileIterator: TFileIterator; const Fn: String; var Accept: Boolean) of object;
TQueryDirectoryFoundEvent = procedure (FileIterator: TFileIterator; const Dir: String; var Accept: Boolean) of object;
{ TFileSearcher }
@ -134,11 +136,15 @@ type
FOnDirectoryEnter: TDirectoryEnterEvent;
FFileAttribute: Word;
FDirectoryAttribute: Word;
FOnQueryFileFound: TQueryFileFoundEvent;
FOnQueryDirectoryFound: TQueryDirectoryFoundEvent;
procedure RaiseSearchingError;
protected
procedure DoDirectoryEnter; virtual;
procedure DoDirectoryFound; virtual;
procedure DoFileFound; virtual;
procedure DoQueryFileFound(const Fn: String; var Accept: Boolean);
procedure DoQueryDirectoryFound(const Dir: String; var Accept: Boolean);
public
constructor Create;
procedure Search(const ASearchPath: String; const ASearchMask: String = '';
@ -152,6 +158,8 @@ type
property OnDirectoryFound: TDirectoryFoundEvent read FOnDirectoryFound write FOnDirectoryFound;
property OnFileFound: TFileFoundEvent read FOnFileFound write FOnFileFound;
property OnDirectoryEnter: TDirectoryEnterEvent read FOnDirectoryEnter write FOnDirectoryEnter;
property OnQueryFileFound: TQueryFileFoundEvent read FOnQueryFileFound write FOnQueryFileFound;
property OnQueryDirectoryFound: TQueryDirectoryFoundEvent read FOnQueryDirectoryFound write FOnQueryDirectoryFound;
end;
{ TListFileSearcher }