Hi, after a lot of testing, I think it is safe and I have submitted this
patch to the bugtracker
https://bugs.freepascal.org/view.php?id=34873
With this patch, it is possible to provide a custom compare function to
a stringlist and thus allow the stringlist to keep the items
automatically sorted according to the custom compare routine.
In addition, this custom compare function can also use fields of the
objects associated with the strings.
I would also be willing to update the documentation accordingly, but I
have no idea how to do that.
Franz
Index: rtl/objpas/classes/classesh.inc
===
--- rtl/objpas/classes/classesh.inc (revision 40862)
+++ rtl/objpas/classes/classesh.inc (working copy)
@@ -759,14 +759,18 @@
FOnChanging: TNotifyEvent;
FDuplicates: TDuplicates;
FCaseSensitive : Boolean;
-FForceSort : Boolean;
FOwnsObjects : Boolean;
FSortStyle: TStringsSortStyle;
+FObjectSort: boolean;
+FOnCompareItems: TStringListSortCompare; // user defined compare function
or nil, if standard
+FDoCompare: TStringListSortCompare; // compare function actually used
for sorting
procedure ExchangeItemsInt(Index1, Index2: Integer); inline;
function GetSorted: Boolean;
procedure Grow;
procedure InternalClear(FromIndex : Integer = 0; ClearOnly : Boolean =
False);
-procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
+procedure QuickSort(L, R: Integer);
+procedure SortIfNeeded;
+procedure SetOnCompareItems(const AValue: TStringListSortCompare);
procedure SetSorted(Value: Boolean);
procedure SetCaseSensitive(b : boolean);
procedure SetSortStyle(AValue: TStringsSortStyle);
@@ -791,10 +795,12 @@
public
destructor Destroy; override;
function Add(const S: string): Integer; override;
+function AddObject(const S: string; AObject: TObject): Integer; override;
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Exchange(Index1, Index2: Integer); override;
function Find(const S: string; Out Index: Integer): Boolean; virtual;
+function Find(const S: string; const O: TObject; Out Index: Integer):
Boolean; virtual;
function IndexOf(const S: string): Integer; override;
procedure Insert(Index: Integer; const S: string); override;
procedure Sort; virtual;
@@ -805,7 +811,9 @@
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
property OwnsObjects : boolean read FOwnsObjects write FOwnsObjects;
-Property SortStyle : TStringsSortStyle Read FSortStyle Write SetSortStyle;
+property SortStyle : TStringsSortStyle Read FSortStyle Write SetSortStyle;
+property ObjectSort : boolean read FObjectSort write FObjectSort;
+property OnCompareItems: TStringListSortCompare read FOnCompareItems write
SetOnCompareItems;
end;
{$else}
Index: rtl/objpas/classes/stringl.inc
===
--- rtl/objpas/classes/stringl.inc (revision 40862)
+++ rtl/objpas/classes/stringl.inc (working copy)
@@ -1230,9 +1230,10 @@
Pointer(Flist^[Index2].FObject):=P2;
end;
+
function TStringList.GetSorted: Boolean;
begin
- Result:=FSortStyle in [sslUser,sslAuto];
+ Result:=FSortStyle <> sslNone;
end;
@@ -1285,8 +1286,7 @@
SetCapacity(0);
end;
-procedure TStringList.QuickSort(L, R: Integer; CompareFn:
TStringListSortCompare
- );
+procedure TStringList.QuickSort(L, R: Integer);
var
Pivot, vL, vR: Integer;
ExchangeProc: procedure(Left, Right: Integer) of object;
@@ -1297,11 +1297,9 @@
else
ExchangeProc := @ExchangeItems;
- if R - L <= 1 then begin // a little bit of time saver
-if L < R then
- if CompareFn(Self, L, R) > 0 then
+ if R=L+1 then begin // a little bit of time saver
+ if FDoCompare(Self, L, R) > 0 then
ExchangeProc(L, R);
-
Exit;
end;
@@ -1311,12 +1309,15 @@
Pivot := L + Random(R - L); // they say random is best
while vL < vR do begin
-while (vL < Pivot) and (CompareFn(Self, vL, Pivot) <= 0) do
+while (vL < Pivot) and (FDoCompare(Self, vL, Pivot) <= 0) do
Inc(vL);
-while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do
+while (vR > Pivot) and (FDoCompare(Self, vR, Pivot) >= 0) do
Dec(vR);
+if vL=vR then
+ break;
+
ExchangeProc(vL, vR);
if Pivot = vL then // swap pivot if we just hit it from one side
@@ -1325,10 +1326,10 @@
Pivot := vL;
end;
- if Pivot - 1 >= L then
-QuickSort(L, Pivot - 1, CompareFn);
- if Pivot + 1 <= R then
-QuickSort(Pivot + 1, R, CompareFn);
+ if L < Pivot - 1 then
+QuickSort(L, Pivot - 1);
+ if Pivot + 1 < R then
+QuickSort(Pivot + 1, R);
end;
@@ -1437,6 +1438,8 @@
procedure TStringList.PutObject(Index:
