lcl/shellctrls: Add a custom compare function for sorting the nodes in the ShellTreeView while collecting the files/dirs.

lcl/shellctrls.pas

@@ -41,7 +41,7 @@ type
 
   TObjectTypes = set of TObjectType;
 
-  TFileSortType = (fstNone, fstAlphabet, fstFoldersFirst);
+  TFileSortType = (fstNone, fstAlphabet, fstFoldersFirst, fstCustom);
 
   TMaskCaseSensitivity = (mcsPlatformDefault, mcsCaseInsensitive, mcsCaseSensitive);
 
@@ -56,6 +56,22 @@ type
   TCustomShellTreeView = class;
   TCustomShellListView = class;
 
+  { TFileItem }
+
+  TFileItem = class(TObject)
+  private
+    FFileInfo: TSearchRec;
+    FBasePath: String;
+  public
+    //more data to sort by size, date... etc
+    isFolder: Boolean;
+    constructor Create(const DirInfo: TSearchRec; ABasePath: String);
+    property BasePath: String read FBasePath;
+    property FileInfo: TSearchRec read FFileInfo write FFileInfo;
+  end;
+
+  TFileItemCompareEvent = function(Item1, Item2: TFileItem): integer of object;
+
   { TCustomShellTreeView }
 
   TAddItemEvent = procedure(Sender: TObject; const ABasePath: String;
@@ -71,10 +87,12 @@ type
     FInitialRoot: String;
     FUseBuiltinIcons: Boolean;
     FOnAddItem: TAddItemEvent;
+    FOnSortCompare: TFileItemCompareEvent;
     { Setters and getters }
     function GetPath: string;
     procedure SetFileSortType(const AValue: TFileSortType);
     procedure SetObjectTypes(AValue: TObjectTypes);
+    procedure SetOnSortCompare(AValue: TFileItemCompareEvent);
     procedure SetPath(AValue: string);
     procedure SetRoot(const AValue: string);
     procedure SetShellListView(const Value: TCustomShellListView);
@@ -116,6 +134,7 @@ type
     property Root: string read FRoot write SetRoot;
     property Path: string read GetPath write SetPath;
     property OnAddItem: TAddItemEvent read FOnAddItem write FOnAddItem;
+    property OnSortCompare: TFileItemCompareEvent read FOnSortCompare write SetOnSortCompare;
     { Protected properties which users may want to access, see bug 15374 }
     property Items;
   end;
@@ -202,6 +221,7 @@ type
     property OnMouseWheelRight;
     property OnSelectionChanged;
     property OnShowHint;
+    property OnSortCompare;
     property OnUTF8KeyPress;
     property Options;
     property TreeLineColor;
@@ -416,20 +436,12 @@ begin
   Result := MaskCaseSensitivityStrings[CS];
 end;
 
-{ TFileItem : internal helper class used for temporarily storing info in an internal TStrings component}
+operator = (const A, B: TMethod): Boolean;
-type
+begin
-  { TFileItem }
+  Result := (A.Code = B.Code) and (A.Data = B.Data);
-  TFileItem = class(TObject)
+end;
-  private
-    FFileInfo: TSearchRec;
-    FBasePath: String;
-  public
-    //more data to sort by size, date... etc
-    isFolder: Boolean;
-    constructor Create(const DirInfo: TSearchRec; ABasePath: String);
-    property FileInfo: TSearchRec read FFileInfo write FFileInfo;
-  end;
 
+{ TFileItem : internal helper class used for temporarily storing info in an internal TStrings component}
 
 constructor TFileItem.Create(const DirInfo:TSearchRec; ABasePath: String);
 begin
@@ -439,6 +451,32 @@ begin
 end;
 
 
+{ TFileItemAVLTree
+
+  Specialized TAVLTree descendant for sorting the TFileItems found by the
+  helper function GetFilesInDir such that a user-friendly compare function
+  can be applied. }
+
+type
+  TFileItemAVLTree = class(TAVLTree)
+  private
+    FFileItemCompare: TFileItemCompareEvent;
+    function InternalFileItemCompare(ATree: TAvlTree; Item1, Item2: Pointer): Integer;
+  public
+    constructor CreateFileItemCompare(ACompare: TFileItemCompareEvent);
+  end;
+
+constructor TFileItemAVLTree.CreateFileItemCompare(ACompare: TFileItemCompareEvent);
+begin
+  FFileItemCompare := ACompare;
+  inherited CreateObjectCompare(@InternalFileItemCompare);
+end;
+
+function TFileItemAVLTree.InternalFileItemCompare(ATree: TAvlTree; Item1, Item2: Pointer): Integer;
+begin
+  Result := FFileItemCompare(TFileItem(Item1), TFileItem(Item2));
+end;
+
 { TShellTreeNode }
 
 procedure TShellTreeNode.SetBasePath(ABasePath: String);
@@ -613,7 +651,7 @@ begin
     BeginUpdate;
     Refresh(nil);
     try
-       SetPath(CurrPath);
+      SetPath(CurrPath);
     except
       // CurrPath may have been removed in the mean time by another process, just ignore
       on E: EInvalidPath do ;//
@@ -623,6 +661,42 @@ begin
   end;
 end;
 
+procedure TCustomShellTreeView.SetOnSortCompare(AValue: TFileItemCompareEvent);
+var
+  RootNode: TTreeNode;
+  CurrPath: String;
+begin
+  if TMethod(AValue) = TMethod(FOnSortCompare) then
+    Exit;
+
+  FOnSortCompare := AValue;
+
+  if (([csLoading,csDesigning] * ComponentState) <> []) or (FFileSortType <> fstCustom) then
+    Exit;
+
+  CurrPath := GetPath;
+  try
+    BeginUpdate;
+    Items.Clear;
+    if FRoot = '' then
+      PopulateWithBaseFiles()
+    else
+    begin
+      RootNode := Items.AddChild(nil, FRoot);
+      RootNode.HasChildren := True;
+      RootNode.Expand(False);
+      try
+       SetPath(CurrPath);
+      except
+        // CurrPath may have been removed in the mean time by another process, just ignore
+        on E: EInvalidPath do ;//
+      end;
+    end;
+  finally
+    EndUpdate;
+  end;
+end;
+
 function TCustomShellTreeView.CanExpand(Node: TTreeNode): Boolean;
 var
   OldAutoExpand: Boolean;
@@ -718,7 +792,6 @@ begin
     if f1.isFolder then Result:=-1
     else Result:=1;
   end;
-
 end;
 
 { Helper routine.
@@ -731,15 +804,17 @@ end;
 }
 procedure GetFilesInDir(const ABaseDir: string; AMask: string;
   AObjectTypes: TObjectTypes; AResult: TStrings; AFileSortType: TFileSortType;
-  ACaseSensitivity: TMaskCaseSensitivity = mcsPlatformDefault);
+  ACaseSensitivity: TMaskCaseSensitivity = mcsPlatformDefault;
+  ASortCompare: TFileItemCompareEvent = nil);
 var
   DirInfo: TSearchRec;
   FindResult, i: Integer;
   IsDirectory, IsValidDirectory, IsHidden, AddFile, UseMaskList, CaseSens: Boolean;
   SearchStr, ShortFilename: string;
   MaskList: TMaskList = nil;
-  Files: TList;
+  Files: TFileItemAVLTree;
   FileItem: TFileItem;
+  avlNode: TAVLTreeNode;
   {$if defined(windows) and not defined(wince)}
   ErrMode : LongWord;
   {$endif}
@@ -755,7 +830,7 @@ begin
       Delete(AMask, Length(AMask), 1);
     if Trim(AMask) = '' then
       AMask := AllFilesMask;
-    //Use a TMaksList if more than 1 mask is specified or if MaskCaseSensitivity differs from the platform default behaviour
+    //Use a TMaskList if more than 1 mask is specified or if MaskCaseSensitivity differs from the platform default behaviour
     UseMaskList := (Pos(';', AMask) > 0) or
                    {$ifdef NotLiteralFilenames}
                    (ACaseSensitivity = mcsCaseSensitive)
@@ -778,10 +853,16 @@ begin
     end;
 
     try
-      if AFileSortType = fstNone then
+      Files := nil;
-        Files:=nil
+      case AFileSortType of
-      else
+        fstAlphabet:
-        Files := TList.Create;
+          Files := TFileItemAVLTree.Create(@FilesSortAlphabet);
+        fstFoldersFirst:
+          Files := TFileItemAVLTree.Create(@FilesSortFoldersFirst);
+        fstCustom:
+          if ASortCompare <> nil then
+            Files := TFileItemAVLTree.CreateFileItemCompare(ASortCompare);
+      end;
 
       i := 0;
       if UseMaskList then
@@ -837,16 +918,14 @@ begin
 
     if Assigned(Files) then
     begin
-      case AFileSortType of
+      avlNode := Files.FindLowest;
-        fstAlphabet:     Files.Sort(@FilesSortAlphabet);
+      while Assigned(avlNode) do
-        fstFoldersFirst: Files.Sort(@FilesSortFoldersFirst);
+      begin
+        FileItem := TFileItem(avlNode.Data);
+        AResult.AddObject(FileItem.FileInfo.Name, FileItem);
+        avlNode := Files.FindSuccessor(avlNode);
       end;
 
-      for i:=0 to Files.Count-1 do
-      begin
-        FileItem:=TFileItem(Files[i]);
-        AResult.AddObject(FileItem.FileInfo.Name, FileItem);
-      end;
       //don't free the TFileItems here, they will freed by the calling routine
       Files.Free;
     end;
@@ -949,7 +1028,7 @@ begin
   Items.BeginUpdate;
   try
     Files.OwnsObjects := True;
-    GetFilesInDir(ANodePath, AllFilesMask, FObjectTypes, Files, FFileSortType);
+    GetFilesInDir(ANodePath, AllFilesMask, FObjectTypes, Files, FFileSortType, mcsPlatformDefault, FOnSortCompare);
     Result := Files.Count > 0;
 
     for i := 0 to Files.Count - 1 do