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

LCL: Simplify NewInstance, search for WsClass. Issue #37360 Note 0124494

Browse Source 
git-svn-id: trunk@63688 -
This commit is contained in:
martin 2020-08-04 11:20:03 +00:00
parent 17af06e4e4
commit dff5dd0577
1 changed files with 12 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
lcl/lclclasses.pp
View File

@ -90,10 +90,6 @@ implementation
uses uses
InterfaceBase; InterfaceBase;
const
cWSRegisterOffset : integer = 0; // Offset of WSRegisterClass in class virtual methods
cLCLComponentWSReg : CodePointer = nil; // Adress of TLCLComponent.WSRegisterClass
type type
TLCLComponentClass = class of TLCLComponent; TLCLComponentClass = class of TLCLComponent;
@ -113,32 +109,16 @@ begin
Registered := True; Registered := True;
end; end;
procedure UpdateOffset;
var
lWSRegisterProc : CodePointer;
lPPtrArray : PPointerArray;
I : integer;
begin
cLCLComponentWSReg := @TLCLComponent.WSRegisterClass;
lPPtrArray := Pointer(TLCLComponent);
I := 0;
while lPPtrArray^[i]<>cLCLComponentWSReg do
inc(i);
cWSRegisterOffset := I * SizeOf(Pointer);
end;
{ This method allows descendents to override the FWidgetSetClass, handles { This method allows descendents to override the FWidgetSetClass, handles
registration of the component in WSLVLClasses list of components. It is only registration of the component in WSLVLClasses list of components. It is only
called if there wasn't a direct or parent hit at the beginining of NewInstance. } called if there wasn't a direct or parent hit at the beginining of NewInstance. }
class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass; class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass;
var const
lPSelfWSReg, DoneTLCLComponent: Boolean = False;
lPSelfParentWSReg : CodePointer;
lClassParent : TLCLComponentClass;
begin begin
if cWSRegisterOffset = 0 then begin if not DoneTLCLComponent then begin
UpdateOffset;
TLCLComponent.WSRegisterClass; { Always create the top node ! } TLCLComponent.WSRegisterClass; { Always create the top node ! }
DoneTLCLComponent := True;
end; end;
WSRegisterClass; WSRegisterClass;
@ -146,27 +126,9 @@ begin
if Result <> nil then if Result <> nil then
Exit; Exit;
lClassParent := TLCLComponentClass(ClassParent); { Force creation of intermediate nodes for Self and a leaf node for Self }
lPSelfWSReg := PCodePointer(Pointer(Self) + cWSRegisterOffset)^; RegisterNewWSComp(Self);
lPSelfParentWSReg := PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^; Result := FindWSRegistered(Self);
{ Self.ComponentClass didn't register itself but the parent should now be registered }
repeat
if lPSelfWSReg = lPSelfParentWSReg then begin
Result := FindWSRegistered(TComponentClass(lClassParent));
if Assigned(Result) then
Break
else
{ Force creation of intermediate nodes for parent }
RegisterNewWSComp(TComponentClass(lClassParent));
end
else begin
{ Force creation of intermediate nodes for Self and a leaf node for Self }
RegisterNewWSComp(Self);
Result := FindWSRegistered(Self);
Break;
end;
until False;
end; end;
{$IFDEF DebugLCLComponents} {$IFDEF DebugLCLComponents}
@ -196,32 +158,14 @@ begin
end; end;
class function TLCLComponent.NewInstance: TObject; class function TLCLComponent.NewInstance: TObject;
var
lWidgetSetClass: TWSLCLComponentClass;
lClassParent : TLCLComponentClass;
begin begin
Result := inherited NewInstance; Result := inherited NewInstance;
{ Test if directly inherits WSRegisterClass from its parent } { Look if already registered. If true set FWidgetSetClass and exit }
lClassParent := TLCLComponentClass(ClassParent); TLCLComponent(Result).FWidgetSetClass := FindWSRegistered(Self);
if (PCodePointer(Pointer(Self) + cWSRegisterOffset)^ if Assigned(TLCLComponent(Result).FWidgetSetClass) then begin
= PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^) {$IFDEF VerboseWSBrunoK} inc(cWSLCLDirectHit); {$ENDIF}
then begin Exit;
{ Retrieve WidgetSetClass from Parent }
lWidgetSetClass := FindWSRegistered(lClassParent);
if Assigned(lWidgetSetClass) then begin
TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
Exit;
end;
end
else begin
{ Look if already registered. If true set FWidgetSetClass and exit }
lWidgetSetClass := FindWSRegistered(Self);
if Assigned(lWidgetSetClass) then begin
TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
{$IFDEF VerboseWSBrunoK} inc(cWSLCLDirectHit); {$ENDIF}
Exit;
end;
end; end;
{ WSRegisterClass and manage WSLVLClasses list } { WSRegisterClass and manage WSLVLClasses list }