View Issue Details

IDProjectCategoryView StatusLast Update
0037407LazarusIDEpublic2020-07-26 18:20
ReporterErik Rößiger Assigned ToJuha Manninen  
PrioritynormalSeverityminorReproducibilityalways
Status resolvedResolutionfixed 
OSFedora 32 
Summary0037407: Patch of r63619 breaks Lazarus startup
DescriptionWhenever I try to start a clean compiled version of the Lazarus executable after r63619 I get an "Access Violation" error.
Using the StartLazarus executable works, though. I do not exactly know what differs them.
I do have a few packages installed, like AnchorDockingDsgn 1.0 that I can think of to maybe interfer with the patch of r63619.
My Lazarus is built with Qt5.
Steps To Reproduce- Check out any SVN revision between and including r63619 and r63628.
- Have Linux and a Qt5 build of Lazarus
TagsNo tags attached.
Fixed in Revisionr63636
LazTarget-
WidgetsetQT5
Attached Files

Relationships

related to 0037360 assignedMartin Friebe Proposed improvements for TLCLComponent.NewInstance 

Activities

Erik Rößiger

2020-07-22 23:49

reporter   ~0124243

Addendum:
Any LCL-using application I clean-compile with GTK2 or QT5 also crashes with this revision.

Cyrax

2020-07-23 01:55

reporter   ~0124247

Which FPC version you are using?

Juha Manninen

2020-07-23 08:18

developer   ~0124252

Last edited: 2020-07-23 08:22

View 2 revisions

It works here. I also use Linux and a Qt5 bindings.

> StartLazarus executable works
Do you mean that running ./lazarus directly crashes but through startlazarus it does not crash?
This sounds like some other problem.

Julian Puhl

2020-07-23 10:03

reporter   ~0124253

Last edited: 2020-07-23 10:06

View 2 revisions

I have a similar issue using Windows. I also use Anchordocking for Lazarus. Compiler is fpc trunk 64 bit. As soon as I try to open any project via double clicking I get an access violation message. If I revert the changes from the mentioned revision everything works. If I start Lazarus via startlazarus.exe with an empty project it works.

noname012

2020-07-23 10:32

reporter   ~0124255

I have also a similar issue when I install LazOpenGLContext component
on Windows 10 64-bit (lazarus trunk r63619 + fpc trunk r.45829).
The file openglcontext.pas has in the uses the unit "WSLCLClasses",
and lazarus trunk rev. 63619 has heavy changes in lcl/widgetset/wslclclasses.pp and lcl/lclclasses.pp.
If I install (lazarus trunk r63618 + fpc trunk r.45829) and install LazOpenGLContext component, everything works fine

BrunoK

2020-07-23 11:00

reporter   ~0124256

@Julian Puhl and others
> open any project via double clicking

I don't get that effect but do not use AnchorDockingDsgn 1.0 (I installed it but I didn't get troubles).

What are the exact messages ?

Is it possible to get a simple application showing the problem ?

May be one using openglcontext.pas ?

Julian Puhl

2020-07-23 11:23

reporter   ~0124257

Last edited: 2020-07-23 11:23

View 2 revisions

The dialog just says "Access violation". It is the default one which gets called when you have e.g. an uncaught exception. I have build debug Lazarus and after the access violation message I know get a heaptrc message, which I attached. It looks quite bad and might be related to the vft hack I read in the other bug report, but also could be a different memory issue.
lazmemerror.jpg (61,389 bytes)   
lazmemerror.jpg (61,389 bytes)   

BrunoK

2020-07-23 11:32

reporter   ~0124259

Looks like a case I hadn't foreseen. Will do some work on it today. Sorry for the trouble.

Do you all reporters use openglcontext ?

noname012

2020-07-23 11:40

reporter   ~0124260

Attached you find a simple application with openglcontext showing the problem.
test-opengl-win.zip (41,723 bytes)

BrunoK

2020-07-23 12:23

reporter   ~0124263

@noname012 2020-07-23 11:40

Would you be kind enough to try to apply openglcontext.pas.patch and test again.
openglcontext.pas.patch (1,204 bytes)   
Index: components/opengl/openglcontext.pas
===================================================================
--- components/opengl/openglcontext.pas	(revision 63573)
+++ components/opengl/openglcontext.pas	(working copy)
@@ -180,6 +180,7 @@
     procedure SetSharedControl(const AValue: TCustomOpenGLControl);
     function IsOpenGLRenderAllowed: boolean;
   protected
+    class procedure WSRegisterClass; override;
     procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
     procedure WMSize(var Message: TLMSize); message LM_SIZE;
     procedure UpdateFrameTimeDiff;
@@ -484,6 +485,17 @@
     (ocoRenderAtDesignTime in Options);
 end;
 
+class procedure TCustomOpenGLControl.WSRegisterClass;
+const
+  Registered : Boolean = False;
+begin
+  if Registered then
+    Exit;
+  inherited WSRegisterClass;
+  RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl);
+  Registered := True;
+end;
+
 procedure TCustomOpenGLControl.WMPaint(var Message: TLMPaint);
 begin
   Include(FControlState, csCustomPaint);
@@ -749,8 +761,9 @@
   Result := False;
   if AWinControl=nil then ;
 end;
-
+{~bk
 initialization
   RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl);
+}
 
 end.
openglcontext.pas.patch (1,204 bytes)   

noname012

2020-07-23 12:54

reporter   ~0124264

I applied the openglcontext.pas.patch and now IT WORKS.
Thanks

Martin Friebe

2020-07-23 13:03

manager   ~0124265

Last edited: 2020-07-23 13:14

View 5 revisions

Not very important, but in case its known:

Why does it break when RegisterWSComponent is in initialization?

The reason RegisterWSComponent is in NewInstance, is that if a unit has several components, initialization meant they could not be optimized out by the compiler (as they all where referenced)

But if a unit has only one component (not sure if the case here), then initialization is preferable. (the unit is only used, if the component is used)

--
What happens, if other (3rd Party) packages have code like this?
(Despite I think RegisterWSComponent was never designed to occur outside the LCL)

BrunoK

2020-07-23 13:54

reporter   ~0124267

> Why does it break when RegisterWSComponent is in initialization?
Because r63619 expects parents in the TLCLComponent class structure to be registered before its descendants.

> The reason RegisterWSComponent is in NewInstance, is that if a unit has several components, initialization meant they could > not be optimized out by the compiler (as they all where referenced)
I didn't see that to be the case if the unit having initialization is in fact never referenced by one of its TLCLComponent descendants (even -XX -CX compiled), but I may be wrong.

> What happens, if other (3rd Party) packages have code like this?
> (Despite I think RegisterWSComponent was never designed to occur outside the LCL)
Maybe I should add in WSLSLClasses a chack for the parents classes to have been WSRegisterClass'ed.

Erik Rößiger

2020-07-23 22:52

reporter   ~0124288

I have checked with the patch you posted and it indeed solves the issues I described.

Juha Manninen

2020-07-23 22:53

developer   ~0124289

I applied the patch for OpenGlContext in r63636. Thanks BrunoK.
I tested Lazarus with AnchorDockingDsgn but didn't get troubles either.
What could make the whole Lazarus crash? Strange.

Unit WSLCLClasses is used also in unit lcl/LazDeviceApis. I don't even know if that is used outside of Android.
Does the new optimization affect LazDeviceApis?

I understand BrunoK studied and debugged the component registration code a bit. Good work. I believe the remaining problems can be solved. We will need proper debugger backtraces from any crashes to solve them.

Martin Friebe

2020-07-23 22:54

manager   ~0124290

I must confess, I had not yet found the time to go through your entire patch. Especially what it does on top of the "if registered" do not call over and over again.

I have no opinion, if registering "out of order" (ie before parents) is something that needs to be kept (would have to see, if anyone else thinks it is important).

If it is not kept, there are 2 things however:
1) It must be noted as an incompatibility change in the release notes
2) Ideally it would raise an exception that gives some clue.
   Then, if any such code exists, it should be easy to figure out what is wrong.

Julian Puhl

2020-07-23 23:49

reporter   ~0124292

With this patch for me everything works. I had the OpenGL widget installed in Lazarus, maybe that caused it?

Juha Manninen

2020-07-25 21:59

developer   ~0124330

> 1) It must be noted as an incompatibility change in the release notes

I added a note in
 https://wiki.freepascal.org/Lazarus_2.2.0_release_notes#LCL_Interfaces_Changes

Resolving as fixed.

BrunoK

2020-07-26 18:20

reporter   ~0124343

With the LCLComponent_V2.patch, hopefully :
  
> 1) It must be noted as an incompatibility change in the release notes
Becomes irrelevant.

> 2) Ideally it would raise an exception that gives some clue.
   Then, if any such code exists, it should be easy to figure out what is wrong.
An exception is raised naturally due to a nil WidgetSet in TCLC<descendant>. Maybe NewInstance should raise one, that would help catch problems earlier.

>> I added a note in
 https://wiki.freepascal.org/Lazarus_2.2.0_release_notes#LCL_Interfaces_Changes
Should not be necessary any more.
LCLComponent_V2.patch (17,068 bytes)   
Index: lcl/lclclasses.pp
===================================================================
--- lcl/lclclasses.pp	(revision 63656)
+++ lcl/lclclasses.pp	(working copy)
@@ -19,7 +19,7 @@
 
 {$mode objfpc}{$H+}
 
-{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
+{ $DEFINE VerboseWSBrunoK}
 
 interface
 
@@ -97,6 +97,48 @@
 type
   TLCLComponentClass = class of TLCLComponent;
 
+procedure UpdateWSRegisterOffset;
+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;
+
+function GetWidgetSetClass(aLCLComponentClass : TLCLComponentClass) : TWSLCLComponentClass;
+var
+  lClassParent : TLCLComponentClass;
+begin
+  { Test if directly inherits WSRegisterClass from its parent }
+  lClassParent := TLCLComponentClass(aLCLComponentClass.ClassParent);
+  if (PCodePointer(Pointer(aLCLComponentClass)  + cWSRegisterOffset)^
+     = PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^)
+  then begin
+    { Retrieve WidgetSetClass from Parent }
+    Result := FindWSComponentClass(lClassParent);
+    {$IFDEF VerboseWSBrunoK}
+    if Assigned(Result) then
+      inc(cWSLCLParentHit);
+    {$ENDIF}
+  end
+  else begin
+    { Look if already registered. If true set FWidgetSetClass and exit }
+    Result := FindWSComponentClass(aLCLComponentClass);
+    {$IFDEF VerboseWSBrunoK}
+    if Assigned(Result) then
+      inc(cWSLCLDirectHit);
+    {$ENDIF}
+  end;
+end;
+
+{ TLCLComponent }
+
 function WSRegisterLCLComponent: boolean;
 begin
   RegisterWSComponent(TLCLComponent, TWSLCLComponent);
@@ -113,20 +155,6 @@
   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. }
@@ -137,36 +165,10 @@
   lClassParent : TLCLComponentClass;
 begin
   if cWSRegisterOffset = 0 then begin
-    UpdateOffset;
+    UpdateWSRegisterOffset;
     TLCLComponent.WSRegisterClass;  { Always create the top node ! }
   end;
-
-  WSRegisterClass;
-  Result := FindWSRegistered(Self);
-  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 }
-        RegisterWSComponent(TComponentClass(lClassParent), nil, nil, True);
-    end
-    else begin
-      { Force creation of intermediate nodes for Self and a leaf node for Self }
-      RegisterWSComponent(Self, nil, nil, True);
-      Result := FindWSRegistered(Self);
-      Break;
-    end;
-  until False;
+  Result := GetWidgetSetClass(Self);
 end;
 
 {$IFDEF DebugLCLComponents}
@@ -199,34 +201,38 @@
 var
   lWidgetSetClass: TWSLCLComponentClass;
   lClassParent : TLCLComponentClass;
+  Pass : integer;  { Want to return a nil WidgetSetClass if an BUG exists }
 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 cWSRegisterOffset = 0 then
+    UpdateWSRegisterOffset;
+
+  Pass := 0;
+  while Pass<3 do begin
+    lWidgetSetClass := GetWidgetSetClass(Self);
     if Assigned(lWidgetSetClass) then begin
       TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
-      Exit;
+      Break;
     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;
+    case Pass of
+    0:  begin
+          WSRegisterClass;
+          {$IFDEF VerboseWSBrunoK} inc(cWSLCLRegister); {$ENDIF}
+        end;
+    1:  if (PCodePointer(Pointer(Self)  + cWSRegisterOffset)^
+           = PCodePointer(Pointer(ClassParent) + cWSRegisterOffset)^)
+        then { inherits from ClassParent need tre down to parent }
+          RegisterWSComponent(TComponentClass(Self.ClassParent), nil, nil, True)
+        else { Self.WSRegisterClass defined but not Registered }
+          RegisterWSComponent(TComponentClass(Self), nil, nil, True);
     end;
+    Inc(Pass);
   end;
-
-  { WSRegisterClass and manage WSLVLClasses list }
-  TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
-  {$IFDEF VerboseWSBrunoK} inc(cWSLCLRegister); {$ENDIF}
+  {$IFDEF VerboseWSBrunoK}
+  if lWidgetSetClass = nil then
+    DumpWSClassesList;
+  {$ENDIF}
 end;
 
 procedure TLCLComponent.RemoveAllHandlersOfObject(AnObject: TObject);
Index: lcl/widgetset/wslclclasses.pp
===================================================================
--- lcl/widgetset/wslclclasses.pp	(revision 63656)
+++ lcl/widgetset/wslclclasses.pp	(working copy)
@@ -21,7 +21,7 @@
 {off$DEFINE VerboseWSRegistration}
 {off$DEFINE VerboseWSRegistration_methods}
 {off$DEFINE VerboseWSRegistration_treedump}
