paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-16 20:49:24 +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
InterfaceBase;
const
cWSRegisterOffset : integer = 0; // Offset of WSRegisterClass in class virtual methods
cLCLComponentWSReg : CodePointer = nil; // Adress of TLCLComponent.WSRegisterClass
type
TLCLComponentClass = class of TLCLComponent;
@ -113,32 +109,16 @@ begin
Registered := True;
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
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. }
class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass;
var
lPSelfWSReg,
lPSelfParentWSReg : CodePointer;
lClassParent : TLCLComponentClass;
const
DoneTLCLComponent: Boolean = False;
begin
if cWSRegisterOffset = 0 then begin
UpdateOffset;
if not DoneTLCLComponent then begin
TLCLComponent.WSRegisterClass; { Always create the top node ! }
DoneTLCLComponent := True;
end;
WSRegisterClass;
@ -146,27 +126,9 @@ begin
if Result <> nil then
Exit;
lClassParent := TLCLComponentClass(ClassParent);
lPSelfWSReg := PCodePointer(Pointer(Self) + cWSRegisterOffset)^;
lPSelfParentWSReg := PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^;
{ 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;
{ Force creation of intermediate nodes for Self and a leaf node for Self }
RegisterNewWSComp(Self);
Result := FindWSRegistered(Self);
end;
{$IFDEF DebugLCLComponents}
@ -196,32 +158,14 @@ begin
end;
class function TLCLComponent.NewInstance: TObject;
var
lWidgetSetClass: TWSLCLComponentClass;
lClassParent : TLCLComponentClass;
begin
Result := inherited NewInstance;
{ Test if directly inherits WSRegisterClass from its parent }
lClassParent := TLCLComponentClass(ClassParent);
if (PCodePointer(Pointer(Self) + cWSRegisterOffset)^
= PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^)
then begin
{ 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;
{ Look if already registered. If true set FWidgetSetClass and exit }
TLCLComponent(Result).FWidgetSetClass := FindWSRegistered(Self);
if Assigned(TLCLComponent(Result).FWidgetSetClass) then begin
{$IFDEF VerboseWSBrunoK} inc(cWSLCLDirectHit); {$ENDIF}
Exit;
end;
{ WSRegisterClass and manage WSLVLClasses list }