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

TFileSearcher: first try at detecting circular links (outside the current tree).

Browse Source
This commit is contained in:
Bart 2024-02-06 20:00:23 +01:00
parent de6b521614
commit 65e0930568
2 changed files with 49 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
components/lazutils/fileutil.inc
View File

@ -795,6 +795,7 @@ begin
FMaskSeparator := ';';
FPathSeparator := ';';
FFollowSymLink := True;
FCircularLinkDetection := False;
FFileAttribute := faAnyFile;
FDirectoryAttribute := faDirectory;
FSearching := False;
@ -819,7 +820,7 @@ var
end;
var
P: String;
P, FQDir, LinkTarget: String;
PathInfo: TSearchRec;
begin
P := APath + AllDirectoryEntriesMask;
@ -862,22 +863,49 @@ 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)) or
(FileIsSymlink(APath + PathInfo.Name) and
( //try to detect the simples case of a circular link
//is the link "up or down the current tree": infinite loop if we follow
FileIsInPath(ExpandFilenameUTF8(ReadAllLinks(APath+PathInfo.Name,False)),ExpandFilenameUTF8(APath)) or
FileIsInPath(ExpandFilenameUTF8(APath),ExpandFilenameUTF8(ReadAllLinks(APath+PathInfo.Name,False))))
) or
(not AcceptDir(AppendPathDelim(ExpandFilenameUtf8(APath + PathInfo.Name))))
then Continue;
then
Continue;
if Assigned(VisitedDirs) then
begin
FQDir := ExpandFilenameUTF8(APath + PathInfo.Name);
{$ifdef CaseInsensitiveFilenames}
FQDir := Utf8LowerCase(FQDir);
{$endif}
end;
// deal with symlinks separately, avoid excessive calls to ExpandFilenameUTF8 and
// have a less convoluted boolean expression above here
if (FileIsSymlink(APath + PathInfo.Name)) then
begin
if not FFollowSymlink then
Continue;
LinkTarget := ReadAllLinks(APath+PathInfo.Name,False);
if (LinkTarget = '') then //broken link
Continue;
LinkTarget := ExpandFilenameUTF8(LinkTarget);
{$ifdef CaseInsensitiveFilenames}
LinkTarget := Utf8LowerCase(LinkTarget);
{$endif}
if
//is the link "up or down the current tree": infinite loop if we follow
FileIsInPath(LinkTarget,ExpandFilenameUTF8(APath)) or
FileIsInPath(ExpandFilenameUTF8(APath),LinkTarget) or
//did we already visit that directory, assuming we actually do check for that
(Assigned(VisitedDirs) and Assigned(VisitedDirs.Find(LinkTarget)))
then
Continue;
if Assigned(VisitedDirs) then
FQDir := LinkTarget;
end;
FPath := APath;
FLevel := ALevel;
FFileInfo := PathInfo;
DoDirectoryEnter;
if not FSearching then Break;
if Assigned(VisitedDirs) then
VisitedDirs.Add(FQDir,'');
DoSearch(AppendPathDelim(APath + PathInfo.Name), Succ(ALevel));
until (FindNextUTF8(PathInfo) <> 0);
@ -893,6 +921,10 @@ var
OtherDir: String;
begin
if FSearching then RaiseSearchingError;
if FCircularLinkDetection and FFollowSymLink then
VisitedDirs := TFPStringHashTable.Create
else
VisitedDirs := nil;
{$ifdef windows}
MaskList := TWindowsMaskList.Create(ASearchMask, FMaskSeparator, CaseSensitive);
{$else}
@ -944,6 +976,8 @@ begin
SearchDirectories.Free;
FSearching := False;
MaskList.Free;
if Assigned(VisitedDirs) then
VisitedDirs.Free;
end;
end;

6
components/lazutils/fileutil.pas
View File

@ -29,7 +29,8 @@ interface
uses
Classes, SysUtils, StrUtils,
// LazUtils
Masks, LazUTF8, LazFileUtils;
Masks, LazUTF8, LazFileUtils,
Contnrs;
{$IF defined(Windows) or defined(darwin) or defined(HASAMIGA)}
{$define CaseInsensitiveFilenames}
@ -138,6 +139,8 @@ type
FDirectoryAttribute: Word;
FOnQueryFileFound: TQueryFileFoundEvent;
FOnQueryDirectoryFound: TQueryDirectoryFoundEvent;
FCircularLinkDetection: Boolean;
VisitedDirs: TFPStringHashTable;
procedure RaiseSearchingError;
protected
procedure DoDirectoryEnter; virtual;
@ -155,6 +158,7 @@ type
property FollowSymLink: Boolean read FFollowSymLink write FFollowSymLink;
property FileAttribute: Word read FFileAttribute write FFileAttribute default faAnyfile;
property DirectoryAttribute: Word read FDirectoryAttribute write FDirectoryAttribute default faDirectory;
property CircularLinkdetection: Boolean read FCircularLinkdetection write FCircularLinkdetection default False;
property OnDirectoryFound: TDirectoryFoundEvent read FOnDirectoryFound write FOnDirectoryFound;
property OnFileFound: TFileFoundEvent read FOnFileFound write FOnFileFound;
property OnDirectoryEnter: TDirectoryEnterEvent read FOnDirectoryEnter write FOnDirectoryEnter;