-{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
+{ $DEFINE VerboseWSBrunoK}
 
 interface
 ////////////////////////////////////////////////////
@@ -73,7 +73,6 @@
   end;
   TWSLCLReferenceComponentClass = class of TWSLCLReferenceComponent;
 
-
 function FindWSComponentClass(const AComponent: TComponentClass): TWSLCLComponentClass;
 function IsWSComponentInheritsFrom(const AComponent: TComponentClass;
   InheritFromClass: TWSLCLComponentClass): Boolean;
@@ -87,9 +86,6 @@
 function GetWSLazDeviceAPIs: TWSObjectClass;
 procedure RegisterWSLazDeviceAPIs(const AWSObject: TWSObjectClass);
 
-// ~bk Search for already registered classes
-function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
-
 { Debug : Dump the WSClassesList nodes }
 {$IFDEF VerboseWSBrunoK}
 const
@@ -122,6 +118,9 @@
     Parent: PClassNode;
     Child: PClassNode;
     Sibling: PClassNode;
+    {$IFDEF VerboseWSBrunoK}
+    DbgCreateSeq: Integer;         { Sequence of WSClassesList.Insert }
+    {$ENDIF}
   end;
 
 const
@@ -128,6 +127,9 @@
   // vmtAutoTable is something Delphi 2 and not used, we 'borrow' the vmt entry
   vmtWSPrivate = vmtAutoTable;
 
+  cWSRegisterOffset : integer = 0; // Offset of WSRegisterClass in class virtual methods
+  cLCLComponentWSReg : CodePointer = nil; // Adress of TLCLComponent.WSRegisterClass
+
 type
 
   { TWSClassesList }
@@ -135,8 +137,11 @@
   // Holds list of already registered TWidgetSetClass'es so TLCLComponent.NewInstance
   // can find faster the WidgetSetClass of the newinstance.
 
-  TWSClassesList = class(TFPList)
+  TRegClassesList = class(TFPList)
   private
+    {$IFDEF VerboseWSBrunoK}
+    FDbgCreateSeq: Integer;
+    {$ENDIF}
     FLastFoundIdx: integer;
     FLastFoundLCLClass: TComponentClass;
     function FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
@@ -143,7 +148,6 @@
     function Get(Index: integer): PClassNode; inline;
     function Search(const aItem: TClass; Out Index: integer): boolean;
     property Items[Index: integer]: PClassNode read Get; { write Put; default; }
-    {$IFDEF VerboseWSBrunoK} {$ENDIF}
     {$IFDEF VerboseWSBrunoK}
     procedure DumpNode(aN : integer; aPClassNode : PClassNode);
     procedure DumpNodes;
@@ -151,7 +155,8 @@
   end;
 
 var
-  WSClassesList: TWSClassesList = nil;
+  LCLClassesList: TRegClassesList = nil; { PClassNode's sorted by TLCLComponentClass
+                                           including internal and leaf nodes }
   WSLazAccessibleObjectClass: TWSObjectClass;
   WSLazDeviceAPIsClass: TWSObjectClass;
 
@@ -160,8 +165,8 @@
   idx: integer;
 begin
   while AComponent <> nil do begin
-    if WSClassesList.Search(AComponent, idx) then
-      Exit(PClassNode(WSClassesList[idx]));
+    if LCLClassesList.Search(AComponent, idx) then
+      Exit(PClassNode(LCLClassesList[idx]));
     AComponent := AComponent.ClassParent;
   end;
   Result := nil;
@@ -172,30 +177,26 @@
   idx: integer;
 begin
   Result := nil;
-  if WSClassesList.Search(AComponent, idx) then
-    Exit(WSClassesList[idx]);
+  if LCLClassesList.Search(AComponent, idx) then
+    Exit(LCLClassesList[idx]);
   Result := FindNodeParent(AComponent.ClassParent);
 end;
 
 function FindWSComponentClass(const AComponent: TComponentClass): TWSLCLComponentClass;
-var
-  Node: PClassNode;
 begin
-  Node := FindClassNode(AComponent);
-  if Assigned(Node) then
-    Result := TWSLCLComponentClass(Node^.VClass)
-  else
-    Result := nil;
+  if not Assigned(LCLClassesList) then
+    DoInitialization;
+  Result := LCLClassesList.FindWSClass(AComponent);
 end;
 
 function IsWSComponentInheritsFrom(const AComponent: TComponentClass;
   InheritFromClass: TWSLCLComponentClass): Boolean;
 var
-  Node: PClassNode;
+  lWSLCLComponentClass : TWSLCLComponentClass;
 begin
-  Node := FindClassNode(AComponent);
-  if Assigned(Node) then
-    Result := TWSLCLComponentClass(Node^.WSClass).InheritsFrom(InheritFromClass)
+  lWSLCLComponentClass := FindWSComponentClass(AComponent);
+  if Assigned(lWSLCLComponentClass) then
+    Result := TWSLCLComponentClass(lWSLCLComponentClass).InheritsFrom(InheritFromClass)
   else
     Result := false;
 end;
@@ -214,19 +215,6 @@
 
   TPointerArray = packed array[0..9999999] of Pointer;
   PPointerArray = ^TPointerArray;
-{
-function GetClassNameP(aClassName:string) : Pointer;
-var
-  lLen: integer;
-  lShortStr : shortstring;
-begin
-  lShortStr := aClassName + #0;
-  lLen := Length(lShortStr);
-  SetLength(lShortStr,lLen-1);
-  Result := GetMem(lLen+1);
-  move(lShortStr, Result^, lLen + 2);
-end;
-}
 
 function FindParentWSClassNode(const ANode: PClassNode): PClassNode;
 begin
@@ -426,7 +414,7 @@
     if (AClass = nil) or not (AClass.InheritsFrom(TLCLComponent)) then
       Exit(nil);
 
-    if not WSClassesList.Search(AClass, idx) then begin
+    if not LCLClassesList.Search(AClass, idx) then begin
       if not aParentGet and (AWSComponent = nil) then begin
         lInsertNode := False;
         Result := @lClassNode;
@@ -470,14 +458,18 @@
           Result^.Sibling := nil;
       end;
       if lInsertNode then begin
-        WSClassesList.Search(aClass, idx);
-        WSClassesList.Insert(idx, Result);
+        {$IFDEF VerboseWSBrunoK}
+        inc(LCLClassesList.FDbgCreateSeq);
+        Result^.DbgCreateSeq := LCLClassesList.FDbgCreateSeq;
+        {$ENDIF}
+        LCLClassesList.Search(aClass, idx);
+        LCLClassesList.Insert(idx, Result);
       end
       else
         Result := nil;
     end
     else begin
-      Result := WSClassesList[idx];
+      Result := LCLClassesList[idx];
     end;
   end;
 
@@ -500,11 +492,29 @@
     end;
   end;
 
+type
+  WSRegisterMethod = procedure of object;
 var
   Node: PClassNode;
   OldPrivate: TClass;
   idx: Integer;
+  lClassParent : TComponentClass;
+  lWSRegisterMethod : WSRegisterMethod;
+  lPSelfWSReg,
+  lPSelfParentWSReg: CodePointer;
 begin
+  { Check that parent widgetsets are WSRegisterClass'ed, if not
+    WSRegisterClass them. }
+  lClassParent := TComponentClass(AComponent.ClassParent);
+  lPSelfParentWSReg := PPointer(Pointer(lClassParent) + cWSRegisterOffset)^;
+  if not LCLClassesList.Search(lClassParent, idx) then begin
+    if AComponent <> TLCLComponent then begin { TLCLComponent is the top class }
+      TMethod(lWSRegisterMethod).Code := PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^;
+      TMethod(lWSRegisterMethod).Data := Pointer(lClassParent);
+      lWSRegisterMethod; { inherited }
+    end;
+  end;
+
   Node := GetNode(AComponent, False or ANewRegistration, True);
   if Node = nil then // No node created
     Exit;
@@ -531,6 +541,13 @@
   {$ENDIF}
   CreateVClass(Node, AWSPrivate);
 
+  { Update the PClassNode tree to fix up missing intermediate nodes.
+    AComponent didn't register itself but the parent should now be registered }
+  lPSelfWSReg := PCodePointer(Pointer(AComponent) + cWSRegisterOffset)^;
+  if lPSelfWSReg = lPSelfParentWSReg then
+    if not Assigned(FindWSComponentClass(TComponentClass(lClassParent))) then
+      RegisterWSComponent(TComponentClass(lClassParent), nil, nil, True);
+
   // Since child classes may depend on us, recreate them
   UpdateChildren(Node, OldPrivate);
 end;
@@ -555,28 +572,21 @@
   WSLazDeviceAPIsClass := AWSObject;
 end;
 
-function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
-begin
-  if not Assigned(WSClassesList) then
-    DoInitialization;
-  Result := WSClassesList.FindWSClass(AComponent);
-end;
-
 {$IFDEF VerboseWSBrunoK}
 procedure DumpWSClassesList;
 begin
-  WSClassesList.DumpNodes;
+  LCLClassesList.DumpNodes;
 end;
 {$ENDIF}
 
-{ TWSClassesList }
+{ TRegClassesList }
 
-function TWSClassesList.Get(Index: integer): PClassNode;
+function TRegClassesList.Get(Index: integer): PClassNode;
 begin
   Result := PClassNode(inherited Get(Index));
 end;
 
-function TWSClassesList.FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
+function TRegClassesList.FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
 var
   I: integer;
 begin
@@ -591,7 +601,7 @@
 
 { Searches a match for AComponent.ClassType. Returns index in items of
   the matching AComponent or the next bigger one }
-function TWSClassesList.Search(const aItem: TClass; out Index: integer): boolean;
+function TRegClassesList.Search(const aItem: TClass; out Index: integer): boolean;
 const
   cIndex: integer = 0;
 var
@@ -627,7 +637,7 @@
 end;
 
 {$IFDEF VerboseWSBrunoK}
-procedure TWSClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
+procedure TRegClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
 var
   LCLClassClassName, lWSClassClassName, lVClassName, ParentVClassName: string;
   lClassNode : PClassNode;
@@ -651,7 +661,7 @@
       ParentVClassName := '???';
     writeln(
       aN, ';',
-      { DbgCreateSeq, ';', }
+      DbgCreateSeq, ';',
       HexStr(aPClassNode), ';',
       HexStr(LCLClass), ';',  // : TComponentClass;
       LCLClassClassName, ';',
@@ -670,12 +680,12 @@
   end;
 end;
 
-procedure TWSClassesList.DumpNodes;
+procedure TRegClassesList.DumpNodes;
 var
   i: integer;
 begin
   WriteLn('n;',          // aN, ';',
-    { 'CreateSeq;',        // DbgCreateSeq, ';', }
+    'CreateSeq;',        // DbgCreateSeq, ';',
     'PClassNode;',        // Node
     'LCLClass;',         // HexStr(LCLClass), ';',  // : TComponentClass;
     'LCLClassName;',     // LCLClassClassName, ';',
@@ -709,9 +719,25 @@
 begin
 end;
 
+{ A identical copy from unit LCLClasses for better encapsulation }
+procedure UpdateWSRegisterOffset;
+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;
+
 procedure DoInitialization;
 begin
-  WSClassesList := TWSClassesList.Create;
+  UpdateWSRegisterOffset;
+  LCLClassesList := TRegClassesList.Create;
 end;
 
 procedure DoFinalization;
@@ -720,20 +746,20 @@
   Node: PClassNode;
 begin
   {$IFDEF VerboseWSBrunoK}
-  WSClassesList.DumpNodes;
+  LCLClassesList.DumpNodes;
   WriteLn;
   WriteLn('cWSLCLDirectHit=', cWSLCLDirectHit,
           ' cWSLCLParentHit=', cWSLCLParentHit,
           ' cWSLCLRegister=', cWSLCLRegister);
   {$ENDIF}
-  for n := 0 to WSClassesList.Count - 1 do
+  for n := 0 to LCLClassesList.Count - 1 do
   begin
-    Node := WSClassesList[n];
+    Node := LCLClassesList[n];
     if (Node^.VClass <> nil) and (not Node^.VClassNew) then
       Freemem(Node^.VClass);
     Dispose(Node);
   end;
-  FreeAndNil(WSClassesList);
+  FreeAndNil(LCLClassesList);
   {$IFDEF VerboseWSBrunoK}
   Write('Press enter to quit > '); ReadLn;
   {$ENDIF}
LCLComponent_V2.patch (17,068 bytes)   

Issue History

Date Modified Username Field Change
2020-07-22 23:45 Erik Rößiger New Issue
2020-07-22 23:49 Erik Rößiger Note Added: 0124243
2020-07-23 01:55 Cyrax Note Added: 0124247
2020-07-23 08:16 Juha Manninen Relationship added related to 0037360
2020-07-23 08:18 Juha Manninen Note Added: 0124252
2020-07-23 08:22 Juha Manninen Note Edited: 0124252 View Revisions
2020-07-23 10:03 Julian Puhl Note Added: 0124253
2020-07-23 10:06 Julian Puhl Note Edited: 0124253 View Revisions
2020-07-23 10:32 noname012 Note Added: 0124255
2020-07-23 11:00 BrunoK Note Added: 0124256
2020-07-23 11:23 Julian Puhl Note Added: 0124257
2020-07-23 11:23 Julian Puhl File Added: lazmemerror.jpg
2020-07-23 11:23 Julian Puhl Note Edited: 0124257 View Revisions
2020-07-23 11:32 BrunoK Note Added: 0124259
2020-07-23 11:40 noname012 Note Added: 0124260
2020-07-23 11:40 noname012 File Added: test-opengl-win.zip
2020-07-23 12:23 BrunoK Note Added: 0124263
2020-07-23 12:23 BrunoK File Added: openglcontext.pas.patch
2020-07-23 12:54 noname012 Note Added: 0124264
2020-07-23 13:03 Martin Friebe Note Added: 0124265
2020-07-23 13:04 Martin Friebe Note Edited: 0124265 View Revisions
2020-07-23 13:06 Martin Friebe Note Edited: 0124265 View Revisions
2020-07-23 13:09 Martin Friebe Note Edited: 0124265 View Revisions
2020-07-23 13:14 Martin Friebe Note Edited: 0124265 View Revisions
2020-07-23 13:54 BrunoK Note Added: 0124267
2020-07-23 22:26 Juha Manninen Assigned To => Juha Manninen
2020-07-23 22:26 Juha Manninen Status new => assigned
2020-07-23 22:52 Erik Rößiger Note Added: 0124288
2020-07-23 22:53 Juha Manninen Note Added: 0124289
2020-07-23 22:54 Martin Friebe Note Added: 0124290
2020-07-23 23:49 Julian Puhl Note Added: 0124292
2020-07-25 21:59 Juha Manninen Note Added: 0124330
2020-07-25 21:59 Juha Manninen Status assigned => resolved
2020-07-25 21:59 Juha Manninen Resolution open => fixed
2020-07-25 21:59 Juha Manninen Fixed in Revision => r63636
2020-07-25 21:59 Juha Manninen LazTarget => -
2020-07-25 21:59 Juha Manninen Widgetset QT5 => QT5
2020-07-26 18:20 BrunoK Note Added: 0124343
2020-07-26 18:20 BrunoK File Added: LCLComponent_V2.patch