LCL: use CompareValue for comparing MapIDs to prevent overflow (bug #8432)

git-svn-id: trunk@10703 -

.gitattributes

@@ -2894,6 +2894,7 @@ test/bugs/8284/expected.txt svneol=native#text/plain
 test/bugs/8284/unit1.lfm svneol=native#text/plain
 test/bugs/8284/unit1.lrs svneol=native#text/plain
 test/bugs/8284/unit1.pas svneol=native#text/plain
+test/bugs/bug8432.pas svneol=native#text/plain
 test/bugtestcase.pas svneol=native#text/plain
 test/hello.ahk svneol=native#text/plain
 test/readme.txt svneol=native#text/plain

lcl/fpcadds.pas

@@ -21,7 +21,7 @@
 }
 unit FPCAdds;
 
-{$mode objfpc}{$H+}
+{$mode objfpc}{$H+}{$inline on}
 {$IFDEF VER2_0_2}
 {$DEFINE FPC_HAS_NO_STRTOQWORD}
 {$ENDIF}
@@ -29,7 +29,7 @@ unit FPCAdds;
 interface
 
 uses
-  Classes, SysUtils
+  Classes, SysUtils, Math
 {$IFDEF FPC_HAS_NO_STRTOQWORD}
   ,sysconst
 {$ENDIF}
@@ -42,6 +42,7 @@ type
   TCompareMemSize = integer;
   PHandle = ^THandle;
 
+function CompareValue ( const A, B  : QWord) : TValueRelationship; inline;
 function StrToWord(const s: string): word;
 {$IFDEF FPC_HAS_NO_STRTOQWORD}
 function StrToQWord(const s: string): QWord;
@@ -61,6 +62,17 @@ begin
   end;
 end;
 
+function CompareValue ( const A, B  : QWord) : TValueRelationship;
+
+begin
+  result:=GreaterThanValue;
+  if a=b then
+    result:=EqualsValue
+  else
+   if a<b then
+     result:=LessThanValue;
+end;
+
 {$IFDEF FPC_HAS_NO_STRTOQWORD}
 function StrToQWord(const s: string): QWord;
 var Error: word;

lcl/maps.pp

@@ -30,7 +30,7 @@ unit maps;
 interface
 
 uses
