Fix for Mantis #23899 . Allow to overwrite TStringList.ExchangeItems if necessary.

rtl/objpas/classes/classesh.inc, TStringList:
  * rename the private ExchangeItems to ExchangeItemsInt and allow inlining
  + add a protected virtual ExchangeItems
rtl/objpas/classes/stringl.inc, TStringList:
  * Exchange: call ExchangeItemsInt
  + let default implementation of ExchangeItems simply call ExchangeItemsInt
  * QuickSort: call ExchangeItemsInt directly if there is no override otherwise call ExchangeItems

+ added test

git-svn-id: trunk@25480 -

.gitattributes

@@ -11988,6 +11988,7 @@ tests/test/units/character/tutf32convert.pp svneol=native#text/pascal
 tests/test/units/classes/tbytesstreamtest.pp svneol=native#text/pascal
 tests/test/units/classes/tmakeobjinst.pp svneol=native#text/plain
 tests/test/units/classes/tsetstream.pp svneol=native#text/plain
+tests/test/units/classes/tstringlistexchange.pp svneol=native#text/pascal
 tests/test/units/classes/tvclcomobject.pp svneol=native#text/plain
 tests/test/units/crt/tcrt.pp svneol=native#text/plain
 tests/test/units/crt/tctrlc.pp svneol=native#text/plain

rtl/objpas/classes/classesh.inc

@@ -728,13 +728,14 @@ type
     FSorted: Boolean;
     FForceSort : Boolean;
     FOwnsObjects : Boolean;
-    procedure ExchangeItems(Index1, Index2: Integer);
+    procedure ExchangeItemsInt(Index1, Index2: Integer); inline;
     procedure Grow;
     procedure InternalClear(FromIndex : Integer = 0; ClearOnly : Boolean = False);
     procedure QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
     procedure SetSorted(Value: Boolean);
     procedure SetCaseSensitive(b : boolean);
   protected
+    procedure ExchangeItems(Index1, Index2: Integer); virtual;
     procedure Changed; virtual;
     procedure Changing; virtual;
     function Get(Index: Integer): string; override;

rtl/objpas/classes/stringl.inc

@@ -933,7 +933,7 @@ end;
 
 {$if not defined(FPC_TESTGENERICS)}
 
-Procedure TStringList.ExchangeItems(Index1, Index2: Integer);
+Procedure TStringList.ExchangeItemsInt(Index1, Index2: Integer);
 
 Var P1,P2 : Pointer;
 
@@ -947,6 +947,11 @@ begin
 end;
 
 
+Procedure TStringList.ExchangeItems(Index1, Index2: Integer);
+begin
+  ExchangeItemsInt(Index1, Index2);
+end;
+
 
 Procedure TStringList.Grow;
 
@@ -991,11 +996,18 @@ end;
 Procedure TStringList.QuickSort(L, R: Integer; CompareFn: TStringListSortCompare);
 var
   Pivot, vL, vR: Integer;
+  ExchangeProc: procedure(Left, Right: Integer) of object;
 begin
+  //if ExchangeItems is override call that, else call (faster) ExchangeItemsInt
+  if TMethod(@Self.ExchangeItems).Code = Pointer(@TStringList.ExchangeItems) then
+    ExchangeProc := @ExchangeItemsInt
+  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
-        ExchangeItems(L, R);
+        ExchangeProc(L, R);
 
     Exit;
   end;
@@ -1012,7 +1024,7 @@ begin
     while (vR > Pivot) and (CompareFn(Self, vR, Pivot) > 0) do
       Dec(vR);
 
-    ExchangeItems(vL, vR);
+    ExchangeProc(vL, vR);
 
     if Pivot = vL then // swap pivot if we just hit it from one side
       Pivot := vR
@@ -1258,7 +1270,7 @@ begin
   If (Index2<0) or (Index2>=FCount) then
     Error(SListIndexError,Index2);
   Changing;
-  ExchangeItems(Index1,Index2);
+  ExchangeItemsInt(Index1,Index2);
   changed;
 end;
 

tests/test/units/classes/tstringlistexchange.pp

@@ -0,0 +1,78 @@
+program tstringlistexchange;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes;
+
+type
+  TMyStringList = class(TStringList)
+  protected
+    ExchangeCount: LongInt;
+    procedure ExchangeItems(aLeft, aRight: Integer); override;
+  end;
+  
+procedure TMyStringList.ExchangeItems(aLeft, aRight: Integer);
+begin
+  Inc(ExchangeCount);
+  inherited ExchangeItems(aLeft, aRight);
+end;
+
+procedure FillStringList(aList: TStrings);
+begin
+  aList.Add('Beta');
+  aList.Add('Gamma');
+  aList.Add('Alpha');
+  aList.Add('Delta');
+end;
+
+type
+  TDummy = class
+    ExchangeCount: LongInt;
+    procedure Change(aSender: TObject);
+  end;
+  
+procedure TDummy.Change(aSender: TObject);
+begin
+  Inc(ExchangeCount);
+end;
+
+var
+  sl: TStringList;
+  msl: TMyStringList;
+  dummy: TDummy;
+begin
+  dummy := TDummy.Create;
+  try
+    sl := TStringList.Create;
+    try
+      FillStringList(sl);
+      sl.OnChange := @dummy.Change;
+      sl.Sort;
+      // only OnChange call in TStringList.Sort
+      if dummy.ExchangeCount <> 1 then
+        Halt(1);
+    finally
+      sl.Free;
+    end;
+
+    dummy.ExchangeCount := 0;
+    
+    msl := TMyStringList.Create;
+    try
+      FillStringList(msl);
+      msl.OnChange := @dummy.Change;
+      msl.Sort;
+      // TMyStringList.ExchangeItems called 5 times
+      if msl.ExchangeCount <> 5 then
+        Halt(1);
+      // OnChange called once in Sort
+      if dummy.ExchangeCount <> 1 then
+        Halt(1);
+    finally
+      msl.Free;
+    end;
+  finally
+    dummy.Free;
+  end;
+end.