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

components/lazutils/fileutil.inc

@@ -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;
 

components/lazutils/fileutil.pas

@@ -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;