1{ $Id: lclclasses.pp 59201 2018-09-30 22:45:40Z maxim $} 2{ 3 ***************************************************************************** 4 * lclclasses.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 17 Defines the base class for all LCL TComponents including controls. 18} 19unit LCLClasses; 20 21{$mode objfpc}{$H+} 22 23interface 24 25uses 26 Classes, WSLCLClasses, WSReferences, LCLType, LCLProc; 27 28type 29 30 // SysUtils.LongRec has unsigned Word for Lo and Hi, 31 // we need a similar record with signed SmallInt 32 LazLongRec = packed record 33{$ifdef FPC_LITTLE_ENDIAN} 34 Lo,Hi : SmallInt; 35{$else FPC_LITTLE_ENDIAN} 36 Hi,Lo : SmallInt; 37{$endif FPC_LITTLE_ENDIAN} 38 end; 39 40 { TLCLComponent } 41 42 TLCLComponent = class(TComponent) 43 private 44 FWidgetSetClass: TWSLCLComponentClass; 45 FLCLRefCount: integer; 46 protected 47 class procedure WSRegisterClass; virtual; 48 class function GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass; virtual; 49 public 50 constructor Create(TheOwner: TComponent); override; 51 destructor Destroy; override; 52 class function NewInstance: TObject; override; 53 procedure RemoveAllHandlersOfObject(AnObject: TObject); virtual; 54 procedure IncLCLRefCount; 55 procedure DecLCLRefCount; 56 property LCLRefCount: integer read FLCLRefCount; 57 property WidgetSetClass: TWSLCLComponentClass read FWidgetSetClass; 58 end; 59 60 { TLCLReferenceComponent } 61 62 // A base class for all components having a handle 63 64 TLCLReferenceComponent = class(TLCLComponent) 65 private 66 FReferencePtr: PWSReference; 67 68 FCreating: Boolean; // Set if we are creating the handle 69 function GetHandle: THandle; 70 function GetReferenceAllocated: Boolean; 71 protected 72 procedure CreateParams(var AParams: TCreateParams); virtual; 73 procedure DestroyReference; 74 function GetReferenceHandle: THandle; virtual; abstract; 75 procedure ReferenceCreated; virtual; // gets called after the Handle is created 76 procedure ReferenceDestroying; virtual; // gets called before the Handle is destroyed 77 procedure ReferenceNeeded; 78 function WSCreateReference(AParams: TCreateParams): PWSReference; virtual; 79 procedure WSDestroyReference; virtual; 80 protected 81 public 82 destructor Destroy; override; 83 property HandleAllocated: Boolean read GetReferenceAllocated; 84 property ReferenceAllocated: Boolean read GetReferenceAllocated; 85 end; 86 87implementation 88 89uses 90 InterfaceBase; 91 92class procedure TLCLComponent.WSRegisterClass; 93begin 94 // 95end; 96 97// This method allows descendents to override the FWidgetSetClass 98class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass; 99begin 100 Result := FindWSComponentClass(Self); 101 102 if Result = nil then 103 begin 104 {$IFDEF VerboseLCL} 105 DebugLn(['TLCLComponent.NewInstance WARNING: missing FWidgetSetClass ',ClassName]); 106 {$ENDIF} 107 Result := TWSLCLComponent; 108 end; 109end; 110 111constructor TLCLComponent.Create(TheOwner: TComponent); 112begin 113 inherited Create(TheOwner); 114 {$IFDEF DebugLCLComponents} 115 //DebugLn('TLCLComponent.Create ',DbgSName(Self)); 116 DebugLCLComponents.MarkCreated(Self,DbgSName(Self)); 117 {$ENDIF} 118end; 119 120destructor TLCLComponent.Destroy; 121begin 122 {$IFNDEF DisableChecks} 123 if FLCLRefCount>0 then begin 124 DebugLn(['WARNING: ' + ClassName + '.Destroy with LCLRefCount>0. Hint: Maybe the component is processing an event?']); 125 {$IFDEF DebugTLCLComponentDestroy} 126 DumpStack; 127 {$ENDIF} 128 end; 129 {$ENDIF} 130 {$IFDEF DebugLCLComponents} 131 //DebugLn('TLCLComponent.Destroy ',DbgSName(Self)); 132 DebugLCLComponents.MarkDestroyed(Self); 133 {$ENDIF} 134 inherited Destroy; 135end; 136 137class function TLCLComponent.NewInstance: TObject; 138begin 139 Result := inherited NewInstance; 140 WSRegisterClass; 141 142 TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result)); 143end; 144 145procedure TLCLComponent.RemoveAllHandlersOfObject(AnObject: TObject); 146begin 147end; 148 149procedure TLCLComponent.IncLCLRefCount; 150begin 151 inc(FLCLRefCount); 152end; 153 154procedure TLCLComponent.DecLCLRefCount; 155begin 156 dec(FLCLRefCount); 157end; 158 159{ TLCLReferenceComponent } 160 161procedure TLCLReferenceComponent.CreateParams(var AParams: TCreateParams); 162begin 163end; 164 165destructor TLCLReferenceComponent.Destroy; 166begin 167 DestroyReference; 168 inherited Destroy; 169end; 170 171procedure TLCLReferenceComponent.DestroyReference; 172begin 173 if ReferenceAllocated then 174 begin 175 ReferenceDestroying; 176 WSDestroyReference; 177 FReferencePtr^._Clear; 178 FReferencePtr := nil; 179 end; 180end; 181 182function TLCLReferenceComponent.GetHandle: THandle; 183begin 184 ReferenceNeeded; 185 Result := GetReferenceHandle; 186end; 187 188function TLCLReferenceComponent.GetReferenceAllocated: Boolean; 189begin 190 Result := (FReferencePtr <> nil) and FReferencePtr^.Allocated; 191end; 192 193procedure TLCLReferenceComponent.ReferenceCreated; 194begin 195end; 196 197procedure TLCLReferenceComponent.ReferenceDestroying; 198begin 199end; 200 201procedure TLCLReferenceComponent.ReferenceNeeded; 202var 203 Params: TCreateParams; 204begin 205 if ReferenceAllocated then Exit; 206 207 if FCreating 208 then begin 209 // raise some error ? 210 {$IFNDEF DisableChecks} 211 DebugLn('TLCLReferenceComponent: Circular reference creation'); 212 {$ENDIF} 213 Exit; 214 end; 215 216 CreateParams(Params); 217 FCreating := True; 218 try 219 FReferencePtr := WSCreateReference(Params); 220 if not ReferenceAllocated 221 then begin 222 // raise some error ? 223 {$IFNDEF DisableChecks} 224 DebugLn('TLCLHandleComponent: Reference creation failed'); 225 {$ENDIF} 226 Exit; 227 end; 228 finally 229 FCreating := False; 230 end; 231 ReferenceCreated; 232end; 233 234function TLCLReferenceComponent.WSCreateReference(AParams: TCreateParams): PWSReference; 235begin 236 // this function should be overriden in derrived class 237 Result := nil; 238end; 239 240procedure TLCLReferenceComponent.WSDestroyReference; 241begin 242 TWSLCLReferenceComponentClass(WidgetSetClass).DestroyReference(Self); 243end; 244 245end. 246 247