-  Classes, SysUtils, AvgLvlTree;
+  Classes, SysUtils, Math, FPCAdds, AvgLvlTree;
   
 type
   TMapIdType = (itu1, its1, itu2, its2, itu4, its4, itu8, its8, itu16, its16,
@@ -412,41 +412,41 @@ var
   Item2: PMapItem absolute AItem2;
 begin
   case FIdType of
-    itu1: Result := Item1^.ID.U1 - Item2^.ID.U1;
+    itu1: Result := CompareValue(Item1^.ID.U1, Item2^.ID.U1);
-    its1: Result := Item1^.ID.S1 - Item2^.ID.S1;
+    its1: Result := CompareValue(Item1^.ID.S1, Item2^.ID.S1);
-    itu2: Result := Item1^.ID.U2 - Item2^.ID.U2;
+    itu2: Result := CompareValue(Item1^.ID.U2, Item2^.ID.U2);
-    its2: Result := Item1^.ID.S2 - Item2^.ID.S2;
+    its2: Result := CompareValue(Item1^.ID.S2, Item2^.ID.S2);
-    itu4: Result := Item1^.ID.U4 - Item2^.ID.U4;
+    itu4: Result := CompareValue(Item1^.ID.U4, Item2^.ID.U4);
-    its4: Result := Item1^.ID.S4 - Item2^.ID.S4;
+    its4: Result := CompareValue(Item1^.ID.S4, Item2^.ID.S4);
-    itu8: Result := Item1^.ID.U8 - Item2^.ID.U8;
+    itu8: Result := CompareValue(Item1^.ID.U8, Item2^.ID.U8);
-    its8: Result := Item1^.ID.S8 - Item2^.ID.S8;
+    its8: Result := CompareValue(Item1^.ID.S8, Item2^.ID.S8);
     itu16: begin
-      Result := Item1^.ID.U16H - Item2^.ID.U16H;
+      Result := CompareValue(Item1^.ID.U16H, Item2^.ID.U16H);
       if Result = 0
-      then Result := Item1^.ID.U16L - Item2^.ID.U16L;
+      then Result := CompareValue(Item1^.ID.U16L, Item2^.ID.U16L);
     end;
     its16: begin
-      Result := Item1^.ID.S16H - Item2^.ID.S16H;
+      Result := CompareValue(Item1^.ID.S16H, Item2^.ID.S16H);
       if Result = 0
-      then Result := Item1^.ID.S16L - Item2^.ID.S16L;
+      then Result := CompareValue(Item1^.ID.S16L, Item2^.ID.S16L);
     end;
     itu32: begin
-      Result := Item1^.ID.U32HH - Item2^.ID.U32HH;
+      Result := CompareValue(Item1^.ID.U32HH,Item2^.ID.U32HH);
       if Result = 0
-      then Result := Item1^.ID.U32HL - Item2^.ID.U32HL;
+      then Result := CompareValue(Item1^.ID.U32HL, Item2^.ID.U32HL);
       if Result = 0
-      then Result := Item1^.ID.U32LH - Item2^.ID.U32LH;
+      then Result := CompareValue(Item1^.ID.U32LH, Item2^.ID.U32LH);
       if Result = 0
-      then Result := Item1^.ID.U32LL - Item2^.ID.U32LL;
+      then Result := CompareValue(Item1^.ID.U32LL, Item2^.ID.U32LL);
     end;
     its32: begin
-      Result := Item1^.ID.S32HH - Item2^.ID.S32HH;
+      Result := CompareValue(Item1^.ID.S32HH, Item2^.ID.S32HH);
       if Result = 0
-      then Result := Item1^.ID.S32HL - Item2^.ID.S32HL;
+      then Result := CompareValue(Item1^.ID.S32HL, Item2^.ID.S32HL);
       if Result = 0
-      then Result := Item1^.ID.S32LH - Item2^.ID.S32LH;
+      then Result := CompareValue(Item1^.ID.S32LH, Item2^.ID.S32LH);
       if Result = 0
-      then Result := Item1^.ID.S32LL - Item2^.ID.S32LL;
+      then Result := CompareValue(Item1^.ID.S32LL, Item2^.ID.S32LL);
     end;
   end;
 end;

test/bugs/bug8432.pas

@@ -0,0 +1,136 @@
+unit bug8432;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpcunit, testregistry, testglobals,
+  maps;
+
+type
+
+  { TTestBug8432 }
+
+  TTestBug8432= class(TTestCase)
+  private
+    FMap: TMap;
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure Test_itu4_1;
+    procedure Test_itu4_2;
+    procedure Test_itu8_1;
+    procedure Test_itu8_2;
+  end;
+
+implementation
+
+procedure TTestBug8432.SetUp;
+begin
+  inherited SetUp;
+end;
+
+procedure TTestBug8432.TearDown;
+begin
+  FMap.Free;
+  inherited TearDown;
+end;
+
+procedure TTestBug8432.Test_itu4_1;
+var
+  AInt: Integer;
+begin
+  FMap:=TMap.Create(itu4,SizeOf(Integer));
+  with FMap do
+  begin
+    AInt:=10;
+    Add(1,AInt);
+    AInt:=20;
+    Add(2,AInt);
+    AInt:=30;
+    Add(3,AInt);
+    GetData(1,AInt);
+    AssertEquals('Wrong entry for 1', 10, AInt);
+    GetData(2,AInt);
+    AssertEquals('Wrong entry for 2', 20, AInt);
+    GetData(3,AInt);
+    AssertEquals('Wrong entry for 3', 30, AInt);
+  end;
+end;
+
+procedure TTestBug8432.Test_itu4_2;
+var
+  i: integer;
+  AInt: Integer;
+  ID: DWord;
+begin
+  FMap:=TMap.Create(itu4,SizeOf(Integer));
+  with FMap do
+  begin
+    for i := 0 to 255 do begin
+      ID := i shl 24;
+      AInt:=i;
+      Add(ID,AInt);
+    end;
+    for i := 0 to 255 do begin
+      AInt:= 0;
+      ID := i shl 24;
+      GetData(ID,AInt);
+      AssertEquals('Wrong entry for '+ IntToStr(i), i, AInt);
+    end;
+  end;
+end;
+
+procedure TTestBug8432.Test_itu8_1;
+var
+  AInt: Integer;
+  ID1, ID2, ID3: QWord;
+begin
+  FMap:=TMap.Create(itu8,SizeOf(Integer));
+  with FMap do
+  begin
+    ID1 := 1; AInt:=10;
+    Add(ID1,AInt);
+    ID2 := 2; AInt:=20;
+    Add(ID2,AInt);
+    ID3 := 3; AInt:=30;
+    Add(ID3,AInt);
+    GetData(ID1,AInt);
+    AssertEquals('Wrong entry for 1', 10, AInt);
+    GetData(ID2,AInt);
+    AssertEquals('Wrong entry for 2', 20, AInt);
+    GetData(ID3,AInt);
+    AssertEquals('Wrong entry for 3', 30, AInt);
+  end;
+end;
+
+procedure TTestBug8432.Test_itu8_2;
+var
+  AInt: Integer;
+  ID1, ID2, ID3: QWord;
+begin
+  FMap:=TMap.Create(itu8,SizeOf(Integer));
+  with FMap do
+  begin
+    ID1 := 1 shl 32; AInt:=10;
+    Add(ID1, AInt);
+    AssertEquals('Wrong ID1', $100000000, ID1);
+    ID2 := 2 shl 32; AInt:=20;
+    Add(ID2, AInt);
+    ID3 := 3 shl 32; AInt:=30;
+    Add(ID3, AInt);
+    GetData(ID1,AInt);
+    AssertEquals('Wrong entry for 1', 10, AInt);
+    GetData(ID2,AInt);
+    AssertEquals('Wrong entry for 2', 20, AInt);
+    GetData(ID3,AInt);
+    AssertEquals('Wrong entry for 3', 30, AInt);
+  end;
+end;
+
+initialization
+  BugsTestSuite.AddTest(TTestSuite.Create(TTestBug8432, '8432'));
+end.
+

test/bugtestcase.pas

@@ -237,10 +237,7 @@ procedure GatherTests;
 var
   ProgPath: string;
   SearchRec: TSearchRec;
-  BugsTestSuite: TTestSuite;
 begin
-  BugsTestSuite := TTestSuite.Create('Bugs');
-  GetTestRegistry.AddTest(BugsTestSuite);
   ProgPath := ExtractFilePath(ParamStr(0)) + 'bugs' + pathdelim;
   if FindFirst(ProgPath+'*', faAnyFile, SearchRec)=0 then
     repeat

test/runtestsgui.lpi

@@ -46,21 +46,29 @@
       <Unit2>
         <Filename Value="testglobals.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="TestGlobals"/>
+        <UnitName Value="testglobals"/>
       </Unit2>
       <Unit3>
-        <Filename Value="testglobals.pas"/>
+        <Filename Value="bugs\bug8432.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="testglobals"/>
+        <UnitName Value="bug8432"/>
       </Unit3>
     </Units>
   </ProjectOptions>
   <CompilerOptions>
     <Version Value="5"/>
     <PathDelim Value="\"/>
+    <SearchPaths>
+      <OtherUnitFiles Value="bugs\"/>
+    </SearchPaths>
     <CodeGeneration>
       <Generate Value="Faster"/>
     </CodeGeneration>
+    <Linking>
+      <Debugging>
+        <UseHeaptrc Value="True"/>
+      </Debugging>
+    </Linking>
     <Other>
       <CompilerPath Value="$(CompPath)"/>
     </Other>

test/runtestsgui.lpr

@@ -23,7 +23,7 @@ program runtestsgui;
 uses
   Interfaces, Forms,
   GuiTestRunner,
-  TestLpi, BugTestCase;
+  TestLpi, BugTestCase, bug8432;
 
 begin
   Application.Title:='Run Lazarus tests';

test/testglobals.pas

@@ -22,10 +22,18 @@ unit testglobals;
 
 interface
 
+uses
+  fpcunit, testregistry;
+
 var
   Compiler: string;
+  BugsTestSuite: TTestSuite;
 
 implementation
 
+initialization
+  BugsTestSuite := TTestSuite.Create('Bugs');
+  GetTestRegistry.AddTest(BugsTestSuite);
+
 end.