paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-18 19:39:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: Fix result of TWSClassesList.Search Issue #37360 Note 0124690 Patch by BrunoK

Browse Source 
git-svn-id: trunk@63707 -
This commit is contained in:
martin 2020-08-09 13:56:39 +00:00
parent 74886381ea
commit 53e492ccd2
1 changed files with 39 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
lcl/widgetset/wslclclasses.pp
View File

@ -21,7 +21,7 @@ unit WSLCLClasses;
{off$DEFINE VerboseWSRegistration} {off$DEFINE VerboseWSRegistration}
{off$DEFINE VerboseWSRegistration_methods} {off$DEFINE VerboseWSRegistration_methods}
{off$DEFINE VerboseWSRegistration_treedump} {off$DEFINE VerboseWSRegistration_treedump}
{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK } {.$DEFINE VerboseWSBrunoK }
interface interface
//////////////////////////////////////////////////// ////////////////////////////////////////////////////
@ -137,16 +137,20 @@ type
TWSClassesList = class(TFPList) TWSClassesList = class(TFPList)
private private
FLastFoundIdx: integer; FLastFoundIdx: integer;
FLastFoundLCLClass: TComponentClass; FLastFoundClass: TClass;
function FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass; function FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
function Get(Index: integer): PClassNode; inline; function Get(Index: integer): PClassNode; inline;
procedure Insert(aIndex: Integer; aItem: Pointer);
function Search(const aItem: TClass; Out Index: integer): boolean; function Search(const aItem: TClass; Out Index: integer): boolean;
procedure UpdatLastFound(aClass: TClass; aIndex: integer);
property Items[Index: integer]: PClassNode read Get; { write Put; default; } property Items[Index: integer]: PClassNode read Get; { write Put; default; }
{$IFDEF VerboseWSBrunoK} {$ENDIF} {$IFDEF VerboseWSBrunoK} {$ENDIF}
{$IFDEF VerboseWSBrunoK} {$IFDEF VerboseWSBrunoK}
procedure DumpNode(aN : integer; aPClassNode : PClassNode); procedure DumpNode(aN : integer; aPClassNode : PClassNode);
procedure DumpNodes; procedure DumpNodes;
{$ENDIF} {$ENDIF}
public
constructor Create;
end; end;
var var
@ -409,7 +413,6 @@ function GetPClassNode(AClass: TClass; AWSComponent: TWSLCLComponentClass;
aParentGet: boolean; aLeaf: boolean): PClassNode; aParentGet: boolean; aLeaf: boolean): PClassNode;
var var
idx: Integer; idx: Integer;
OldCount: integer;
lParentNode : PClassNode; lParentNode : PClassNode;
lClassNode : TClassNode; { A temp local node to fake normal processing lClassNode : TClassNode; { A temp local node to fake normal processing
of a node that won't be stored aParentGet = 0 of a node that won't be stored aParentGet = 0
@ -497,7 +500,6 @@ procedure RegisterWSComponent(AComponent: TComponentClass;
var var
Node: PClassNode; Node: PClassNode;
OldPrivate: TClass; OldPrivate: TClass;
idx: Integer;
begin begin
if not Assigned(WSClassesList) then if not Assigned(WSClassesList) then
DoInitialization; DoInitialization;
@ -577,9 +579,9 @@ end;
{ TWSClassesList } { TWSClassesList }
function TWSClassesList.Get(Index: integer): PClassNode; constructor TWSClassesList.Create;
begin begin
Result := PClassNode(inherited Get(Index)); FLastFoundClass:=TClass(High(UIntPtr));
end; end;
function TWSClassesList.FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass; function TWSClassesList.FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
@ -595,43 +597,54 @@ begin
Result := nil; Result := nil;
end; end;
function TWSClassesList.Get(Index: integer): PClassNode;
begin
Result := PClassNode(inherited Get(Index));
end;
procedure TWSClassesList.Insert(aIndex: Integer; aItem: Pointer);
begin
inherited Insert(aIndex, aItem);
UpdatLastFound(TClass(aItem), aIndex);
end;
{ Searches a match for AComponent.ClassType. Returns index in items of { Searches a match for AComponent.ClassType. Returns index in items of
the matching AComponent or the next bigger one } the matching AComponent or the next bigger one }
function TWSClassesList.Search(const aItem: TClass; out Index: integer): boolean; function TWSClassesList.Search(const aItem: TClass; out Index: integer): boolean;
const
cIndex: integer = 0;
var var
L, R: integer; L, R: integer;
lLCLClass: TClass; lLCLClass: TClass;
lPClassNode: PClassNode;
begin begin
if aItem = FLastFoundClass then begin
Index := FLastFoundIdx;
Exit(True);
end;
L := 0; L := 0;
R := Count - 1; R := Count - 1;
// Use binary search. // Use binary search.
if R >= 0 then begin while (L <= R) do begin
if Pointer(aItem) = Pointer(FLastFoundLCLClass) then begin Index := L + ((R - L) div 2);
Index := FLastFoundIdx; lLCLClass := PClassNode(List^[Index])^.LCLClass;
Exit(True); if Pointer(aItem) < Pointer(lLCLClass) then
end; R := Index - 1
while (L <= R) do begin else begin
Index := L + ((R - L) div 2); if aItem = lLCLClass then begin
lLCLClass := PClassNode(List^[Index])^.LCLClass; UpdatLastFound(lLCLClass, Index);
if Pointer(aItem) < Pointer(lLCLClass) then Exit(True);
R := Index - 1
else begin
if aItem = lLCLClass then begin
FLastFoundIdx := Index;
FLastFoundLCLClass := TComponentClass(lLCLClass);
Exit(True);
end;
L := Index + 1;
end; end;
L := Index + 1;
end; end;
end; end;
Index := L; Index := L;
Result := False; Result := False;
end; end;
procedure TWSClassesList.UpdatLastFound(aClass: TClass; aIndex: integer);
begin
FLastFoundClass := TComponentClass(aClass);
FLastFoundIdx := aIndex;
end;
{$IFDEF VerboseWSBrunoK} {$IFDEF VerboseWSBrunoK}
procedure TWSClassesList.DumpNode(aN: integer; aPClassNode: PClassNode); procedure TWSClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
var var