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