1{ $Id: wslclclasses.pp 61642 2019-07-29 12:40:38Z dmitry $}
2{
3 *****************************************************************************
4 *                              wslclclasses.pp                              *
5 *                              ---------------                              *
6 *                                                                           *
7 *                                                                           *
8 *****************************************************************************
9
10 *****************************************************************************
11  This file is part of the Lazarus Component Library (LCL)
12
13  See the file COPYING.modifiedLGPL.txt, included in this distribution,
14  for details about the license.
15 *****************************************************************************
16}
17unit WSLCLClasses;
18
19{$mode objfpc}{$H+}
20{$I lcl_defines.inc}
21
22{off$DEFINE VerboseWSRegistration}
23{off$DEFINE VerboseWSRegistration_methods}
24{off$DEFINE VerboseWSRegistration_treedump}
25{$IFDEF VerboseWSRegistration_methods}
26{$DEFINE VerboseWSRegistration}
27{$ENDIF}
28
29interface
30////////////////////////////////////////////////////
31// I M P O R T A N T
32////////////////////////////////////////////////////
33// 1) Only class methods allowed
34// 2) Class methods have to be published and virtual
35// 3) To get as little as possible circles, the uses
36//    clause should contain only those LCL units
37//    needed for registration. WSxxx units are OK
38// 4) To improve speed, register only classes in the
39//    initialization section which actually
40//    implement something
41// 5) To enable your XXX widgetset units, look at
42//    the uses clause of the XXXintf.pp
43////////////////////////////////////////////////////
44uses
45  Classes, SysUtils, LCLProc;
46
47type
48  { TWSPrivate }
49
50  {
51    Internal WidgetSet specific object tree
52  }
53  TWSPrivate = class(TObject)
54  end;
55  TWSPrivateClass = class of TWSPrivate;
56
57  { For non-TComponent WS objects }
58
59  TWSObject = class(TObject)
60  public
61  end;
62  TWSObjectClass = class of TWSObject;
63
64  { TWSLCLComponent }
65
66{$M+}
67  TWSLCLComponent = class(TObject)
68  public
69    class function WSPrivate: TWSPrivateClass; //inline;
70  end;
71{$M-}
72  TWSLCLComponentClass = class of TWSLCLComponent;
73
74  { TWSLCLHandleComponent }
75
76  TWSLCLReferenceComponent = class(TWSLCLComponent)
77  published
78    class procedure DestroyReference(AComponent: TComponent); virtual;
79  end;
80  TWSLCLReferenceComponentClass = class of TWSLCLReferenceComponent;
81
82
83function FindWSComponentClass(const AComponent: TComponentClass): TWSLCLComponentClass;
84function IsWSComponentInheritsFrom(const AComponent: TComponentClass;
85  InheritFromClass: TWSLCLComponentClass): Boolean;
86procedure RegisterWSComponent(const AComponent: TComponentClass;
87                              const AWSComponent: TWSLCLComponentClass;
88                              const AWSPrivate: TWSPrivateClass = nil;
89                              const ANewRegistration: Boolean = False);
90// Only for non-TComponent based objects
91function GetWSLazAccessibleObject: TWSObjectClass;
92procedure RegisterWSLazAccessibleObject(const AWSObject: TWSObjectClass);
93function GetWSLazDeviceAPIs: TWSObjectClass;
94procedure RegisterWSLazDeviceAPIs(const AWSObject: TWSObjectClass);
95
96implementation
97
98uses
99  LCLClasses;
100
101procedure DoInitialization; forward;
102
103////////////////////////////////////////////////////
104// Registration code
105////////////////////////////////////////////////////
106type
107  PClassNode = ^TClassNode;
108  TClassNode = record
109    LCLClass: TComponentClass;
110    WSClass: TWSLCLComponentClass;
111    VClass: Pointer;
112    VClassName: ShortString;
113    VClassNew: Boolean; // Indicates that VClass=WSClass, VClass is not created during runtime
114    Parent: PClassNode;
115    Child: PClassNode;
116    Sibling: PClassNode;
117  end;
118
119const
120  // To my knowledge there is no way to tell the size of the
121  // VMT of a given class.
122  // Assume we have no more than 100 virtual entries
123  // 12.10.2013 - changed to 128, since we cannot add more methods in ws classes.zeljko.
124  VIRTUAL_VMT_COUNT = 128;
125  VIRTUAL_VMT_SIZE = vmtMethodStart + VIRTUAL_VMT_COUNT * SizeOf(Pointer);
126
127const
128  // vmtAutoTable is something Delphi 2 and not used, we 'borrow' the vmt entry
129  vmtWSPrivate = vmtAutoTable;
130
131var
132  MComponentIndex: TStringList;
133  MWSRegisterIndex: TStringList;
134  WSLazAccessibleObjectClass: TWSObjectClass;
135  WSLazDeviceAPIsClass: TWSObjectClass;
136
137function FindClassNode(const AComponent: TComponentClass): PClassNode;
138var
139  idx: Integer;
140  cls: TClass;
141begin
142  if MWSRegisterIndex = nil then
143    DoInitialization;
144
145  Result := nil;
146  cls := AComponent;
147  while cls <> nil do
148  begin
149    idx := MWSRegisterIndex.IndexOf(cls.ClassName);
150    if idx <> -1 then
151    begin
152      Result := PClassNode(MWSRegisterIndex.Objects[idx]);
153      Break;
154    end;
155    cls := cls.ClassParent;
156  end;
157end;
158
159function FindWSComponentClass(
160  const AComponent: TComponentClass): TWSLCLComponentClass;
161var
162  Node: PClassNode;
163begin
164  Node := FindClassNode(AComponent);
165  if Assigned(Node) then
166    Result := TWSLCLComponentClass(Node^.VClass)
167  else
168    Result := nil;
169end;
170
171function IsWSComponentInheritsFrom(const AComponent: TComponentClass;
172  InheritFromClass: TWSLCLComponentClass): Boolean;
173var
174  Node: PClassNode;
175begin
176  Node := FindClassNode(AComponent);
177  if Assigned(Node) then
178    Result := TWSLCLComponentClass(Node^.WSClass).InheritsFrom(InheritFromClass)
179  else
180    Result := false;
181end;
182
183type
184  TMethodNameTableEntry = packed record
185      Name: PShortstring;
186      Addr: Pointer;
187    end;
188
189  TMethodNameTable = packed record
190    Count: DWord;
191    Entries: packed array[0..9999999] of TMethodNameTableEntry;
192  end;
193  PMethodNameTable =  ^TMethodNameTable;
194
195  TPointerArray = packed array[0..9999999] of Pointer;
196  PPointerArray = ^TPointerArray;
197
198// ANewRegistration - If true, VClass is not created during runtime,
199// but instead normal, Object Pascal class creation is used
200procedure RegisterWSComponent(const AComponent: TComponentClass;
201  const AWSComponent: TWSLCLComponentClass;
202  const AWSPrivate: TWSPrivateClass = nil;
203  const ANewRegistration: Boolean = False);
204
205  function GetNode(const AClass: TClass): PClassNode;
206  var
207    idx: Integer;
208    Name: String;
209  begin
210    if (AClass = nil)
211    or not (AClass.InheritsFrom(TLCLComponent))
212    then begin
213      Result := nil;
214      Exit;
215    end;
216
217    Name := AClass.ClassName;
218    idx := MComponentIndex.IndexOf(Name);
219    if idx = -1
220    then begin
221      New(Result);
222      Result^.LCLClass := TComponentClass(AClass);
223      Result^.WSClass := nil;
224      Result^.VClass := nil;
225      Result^.VClassName := '';
226      Result^.VClassNew := False;
227      Result^.Child := nil;
228      Result^.Parent := GetNode(AClass.ClassParent);
229      if Result^.Parent = nil
230      then begin
231        Result^.Sibling := nil;
232      end
233      else begin
234        Result^.Sibling := Result^.Parent^.Child;
235        Result^.Parent^.Child := Result;
236      end;
237      MComponentIndex.AddObject(Name, TObject(Result));
238    end
239    else begin
240      Result := PClassNode(MComponentIndex.Objects[idx]);
241    end;
242  end;
243
244  function FindParentWSClassNode(const ANode: PClassNode): PClassNode;
245  begin
246    Result := ANode^.Parent;
247    while Result <> nil do
248    begin
249      if Result^.WSClass <> nil then Exit;
250      Result := Result^.Parent;
251    end;
252    Result := nil;
253  end;
254
255  function FindCommonAncestor(const AClass1, AClass2: TClass): TClass;
256  begin
257    Result := AClass1;
258    if AClass2.InheritsFrom(Result)
259    then Exit;
260
261    Result := AClass2;
262    while Result <> nil do
263    begin
264      if AClass1.InheritsFrom(Result)
265      then Exit;
266      Result := Result.ClassParent;
267    end;
268
269    Result := nil;
270  end;
271
272  procedure CreateVClass(const ANode: PClassNode; AOldPrivate: TClass = nil);
273  var
274    ParentWSNode: PClassNode;
275    CommonClass: TClass;
276    Vvmt, Cvmt, Pvmt: PPointerArray;
277    Cmnt: PMethodNameTable;
278    SearchAddr: Pointer;
279    n, idx: Integer;
280    WSPrivate, OrgPrivate: TClass;
281    Processed: array[0..VIRTUAL_VMT_COUNT-1] of Boolean;
282    {$IFDEF VerboseWSRegistration}
283    Indent: String;
284    {$ENDIF}
285  begin
286    if AWSPrivate = nil
287    then WSPrivate := TWSPrivate
288    else WSPrivate := AWSPrivate;
289
290    if ANode^.VClass = nil
291    then begin
292      ANode^.VClass := GetMem(VIRTUAL_VMT_SIZE)
293    end
294    else begin
295      // keep original WSPrivate (only when different than default class)
296      OrgPrivate := PClass(ANode^.VClass + vmtWSPrivate)^;
297
298      if (OrgPrivate <> nil) and (OrgPrivate <> AOldPrivate) and OrgPrivate.InheritsFrom(WSPrivate)
299      then begin
300        {$IFDEF VerboseWSRegistration}
301        DebugLn('Keep org private: ', WSPrivate.ClassName, ' -> ', OrgPrivate.Classname);
302        {$ENDIF}
303        WSPrivate := OrgPrivate;
304      end;
305    end;
306
307    // Initially copy the WSClass
308    // Tricky part, the source may get beyond read mem limit
309    Move(Pointer(ANode^.WSClass)^, ANode^.VClass^, VIRTUAL_VMT_SIZE);
310
311    // Set WSPrivate class
312    ParentWSNode := FindParentWSClassNode(ANode);
313    if ParentWSNode = nil
314    then begin
315      // nothing to do
316      PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
317      {$IFDEF VerboseWSRegistration}
318      DebugLn('Virtual parent: nil, WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
319      {$ENDIF}
320      Exit;
321    end;
322
323    if WSPrivate = TWSPrivate
324    then begin
325      if ParentWSNode^.VClass = nil
326      then begin
327        DebugLN('[WARNING] Missing VClass for: ', ParentWSNode^.WSClass.ClassName);
328        PClass(ANode^.VClass + vmtWSPrivate)^ := TWSPrivate;
329      end
330      else PClass(ANode^.VClass + vmtWSPrivate)^ := PClass(ParentWSNode^.VClass + vmtWSPrivate)^;
331    end
332    else PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
333
334    {$IFDEF VerboseWSRegistration}
335    DebugLn('Virtual parent: ', ParentWSNode^.WSClass.ClassName, ', WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
336    {$ENDIF}
337
338    // Try to find the common ancestor
339    CommonClass := FindCommonAncestor(ANode^.WSClass, ParentWSNode^.WSClass);
340    {$IFDEF VerboseWSRegistration}
341    DebugLn('Common: ', CommonClass.ClassName);
342    Indent := '';
343    {$ENDIF}
344
345    Vvmt := ANode^.VClass + vmtMethodStart;
346    Pvmt := ParentWSNode^.VClass + vmtMethodStart;
347    FillChar(Processed[0], SizeOf(Processed), 0);
348
349    while CommonClass <> nil do
350    begin
351      Cmnt := PPointer(Pointer(CommonClass) + vmtMethodTable)^;
352      if Cmnt <> nil
353      then begin
354        {$IFDEF VerboseWSRegistration_methods}
355        DebugLn(Indent, '*', CommonClass.Classname, ' method count: ', IntToStr(Cmnt^.Count));
356        Indent := Indent + ' ';
357        {$ENDIF}
358
359        Cvmt := Pointer(CommonClass) + vmtMethodStart;
360        Assert(Cmnt^.Count < VIRTUAL_VMT_COUNT, 'MethodTable count is larger than assumed VIRTUAL_VMT_COUNT');
361
362        // Loop through the VMT to see what is overridden
363        for n := 0 to Cmnt^.Count - 1 do
364        begin
365          SearchAddr := Cmnt^.Entries[n].Addr;
366          {$IFDEF VerboseWSRegistration_methods}
367          DebugLn('%sSearch: %s (%p)', [Indent, Cmnt^.Entries[n].Name^, SearchAddr]);
368          {$ENDIF}
369
370          for idx := 0 to VIRTUAL_VMT_COUNT - 1 do
371          begin
372            if Cvmt^[idx] = SearchAddr
373            then begin
374              {$IFDEF VerboseWSRegistration_methods}
375              DebugLn('%sFound at index: %d (v=%p p=%p)', [Indent, idx, Vvmt^[idx], Pvmt^[idx]]);
376              {$ENDIF}
377
378              if Processed[idx]
379              then begin
380                {$IFDEF VerboseWSRegistration_methods}
381                DebugLn(Indent, 'Processed -> skipping');
382                {$ENDIF}
383                Break;
384              end;
385              Processed[idx] := True;
386
387              if  (Vvmt^[idx] = SearchAddr)  //original
388              and (Pvmt^[idx] <> SearchAddr) //overridden by parent
389              then begin
390                {$IFDEF VerboseWSRegistration_methods}
391                DebugLn('%sUpdating %p -> %p', [Indent, Vvmt^[idx], Pvmt^[idx]]);
392                {$ENDIF}
393                Vvmt^[idx] := Pvmt^[idx];
394              end;
395
396              Break;
397            end;
398            if idx = VIRTUAL_VMT_COUNT - 1
399            then begin
400              DebugLn('[WARNING] VMT entry "', Cmnt^.Entries[n].Name^, '" not found in "', CommonClass.ClassName, '"');
401              Break;
402            end;
403          end;
404        end;
405      end;
406      CommonClass := Commonclass.ClassParent;
407    end;
408
409    // Adjust classname
410    ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName;
411    PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName;
412    // Adjust classparent
413    {$IF (FPC_FULLVERSION >= 30101)}
414    PPointer(ANode^.VClass + vmtParent)^ := @ParentWSNode^.WSClass;
415    {$ELSE}
416    PPointer(ANode^.VClass + vmtParent)^ := ParentWSNode^.WSClass;
417    {$ENDIF}
418    // Delete methodtable entry
419    PPointer(ANode^.VClass + vmtMethodTable)^ := nil;
420  end;
421
422  procedure UpdateChildren(const ANode: PClassNode; AOldPrivate: TClass);
423  var
424    Node: PClassNode;
425  begin
426    Node := ANode^.Child;
427    while Node <> nil do
428    begin
429      if (Node^.WSClass <> nil) and (not Node^.VClassNew) then
430      begin
431        {$IFDEF VerboseWSRegistration}
432        DebugLn('Update VClass for: ', Node^.WSClass.ClassName);
433        {$ENDIF}
434        CreateVClass(Node, AOldPrivate);
435      end;
436      UpdateChildren(Node, AOldPrivate);
437      Node := Node^.Sibling;
438    end;
439  end;
440
441var
442  Node: PClassNode;
443  OldPrivate: TClass;
444begin
445  if MWSRegisterIndex = nil then
446    DoInitialization;
447  Node := GetNode(AComponent);
448  if Node = nil then Exit;
449
450  if Node^.WSClass = nil
451  then MWSRegisterIndex.AddObject(AComponent.ClassName, TObject(Node));
452  Node^.WSClass := AWSComponent;
453
454  if ANewRegistration then
455  begin
456    Node^.VClass := AWSComponent;
457    Node^.VClassNew := True;
458    Exit;
459  end;
460
461  // childclasses "inherit" the private from their parent
462  // the child privates should only be updated when their private is still
463  // the same as their parents
464  if Node^.VClass = nil
465  then OldPrivate := nil
466  else OldPrivate := PClass(Node^.VClass + vmtWSPrivate)^;
467
468  {$IFDEF VerboseWSRegistration}
469  DebugLn('Create VClass for: ', AComponent.ClassName, ' -> ', Node^.WSClass.ClassName);
470  {$ENDIF}
471  CreateVClass(Node);
472
473  // Since child classes may depend on us, recreate them
474  UpdateChildren(Node, OldPrivate);
475end;
476
477function GetWSLazAccessibleObject: TWSObjectClass;
478begin
479  Result := WSLazAccessibleObjectClass;
480end;
481
482procedure RegisterWSLazAccessibleObject(const AWSObject: TWSObjectClass);
483begin
484  WSLazAccessibleObjectClass := AWSObject;
485end;
486
487function GetWSLazDeviceAPIs: TWSObjectClass;
488begin
489  Result := WSLazDeviceAPIsClass;
490end;
491
492procedure RegisterWSLazDeviceAPIs(const AWSObject: TWSObjectClass);
493begin
494  WSLazDeviceAPIsClass := AWSObject;
495end;
496
497{ TWSLCLComponent }
498
499class function TWSLCLComponent.WSPrivate: TWSPrivateClass; //inline;
500begin
501  Result := TWSPrivateClass(PClass(Pointer(Self) + vmtWSPrivate)^);
502end;
503
504{ TWSLCLHandleComponent }
505
506class procedure TWSLCLReferenceComponent.DestroyReference(AComponent: TComponent);
507begin
508end;
509
510procedure DoInitialization;
511begin
512  MComponentIndex := TStringList.Create;
513  MComponentIndex.Sorted := True;
514  MComponentIndex.Duplicates := dupError;
515
516  MWSRegisterIndex := TStringList.Create;
517  MWSRegisterIndex.Sorted := True;
518  MWSRegisterIndex.Duplicates := dupError;
519end;
520
521{$ifdef VerboseWSRegistration_treedump}
522procedure DumpVTree;
523  procedure DumpNode(ANode: PClassNode; AIndent: String = '');
524  begin
525    if ANode = nil then Exit;
526
527    DbgOut(AIndent);
528
529    DbgOut('LCLClass=');
530    if ANode^.LCLClass = nil
531    then DbgOut('nil')
532    else DbgOut(ANode^.LCLClass.Classname);
533
534    DbgOut(' WSClass=');
535    if ANode^.WSClass = nil
536    then DbgOut('nil')
537    else DbgOut(ANode^.WSClass.Classname);
538
539    DbgOut(' VClass=');
540    if ANode^.VClass = nil
541    then DbgOut('nil')
542    else begin
543      DbgOut(TClass(ANode^.VClass).Classname);
544      DbgOut(' VClass.Parent=');
545      if TClass(ANode^.VClass).ClassParent = nil
546      then DbgOut('nil')
547      else DbgOut(TClass(ANode^.VClass).ClassParent.ClassName);
548
549      DbgOut(' Private=');
550      if PClass(ANode^.VClass + vmtWSPrivate)^ = nil
551      then DbgOut('nil')
552      else DbgOut(PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
553    end;
554
555    DbgOut(' VClassName=''', ANode^.VClassName, '''');
556    DebugLn;
557
558    DumpNode(ANode^.Child, AIndent + ' ');
559
560    DumpNode(ANode^.Sibling, AIndent);
561  end;
562
563var
564  n: Integer;
565  Node: PClassNode;
566begin
567  for n := 0 to MComponentIndex.Count - 1 do
568  begin
569    Node := PClassNode(MComponentIndex.Objects[n]);
570    if Node^.Parent = nil
571    then DumpNode(Node);
572  end;
573end;
574{$endif}
575
576procedure DoFinalization;
577var
578  n: Integer;
579  Node: PClassNode;
580begin
581  {$ifdef VerboseWSRegistration_treedump}
582  DumpVTree;
583  {$endif}
584
585  for n := 0 to MComponentIndex.Count - 1 do
586  begin
587    Node := PClassNode(MComponentIndex.Objects[n]);
588    if (Node^.VClass <> nil) and (not Node^.VClassNew) then
589      Freemem(Node^.VClass);
590    Dispose(Node);
591  end;
592  FreeAndNil(MComponentIndex);
593  FreeAndNil(MWSRegisterIndex);
594end;
595
596
597finalization
598  DoFinalization;
599
600end.
601