← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/include/control.inc

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lcl/include/control.inc
1
1
{%MainUnit ../controls.pp}
2
 
{  $Id: control.inc 31591 2011-07-07 17:16:28Z juha $  }
3
2
 
4
3
{******************************************************************************
5
4
                                     TControl
27
26
 
28
27
{ $DEFINE CHECK_POSITION}
29
28
 
 
29
{ TLazAccessibleObjectEnumerator }
 
30
 
 
31
function TLazAccessibleObjectEnumerator.GetCurrent: TLazAccessibleObject;
 
32
begin
 
33
  Result:=TLazAccessibleObject(FCurrent.Data);
 
34
end;
 
35
 
 
36
{ TLazAccessibleObject }
 
37
 
 
38
function TLazAccessibleObject.GetHandle: PtrInt;
 
39
var
 
40
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
41
begin
 
42
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
43
  if (WidgetsetClass <> nil) and (FHandle = 0) then
 
44
  begin
 
45
    FHandle := WidgetsetClass.CreateHandle(Self);
 
46
    InitializeHandle();
 
47
  end;
 
48
  Result := FHandle;
 
49
end;
 
50
 
 
51
function TLazAccessibleObject.GetAccessibleValue: TCaption;
 
52
begin
 
53
  Result := FAccessibleValue;
 
54
end;
 
55
 
 
56
function TLazAccessibleObject.GetPosition: TPoint;
 
57
begin
 
58
  if (OwnerControl <> nil) and (OwnerControl.GetAccessibleObject() = Self) then
 
59
  begin
 
60
    Result := Point(OwnerControl.Left, OwnerControl.Top);
 
61
    Exit;
 
62
  end;
 
63
  Result := FPosition;
 
64
end;
 
65
 
 
66
function TLazAccessibleObject.GetSize: TSize;
 
67
begin
 
68
  if (OwnerControl <> nil) and (OwnerControl.GetAccessibleObject() = Self) then
 
69
  begin
 
70
    Result := Types.Size(OwnerControl.Width, OwnerControl.Height);
 
71
    Exit;
 
72
  end;
 
73
  Result := FSize;
 
74
end;
 
75
 
 
76
procedure TLazAccessibleObject.SetHandle(AValue: PtrInt);
 
77
begin
 
78
  if AValue = FHandle then Exit;
 
79
  FHandle := AValue;
 
80
  InitializeHandle();
 
81
end;
 
82
 
 
83
procedure TLazAccessibleObject.SetPosition(AValue: TPoint);
 
84
var
 
85
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
86
begin
 
87
  if (FPosition.X=AValue.X) and (FPosition.Y=AValue.Y) then Exit;
 
88
  FPosition := AValue;
 
89
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
90
  WidgetsetClass.SetPosition(Self, AValue);
 
91
end;
 
92
 
 
93
procedure TLazAccessibleObject.SetSize(AValue: TSize);
 
94
var
 
95
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
96
begin
 
97
  if (FSize.CX=AValue.CX) and (FSize.CY=AValue.CY) then Exit;
 
98
  FSize := AValue;
 
99
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
100
  WidgetsetClass.SetSize(Self, AValue);
 
101
end;
 
102
 
 
103
class procedure TLazAccessibleObject.WSRegisterClass;
 
104
begin
 
105
//  inherited WSRegisterClass;
 
106
  RegisterLazAccessibleObject;
 
107
end;
 
108
 
 
109
constructor TLazAccessibleObject.Create(AOwner: TControl);
 
110
begin
 
111
  inherited Create;//(AOwner);
 
112
  OwnerControl := AOwner;
 
113
  FChildrenSortedForDataObject := TAvgLvlTree.Create(@CompareDataObjectWithLazAccessibleObject);
 
114
  WSRegisterClass();
 
115
end;
 
116
 
 
117
destructor TLazAccessibleObject.Destroy;
 
118
var
 
119
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
120
begin
 
121
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
122
  ClearChildAccessibleObjects();
 
123
  if (WidgetsetClass <> nil) and (FHandle <> 0) then
 
124
    WidgetsetClass.DestroyHandle(Self);
 
125
  FreeAndNil(FChildrenSortedForDataObject);
 
126
  inherited Destroy;
 
127
end;
 
128
 
 
129
function TLazAccessibleObject.HandleAllocated: Boolean;
 
130
begin
 
131
  Result := FHandle <> 0;
 
132
end;
 
133
 
 
134
procedure TLazAccessibleObject.InitializeHandle;
 
135
var
 
136
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
137
begin
 
138
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
139
  WidgetsetClass.SetAccessibleDescription(Self, FAccessibleDescription);
 
140
  WidgetsetClass.SetAccessibleValue(Self, FAccessibleValue);
 
141
  WidgetsetClass.SetAccessibleRole(Self, FAccessibleRole);
 
142
end;
 
143
 
 
144
procedure TLazAccessibleObject.SetAccessibleDescription(const ADescription: TCaption);
 
145
var
 
146
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
147
begin
 
148
  if FAccessibleDescription=ADescription then Exit;
 
149
  FAccessibleDescription := ADescription;
 
150
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
151
  WidgetsetClass.SetAccessibleDescription(Self, ADescription);
 
152
end;
 
153
 
 
154
procedure TLazAccessibleObject.SetAccessibleValue(const AValue: TCaption);
 
155
var
 
156
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
157
begin
 
158
  if FAccessibleValue=AValue then Exit;
 
159
  FAccessibleValue := AValue;
 
160
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
161
  WidgetsetClass.SetAccessibleValue(Self, AValue);
 
162
end;
 
163
 
 
164
procedure TLazAccessibleObject.SetAccessibleRole(const ARole: TLazAccessibilityRole);
 
165
var
 
166
  WidgetsetClass: TWSLazAccessibleObjectClass;
 
167
begin
 
168
  if FAccessibleRole=ARole then Exit;
 
169
  FAccessibleRole := ARole;
 
170
  WidgetsetClass := TWSLazAccessibleObjectClass(GetWSLazAccessibleObject());
 
171
  WidgetsetClass.SetAccessibleRole(Self, ARole);
 
172
end;
 
173
 
 
174
function TLazAccessibleObject.FindOwnerWinControl: TWinControl;
 
175
begin
 
176
  Result := nil;
 
177
  if (OwnerControl <> nil) and (OwnerControl is TWinControl) then Exit(OwnerControl as TWinControl);
 
178
  if Self.Parent = nil then Exit;
 
179
  Result := Self.Parent.FindOwnerWinControl();
 
180
end;
 
181
 
 
182
function TLazAccessibleObject.AddChildAccessibleObject: TLazAccessibleObject;
 
183
begin
 
184
  Result := nil;
 
185
  if FChildrenSortedForDataObject = nil then Exit;
 
186
  Result := TLazAccessibleObject.Create(OwnerControl);
 
187
  Result.Parent := Self;
 
188
  FChildrenSortedForDataObject.Add(Result);
 
189
  //DebugLn('[TControl.AddChildAccessibleObject] Name=%s', [Name]);
 
190
end;
 
191
 
 
192
procedure TLazAccessibleObject.InsertChildAccessibleObject(
 
193
  AObject: TLazAccessibleObject);
 
194
begin
 
195
  if FChildrenSortedForDataObject = nil then Exit;
 
196
  FChildrenSortedForDataObject.Add(AObject);
 
197
end;
 
198
 
 
199
procedure TLazAccessibleObject.ClearChildAccessibleObjects;
 
200
var
 
201
  lXObject: TLazAccessibleObject;
 
202
  AVLNode: TAvgLvlTreeNode;
 
203
begin
 
204
  if FChildrenSortedForDataObject = nil then Exit;
 
205
  //DebugLn(Format('[TControl.ClearChildAccessibleObjects] Name=%s Count=%d', [Name, FAccessibleChildren.Count]));
 
206
  // Free only the non-control children
 
207
  AVLNode:=FChildrenSortedForDataObject.FindLowest;
 
208
  while AVLNode<>nil do begin
 
209
    lXObject := TLazAccessibleObject(AVLNode.Data);
 
210
    if lXObject.OwnerControl = OwnerControl then
 
211
      lXObject.Free;
 
212
    AVLNode:=FChildrenSortedForDataObject.FindSuccessor(AVLNode);
 
213
  end;
 
214
  FChildrenSortedForDataObject.Clear;
 
215
end;
 
216
 
 
217
procedure TLazAccessibleObject.RemoveChildAccessibleObject(
 
218
  AObject: TLazAccessibleObject; AFreeObject: Boolean = True);
 
219
var
 
220
  Node: TAvgLvlTreeNode;
 
221
begin
 
222
  if FChildrenSortedForDataObject = nil then Exit;
 
223
  Node:=FChildrenSortedForDataObject.Find(AObject);
 
224
  if Node=nil then exit;
 
225
  FChildrenSortedForDataObject.Delete(Node);
 
226
  if AFreeObject then
 
227
    AObject.Free;
 
228
end;
 
229
 
 
230
function TLazAccessibleObject.GetChildAccessibleObjectWithDataObject(
 
231
  ADataObject: TObject): TLazAccessibleObject;
 
232
var
 
233
  Node: TAvgLvlTreeNode;
 
234
begin
 
235
  Result := nil;
 
236
  if FChildrenSortedForDataObject = nil then Exit;
 
237
  Node:=FChildrenSortedForDataObject.FindKey(ADataObject,@CompareDataObjectWithLazAccessibleObject);
 
238
  if Node<>nil then
 
239
    Result:=TLazAccessibleObject(Node.Data);
 
240
end;
 
241
 
 
242
function TLazAccessibleObject.GetChildAccessibleObjectsCount: Integer;
 
243
begin
 
244
  Result := 0;
 
245
  if FChildrenSortedForDataObject <> nil then
 
246
    Result := FChildrenSortedForDataObject.Count;
 
247
end;
 
248
 
 
249
function TLazAccessibleObject.GetChildAccessibleObject(AIndex: Integer): TLazAccessibleObject;
 
250
var
 
251
  lNode: TAvgLvlTreeNode = nil;
 
252
begin
 
253
  Result := nil;
 
254
  if AIndex = 0 then lNode := FChildrenSortedForDataObject.FindLowest()
 
255
  else if AIndex = GetChildAccessibleObjectsCount()-1 then
 
256
    lNode := FChildrenSortedForDataObject.FindHighest()
 
257
  else if AIndex = FLastSearchIndex then lNode := FLastSearchNode
 
258
  else if AIndex = FLastSearchIndex+1 then
 
259
    lNode := FChildrenSortedForDataObject.FindSuccessor(FLastSearchNode)
 
260
  else if AIndex = FLastSearchIndex-1 then
 
261
    lNode := FChildrenSortedForDataObject.FindPrecessor(FLastSearchNode);
 
262
 
 
263
  if lNode = nil then Exit;
 
264
 
 
265
  Result := TLazAccessibleObject(lNode.Data);
 
266
end;
 
267
 
 
268
function TLazAccessibleObject.GetFirstChildAccessibleObject: TLazAccessibleObject;
 
269
begin
 
270
  Result := nil;
 
271
  FLastSearchInSubcontrols := False;
 
272
  if GetChildAccessibleObjectsCount() > 0 then
 
273
    Result := GetChildAccessibleObject(0)
 
274
  else if (OwnerControl <> nil) and (OwnerControl is TWinControl) then
 
275
  begin
 
276
    FLastSearchIndex := 1;
 
277
    FLastSearchInSubcontrols := True;
 
278
    if (TWinControl(OwnerControl).ControlCount > 0) then
 
279
      Result := TWinControl(OwnerControl).Controls[0].GetAccessibleObject();
 
280
  end;
 
281
end;
 
282
 
 
283
function TLazAccessibleObject.GetNextChildAccessibleObject: TLazAccessibleObject;
 
284
begin
 
285
  Result := nil;
 
286
  if not FLastSearchInSubcontrols then
 
287
  begin
 
288
    if GetChildAccessibleObjectsCount() < FLastSearchIndex then
 
289
      Result := GetChildAccessibleObject(FLastSearchIndex)
 
290
    else if (OwnerControl <> nil) and (OwnerControl is TWinControl) then
 
291
    begin
 
292
      FLastSearchIndex := 1;
 
293
      FLastSearchInSubcontrols := True;
 
294
      Result := TWinControl(OwnerControl).Controls[0].GetAccessibleObject();
 
295
    end;
 
296
  end
 
297
  else
 
298
  begin
 
299
    if TWinControl(OwnerControl).ControlCount > FLastSearchIndex then
 
300
    begin
 
301
      Result := TWinControl(OwnerControl).Controls[FLastSearchIndex].GetAccessibleObject();
 
302
      Inc(FLastSearchIndex);
 
303
    end;
 
304
  end;
 
305
end;
 
306
 
 
307
function TLazAccessibleObject.GetSelectedChildAccessibleObject: TLazAccessibleObject;
 
308
begin
 
309
  Result := nil;
 
310
  if OwnerControl = nil then Exit;
 
311
  Result := OwnerControl.GetSelectedChildAccessibleObject();
 
312
end;
 
313
 
 
314
function TLazAccessibleObject.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
 
315
begin
 
316
  Result := nil;
 
317
  if OwnerControl = nil then Exit;
 
318
  Result := OwnerControl.GetChildAccessibleObjectAtPos(APos);
 
319
end;
 
320
 
 
321
function TLazAccessibleObject.GetEnumerator: TLazAccessibleObjectEnumerator;
 
322
begin
 
323
  Result:=TLazAccessibleObjectEnumerator.Create(FChildrenSortedForDataObject);
 
324
end;
 
325
 
30
326
{------------------------------------------------------------------------------
31
327
  TControl.AdjustSize
32
328
 
51
347
    and (Parent=nil)
52
348
    and (Self is TCustomForm)
53
349
  then begin
54
 
    DebugLn(['TControl.Adjustsize ',DbgSName(Self)]);
 
350
    DebugLn(['TControl.AdjustSize ',DbgSName(Self)]);
55
351
  end;
56
352
  {$ENDIF}
57
353
  Include(FControlFlags, cfAutoSizeNeeded);
88
384
------------------------------------------------------------------------------}
89
385
procedure TControl.BeginAutoDrag;
90
386
begin
 
387
  {$IFDEF VerboseDrag}
91
388
  debugln(['TControl.BeginAutoDrag ',DbgSName(Self)]);
 
389
  {$ENDIF}
92
390
  BeginDrag(DragManager.DragImmediate, DragManager.DragThreshold);
93
391
end;
94
392
 
143
441
        alBottom: OffsetRect(ARect,0,NewDockSite.ClientHeight-ARect.Bottom);
144
442
      end;
145
443
    end;
146
 
    //DebugLn('TControl.DoDock AFTER Adjusting ',DbgSName(Self),' ',dbgs(ARect),' Align=',AlignNames[Align],' NewDockSite.ClientRect=',dbgs(NewDockSite.ClientRect));
 
444
    //DebugLn('TControl.DoDock AFTER Adjusting ',DbgSName(Self),' ',dbgs(ARect),' Align=',DbgS(Align),' NewDockSite.ClientRect=',dbgs(NewDockSite.ClientRect));
147
445
  end;
148
446
  //debugln('TControl.DoDock BEFORE MOVE ',Name,' BoundsRect=',dbgs(BoundsRect),' NewRect=',dbgs(ARect));
149
447
  if Parent<>NewDockSite then
283
581
procedure TControl.FontChanged(Sender: TObject);
284
582
begin
285
583
  FParentFont := False;
 
584
  FDesktopFont := False;
286
585
  Invalidate;
287
586
  Perform(CM_FONTCHANGED, 0, 0);
288
587
  if AutoSize then
299
598
 
300
599
procedure TControl.SetAction(Value: TBasicAction);
301
600
begin
302
 
  if (Value=Action) then exit;
303
601
  //debugln('TControl.SetAction A ',Name,':',ClassName,' Old=',DbgS(Action),' New=',DbgS(Value));
304
 
  if Value = nil then begin
 
602
  if Value = nil then
 
603
  begin
305
604
    ActionLink.Free;
306
 
    ActionLink:=nil;
 
605
    ActionLink := nil;
307
606
    Exclude(FControlStyle, csActionClient);
308
607
  end
309
608
  else
654
953
                  and (not (csNoDesignVisible in ControlStyle))));
655
954
end;
656
955
 
 
956
{------------------------------------------------------------------------------
 
957
  Method: TControl.IsEnabled
 
958
  Params:   none
 
959
  Returns:  Boolean
 
960
 
 
961
  Returns True only if both TControl and it's parent hierarchy are enabled.
 
962
  Used internally by TGraphicControls for painting and various states during
 
963
  runtime.
 
964
 ------------------------------------------------------------------------------}
 
965
function TControl.IsEnabled: Boolean;
 
966
var
 
967
  TheControl: TControl;
 
968
begin
 
969
  TheControl := Self;
 
970
  repeat
 
971
    Result := TheControl.Enabled;
 
972
    TheControl := TheControl.Parent;
 
973
  until (TheControl = nil) or (not Result);
 
974
end;
 
975
 
 
976
{------------------------------------------------------------------------------
 
977
  Method: TControl.IsParentColor
 
978
  Params:   none
 
979
  Returns:  Boolean
 
980
 
 
981
  Used at places where we need to check ParentColor property from TControl.
 
982
  Property is protected, so this function avoids hacking to get
 
983
  protected property value.
 
984
 ------------------------------------------------------------------------------}
 
985
function TControl.IsParentColor: Boolean;
 
986
begin
 
987
  Result := FParentColor;
 
988
end;
 
989
 
 
990
{------------------------------------------------------------------------------
 
991
  Method: TControl.IsParentFont
 
992
  Params:   none
 
993
  Returns:  Boolean
 
994
 
 
995
  Used at places where we need to check ParentFont property from TControl.
 
996
  Property is protected, so this function avoids hacking to get
 
997
  protected property value.
 
998
 ------------------------------------------------------------------------------}
 
999
function TControl.IsParentFont: Boolean;
 
1000
begin
 
1001
  Result := FParentFont;
 
1002
end;
 
1003
 
657
1004
function TControl.FormIsUpdating: boolean;
658
1005
begin
659
1006
  Result := Assigned(Parent) and Parent.FormIsUpdating;
754
1101
  TextChanged;
755
1102
end;
756
1103
 
757
 
procedure TControl.CMWantSpecialKey(var Message: TLMessage);
758
 
begin
759
 
  // by default control does not want to handle VK_TAB itself
760
 
  if Message.wParam = VK_TAB then
761
 
    Message.Result := 0
762
 
  else
763
 
    Message.Result := 1;
764
 
end;
765
 
 
766
1104
procedure TControl.CMCursorChanged(var Message: TLMessage);
767
1105
begin
768
1106
  if not (csDesigning in ComponentState) then
804
1142
end;
805
1143
 
806
1144
{------------------------------------------------------------------------------
807
 
       TControl.CMShowHintChanged
 
1145
       TControl.CMParentShowHintChanged
808
1146
 
809
1147
       assumes: FParent <> nil
810
1148
------------------------------------------------------------------------------}
947
1285
      Result := DefColors[DefaultColorType];
948
1286
end;
949
1287
 
 
1288
function TControl.GetColorResolvingParent: TColor;
 
1289
begin
 
1290
  if Color = clDefault then
 
1291
    Result := GetDefaultColor(dctBrush) // GetDefaultColor resolves the parent
 
1292
  else
 
1293
    Result := Color;
 
1294
end;
 
1295
 
 
1296
function TControl.GetRGBColorResolvingParent: TColor;
 
1297
begin
 
1298
  Result := ColorToRGB(GetColorResolvingParent());
 
1299
end;
 
1300
 
950
1301
{------------------------------------------------------------------------------
951
1302
       TControl.DoConstrainedResize
952
1303
------------------------------------------------------------------------------}
955
1306
var
956
1307
  MinWidth, MinHeight, MaxWidth, MaxHeight : TConstraintSize;
957
1308
begin
 
1309
  if NewWidth<0 then NewWidth:=0;
 
1310
  if NewHeight<0 then NewHeight:=0;
958
1311
  MinWidth := Constraints.EffectiveMinWidth;
959
1312
  MinHeight := Constraints.EffectiveMinHeight;
960
1313
  MaxWidth := Constraints.EffectiveMaxWidth;
1017
1370
procedure TControl.DoBorderSpacingChange(Sender: TObject;
1018
1371
  InnerSpaceChanged: Boolean);
1019
1372
begin
 
1373
  if Parent <> nil then Parent.InvalidatePreferredSize;
1020
1374
  AdjustSize;
1021
 
  if (csDesigning in ComponentState) and (Parent <> nil) then
1022
 
    Parent.Invalidate;
1023
1375
end;
1024
1376
 
1025
1377
function TControl.IsBorderSpacingInnerBorderStored: Boolean;
1028
1380
end;
1029
1381
 
1030
1382
{------------------------------------------------------------------------------
 
1383
  TControl IsCaptionStored
 
1384
------------------------------------------------------------------------------}
 
1385
function TControl.IsCaptionStored: Boolean;
 
1386
begin
 
1387
  Result := (ActionLink = nil) or not ActionLink.IsCaptionLinked;
 
1388
end;
 
1389
 
 
1390
{------------------------------------------------------------------------------
1031
1391
  procedure TControl.SendMoveSizeMessages(SizeChanged, PosChanged: boolean);
1032
1392
------------------------------------------------------------------------------}
1033
1393
procedure TControl.SendMoveSizeMessages(SizeChanged, PosChanged: boolean);
1144
1504
  Result.Y := APoint.Y + P.Y;
1145
1505
end;
1146
1506
 
 
1507
function TControl.ClientToParent(const Point: TPoint; AParent: TWinControl): TPoint;
 
1508
begin
 
1509
  if not Assigned(AParent) then
 
1510
    AParent := Parent;
 
1511
  if not AParent.IsParentOf(Self) then
 
1512
    raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]);
 
1513
  Result := AParent.ScreenToClient(ClientToScreen(Point));
 
1514
end;
 
1515
 
 
1516
function TControl.ParentToClient(const Point: TPoint; AParent: TWinControl): TPoint;
 
1517
begin
 
1518
  if not Assigned(AParent) then
 
1519
    AParent := Parent;
 
1520
  if not AParent.IsParentOf(Self) then
 
1521
    raise EInvalidOperation.CreateFmt(rsControlIsNotAParent, [AParent.Name, Name]);
 
1522
  Result := ScreenToClient(AParent.ClientToScreen(Point));
 
1523
end;
 
1524
 
1147
1525
{------------------------------------------------------------------------------
1148
1526
       TControl.DblClick
1149
1527
------------------------------------------------------------------------------}
1252
1630
  if Assigned(FOnDragDrop) then FOnDragDrop(Self, Source,X,Y);
1253
1631
end;
1254
1632
 
 
1633
procedure TControl.SetAccessibleDescription(AValue: TCaption);
 
1634
begin
 
1635
  FAccessibleObject.AccessibleDescription := AValue;
 
1636
end;
 
1637
 
 
1638
procedure TControl.SetAccessibleValue(AValue: TCaption);
 
1639
begin
 
1640
  FAccessibleObject.AccessibleValue := AValue;
 
1641
end;
 
1642
 
 
1643
procedure TControl.SetAccessibleRole(AValue: TLazAccessibilityRole);
 
1644
begin
 
1645
  FAccessibleObject.AccessibleRole := AValue;
 
1646
end;
 
1647
 
1255
1648
{------------------------------------------------------------------------------
1256
1649
  TControl Method SetColor  "Sets the default color and tells the widget set"
1257
1650
------------------------------------------------------------------------------}
1301
1694
  Result := DragManager.Dragging(Self);
1302
1695
end;
1303
1696
 
 
1697
// accessibility
 
1698
function TControl.GetAccessibleObject: TLazAccessibleObject;
 
1699
begin
 
1700
  Result := FAccessibleObject;
 
1701
end;
 
1702
 
 
1703
function TControl.CreateAccessibleObject: TLazAccessibleObject;
 
1704
begin
 
1705
  Result := TLazAccessibleObject.Create(Self);
 
1706
end;
 
1707
 
 
1708
function TControl.GetSelectedChildAccessibleObject: TLazAccessibleObject;
 
1709
begin
 
1710
  Result := nil;
 
1711
end;
 
1712
 
 
1713
function TControl.GetChildAccessibleObjectAtPos(APos: TPoint): TLazAccessibleObject;
 
1714
begin
 
1715
  Result := nil;
 
1716
end;
 
1717
 
1304
1718
{------------------------------------------------------------------------------
1305
1719
       TControl GetBoundsRect
1306
1720
------------------------------------------------------------------------------}
1386
1800
 
1387
1801
procedure TControl.VisibleChanged;
1388
1802
begin
1389
 
{ TODO -cdocking : For docked controls, the docking manager must receive a notification!
1390
 
 }
 
1803
{ TODO -cdocking : For docked controls, the docking manager must receive a notification! }
1391
1804
  DoCallNotifyHandler(chtOnVisibleChanged);
1392
1805
end;
1393
1806
 
 
1807
{------------------------------------------------------------------------------
 
1808
  procedure TControl.EnabledChanging;
 
1809
------------------------------------------------------------------------------}
 
1810
procedure TControl.EnabledChanging;
 
1811
begin
 
1812
  DoCallNotifyHandler(chtOnEnabledChanging);
 
1813
end;
 
1814
 
 
1815
procedure TControl.EnabledChanged;
 
1816
begin
 
1817
{ TODO -cdocking : For docked controls, the docking manager must receive a notification! }
 
1818
  DoCallNotifyHandler(chtOnEnabledChanged);
 
1819
end;
 
1820
 
1394
1821
procedure TControl.AddHandler(HandlerType: TControlHandlerType;
1395
1822
  const AMethod: TMethod; AsFirst: boolean);
1396
1823
begin
1414
1841
  procedure TControl.DoContextPopup(const MousePos: TPoint;
1415
1842
    var Handled: Boolean);
1416
1843
------------------------------------------------------------------------------}
1417
 
procedure TControl.DoContextPopup(const MousePos: TPoint; var Handled: Boolean);
 
1844
procedure TControl.DoContextPopup(MousePos: TPoint; var Handled: Boolean);
1418
1845
begin
1419
1846
  if Assigned(FOnContextPopup) then
1420
1847
    FOnContextPopup(Self, MousePos, Handled);
1426
1853
begin
1427
1854
  if Sender is TCustomAction then begin
1428
1855
    NewAction:=TCustomAction(Sender);
1429
 
    if (not CheckDefaults)
1430
 
    or (Caption = '') or (Caption = Name) then
 
1856
    if (not CheckDefaults) or (Caption = '') or (Caption = Name) then
1431
1857
      Caption := NewAction.Caption;
1432
1858
    if not CheckDefaults or Enabled then
1433
1859
      Enabled := NewAction.Enabled;
1450
1876
  if Sender = Action then ActionChange(Sender, False);
1451
1877
end;
1452
1878
 
 
1879
function TControl.GetAccessibleDescription: TCaption;
 
1880
begin
 
1881
  Result := FAccessibleObject.AccessibleDescription;
 
1882
end;
 
1883
 
 
1884
function TControl.GetAccessibleValue: TCaption;
 
1885
begin
 
1886
  Result := FAccessibleObject.AccessibleValue;
 
1887
end;
 
1888
 
 
1889
function TControl.GetAccessibleRole: TLazAccessibilityRole;
 
1890
begin
 
1891
  Result := FAccessibleObject.AccessibleRole;
 
1892
end;
 
1893
 
1453
1894
function TControl.CaptureMouseButtonsIsStored: boolean;
1454
1895
begin
1455
1896
  Result := FCaptureMouseButtons <> [mbLeft];
1460
1901
  Result:=FAnchorSides[Kind];
1461
1902
end;
1462
1903
 
1463
 
function TControl.GetAnchorSideIndex(Index: integer): TAnchorSide;
1464
 
begin
1465
 
  case Index of
1466
 
  0: Result:=FAnchorSides[akLeft];
1467
 
  1: Result:=FAnchorSides[akTop];
1468
 
  2: Result:=FAnchorSides[akRight];
1469
 
  3: Result:=FAnchorSides[akBottom];
1470
 
  else
1471
 
  Result:=nil;
1472
 
  end;
1473
 
end;
1474
 
 
1475
1904
function TControl.GetAnchoredControls(Index: integer): TControl;
1476
1905
begin
1477
1906
  Result := TControl(FAnchoredControls[Index]);
1590
2019
    // redirect messages to designer
1591
2020
    Form := GetParentForm(Self);
1592
2021
    //debugln(['TControl.WndProc ',dbgsname(Self)]);
1593
 
    if (Form <> nil) and (Form.Designer <> nil)
1594
 
    and Form.Designer.IsDesignMsg(Self,TheMessage) then begin
 
2022
    if Assigned(Form) and Assigned(Form.Designer) and Form.Designer.IsDesignMsg(Self, TheMessage) then
1595
2023
      Exit;
1596
 
    end;
1597
2024
  end
1598
2025
  else if (TheMessage.Msg >= LM_KEYFIRST) and (TheMessage.Msg <= LM_KEYLAST)
1599
2026
  then begin
1656
2083
              is sent immediately.
1657
2084
 
1658
2085
              Further Note:
1659
 
                Under winapi a  LM_LBUTTONDOWN ends the drag immediate.
 
2086
                Under winapi a LM_LBUTTONDOWN ends the drag immediate.
1660
2087
              For example: If we exit here, then mouse down on TTreeView does
1661
2088
                not work any longer under gtk.
1662
2089
            }
1781
2208
    FOnMouseWheelUp(Self, Shift, MousePos, Result);
1782
2209
end;
1783
2210
 
1784
 
procedure TControl.SetAnchorSideIndex(Index: integer; const AValue: TAnchorSide
1785
 
  );
 
2211
procedure TControl.SetAnchorSide(Kind: TAnchorKind; AValue: TAnchorSide);
1786
2212
begin
1787
 
  GetAnchorSideIndex(Index).Assign(AValue);
 
2213
  GetAnchorSide(Kind).Assign(AValue);
1788
2214
end;
1789
2215
 
1790
2216
procedure TControl.SetBorderSpacing(const AValue: TControlBorderSpacing);
2263
2689
procedure TControl.WMMouseWheel(var Message: TLMMouseEvent);
2264
2690
var
2265
2691
  MousePos: TPoint;
 
2692
  lState: TShiftState;
2266
2693
begin
2267
2694
  MousePos.X := Message.X;
2268
2695
  MousePos.Y := Message.Y;
2269
2696
 
2270
 
  if DoMouseWheel(Message.State, Message.WheelDelta, MousePos) then
 
2697
  lState := Message.State - [ssCaps, ssNum, ssScroll]; // Remove unreliable states, see http://bugs.freepascal.org/view.php?id=20065
 
2698
  if DoMouseWheel(lState, Message.WheelDelta, MousePos) then
2271
2699
    Message.Result := 1 // handled, skip further handling by interface
2272
2700
  else
2273
2701
    inherited;
2280
2708
procedure TControl.Click;
2281
2709
begin
2282
2710
  //DebugLn(['TControl.Click ',DbgSName(Self)]);
2283
 
  if (not (csDesigning in ComponentState)) and (ActionLink <> nil) and
2284
 
     ((Action=nil) or (@FOnClick <> @Action.OnExecute) or Assigned(FOnClick)) then
 
2711
  if Assigned(FOnClick) and (Action<>nil)
 
2712
  and (not CompareMethods(TMethod(Action.OnExecute),TMethod(FOnClick))) then
 
2713
    // the OnClick is set and differs from the Action => call the OnClick
 
2714
    FOnClick(Self)
 
2715
  else if (not (csDesigning in ComponentState)) and (ActionLink <> nil) then
2285
2716
    ActionLink.Execute(Self)
2286
 
  else
2287
 
  if Assigned(FOnClick) then
 
2717
  else if Assigned(FOnClick) then
2288
2718
    FOnClick(Self);
2289
2719
end;
2290
2720
 
2526
2956
          // no autosize for invisible controls
2527
2957
          or (not IsControlVisible)
2528
2958
          // if there is no parent, then this control is not visible
2529
 
          //  (TCustomForm will override this)
2530
 
          or not AutoSizeCheckParent
 
2959
          //  (TWinControl and TCustomForm override this)
 
2960
          or AutoSizeDelayedHandle
2531
2961
          // if there is a parent, ask it
2532
2962
          or ((Parent<>nil) and Parent.AutoSizeDelayed);
2533
2963
  {$IFDEF VerboseCanAutoSize}
2538
2968
    else if csDestroying in ComponentState then debugln('csDestroying')
2539
2969
    else if cfLoading in FControlFlags then debugln('cfLoading')
2540
2970
    else if not IsControlVisible then debugln('not IsControlVisible')
2541
 
    else if not AutoSizeCheckParent then debugln('not AutoSizeCheckParent')
 
2971
    else if AutoSizeDelayedHandle then debugln('AutoSizeDelayedHandle')
2542
2972
    else if ((Parent<>nil) and Parent.AutoSizeDelayed) then debugln('Parent.AutoSizeDelayed')
2543
2973
    else debugln('?');
2544
2974
  end;
2545
2975
  {$ENDIF}
2546
2976
end;
2547
2977
 
2548
 
function TControl.AutoSizeCheckParent: Boolean;
2549
 
begin
2550
 
  Result := Parent <> nil;
2551
 
end;
2552
 
 
2553
 
{------------------------------------------------------------------------------
2554
 
       TControl SetBoundsRect
 
2978
function TControl.AutoSizeDelayedReport: string;
 
2979
begin
 
2980
  if (FAutoSizingLockCount>0) then
 
2981
    Result:='FAutoSizingLockCount='+dbgs(FAutoSizingLockCount)
 
2982
  else if csLoading in ComponentState then
 
2983
    Result:='csLoading'
 
2984
  else if csDestroying in ComponentState then
 
2985
    Result:='csDestroying'
 
2986
  else if cfLoading in FControlFlags then
 
2987
    Result:='cfLoading'
 
2988
  else if IsControlVisible then
 
2989
    Result:='not IsControlVisible'
 
2990
  else if AutoSizeDelayedHandle then
 
2991
    Result:='AutoSizeDelayedHandle'
 
2992
  else if Parent<>nil then
 
2993
    Result:=Parent.AutoSizeDelayedReport
 
2994
  else
 
2995
    Result:='?';
 
2996
end;
 
2997
 
 
2998
{------------------------------------------------------------------------------
 
2999
  TControl AutoSizeDelayedHandle
 
3000
 
 
3001
  Returns true if AutoSize should be skipped / delayed because of its handle.
 
3002
  A TControl does not have a handle, so it needs a parent.
 
3003
------------------------------------------------------------------------------}
 
3004
function TControl.AutoSizeDelayedHandle: Boolean;
 
3005
begin
 
3006
  Result := Parent = nil;
 
3007
end;
 
3008
 
 
3009
{------------------------------------------------------------------------------
 
3010
  TControl SetBoundsRect
2555
3011
------------------------------------------------------------------------------}
2556
3012
procedure TControl.SetBoundsRect(const ARect: TRect);
2557
3013
begin
2664
3120
begin
2665
3121
  if FEnabled <> Value
2666
3122
  then begin
 
3123
    EnabledChanging;
2667
3124
    FEnabled := Value;
2668
3125
    Perform(CM_ENABLEDCHANGED, 0, 0);
 
3126
    EnabledChanged;
2669
3127
  end;
2670
3128
end;
2671
3129
 
2696
3154
begin
2697
3155
  if FHint = Value then exit;
2698
3156
  FHint := Value;
2699
 
 
2700
3157
end;
2701
3158
 
2702
3159
{------------------------------------------------------------------------------
2782
3239
function TControl.GetText: TCaption;
2783
3240
var
2784
3241
  len: Integer;
 
3242
  GetTextMethod: TMethod;
2785
3243
begin
2786
 
  // Check if GetTextBuf is overridden, otherwise
2787
 
  // we can call RealGetText directly
2788
 
  if TMethod(@Self.GetTextBuf).Code = Pointer(@TControl.GetTextBuf)
2789
 
  then begin
 
3244
  // Check if GetTextBuf is overridden, otherwise we can call RealGetText directly
 
3245
  Assert(Assigned(@Self.GetTextBuf), 'TControl.GetText: GetTextBuf Method is Nil');
 
3246
  GetTextMethod := TMethod(@Self.GetTextBuf);
 
3247
  if GetTextMethod.Code = Pointer(@TControl.GetTextBuf) then begin
2790
3248
    Result := RealGetText;
2791
3249
  end
2792
3250
  else begin
2793
3251
    // Bummer, we have to do it the compatible way.
2794
3252
    DebugLn('Note: GetTextBuf is overridden for: ', Classname);
2795
 
    
2796
3253
    len := GetTextLen;
2797
 
    if len = 0 
2798
 
    then begin
 
3254
    if len = 0 then begin
2799
3255
      Result := '';
2800
3256
    end
2801
3257
    else begin
2833
3289
  Result := TControlActionLink;
2834
3290
end;
2835
3291
 
2836
 
{------------------------------------------------------------------------------
2837
 
  TControl IsCaptionStored
2838
 
------------------------------------------------------------------------------}
2839
 
function TControl.IsCaptionStored: Boolean;
2840
 
begin
2841
 
  Result := (ActionLink = nil) or not ActionLink.IsCaptionLinked;
2842
 
end;
2843
 
 
2844
3292
function TControl.IsClientHeightStored: Boolean;
2845
3293
begin
2846
3294
  Result:=false;
2905
3353
procedure TControl.InvalidateControl(CtrlIsVisible, CtrlIsOpaque: Boolean);
2906
3354
var
2907
3355
  Rect: TRect;
2908
 
  Pt: TPoint;
2909
3356
 
2910
3357
  function BackgroundClipped: Boolean;
2911
3358
  var
2941
3388
  then exit;
2942
3389
  // Note: it should invalidate, when this control is loaded/destroyed, but parent not
2943
3390
 
2944
 
  if (CtrlIsVisible or ((csDesigning in ComponentState)
2945
 
  and not (csNoDesignVisible in ControlStyle)))
2946
 
  then begin
2947
 
    Pt := Parent.GetClientScrollOffset;
 
3391
  if (CtrlIsVisible or ((csDesigning in ComponentState) and
 
3392
    not (csNoDesignVisible in ControlStyle))) then
 
3393
  begin
2948
3394
    Rect := BoundsRect;
2949
 
    OffsetRect(Rect, -Pt.X, -Pt.Y);
2950
3395
    InvalidateRect(Parent.Handle, @Rect, not (CtrlIsOpaque or
2951
3396
      (csOpaque in Parent.ControlStyle) or BackgroundClipped));
2952
3397
  end;
3016
3461
  if (FLastResizeWidth<>Width) or (FLastResizeHeight<>Height)
3017
3462
  or (FLastResizeClientWidth<>ClientWidth)
3018
3463
  or (FLastResizeClientHeight<>ClientHeight) then begin
3019
 
    //if AnsiCompareText('NOTEBOOK',Name)=0 then
3020
 
    {DebugLn(['[TControl.Resize] ',Name,':',ClassName,
3021
 
    ' Last=',FLastResizeWidth,',',FLastResizeHeight,
3022
 
    ' LastClient=',FLastResizeClientWidth,',',FLastResizeClientHeight,
3023
 
    ' New=',Width,',',Height,
3024
 
    ' NewClient=',ClientWidth,',',ClientHeight]);}
 
3464
    {if CompareText('SubPanel',Name)=0 then begin
 
3465
      DebugLn(['[TControl.Resize] ',Name,':',ClassName,
 
3466
      ' Last=',FLastResizeWidth,',',FLastResizeHeight,
 
3467
      ' LastClient=',FLastResizeClientWidth,',',FLastResizeClientHeight,
 
3468
      ' New=',Width,',',Height,
 
3469
      ' NewClient=',ClientWidth,',',ClientHeight]);
 
3470
      DumpStack;
 
3471
    end;}
3025
3472
    FLastResizeWidth:=Width;
3026
3473
    FLastResizeHeight:=Height;
3027
3474
    FLastResizeClientWidth:=ClientWidth;
3186
3633
 
3187
3634
procedure TControl.ReadState(Reader: TReader);
3188
3635
begin
3189
 
  Include(FControlFlags,cfLoading);
 
3636
  Include(FControlFlags, cfLoading);
3190
3637
  DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReadState'){$ENDIF};
3191
3638
  try
 
3639
    Include(FControlState, csReadingState);
3192
3640
    inherited ReadState(Reader);
3193
3641
  finally
 
3642
    Exclude(FControlState, csReadingState);
3194
3643
    EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.ReadState'){$ENDIF};
3195
3644
  end;
3196
3645
end;
3218
3667
  FConstraints.Assign(Value);
3219
3668
end;
3220
3669
 
 
3670
procedure TControl.SetDesktopFont(const AValue: Boolean);
 
3671
begin
 
3672
  if FDesktopFont <> AValue then
 
3673
  begin
 
3674
    FDesktopFont := AValue;
 
3675
    Perform(CM_SYSFONTCHANGED, 0, 0);
 
3676
  end;
 
3677
end;
 
3678
 
3221
3679
{------------------------------------------------------------------------------
3222
3680
  TControl SetAlign
3223
3681
------------------------------------------------------------------------------}
3225
3683
var
3226
3684
  OldAlign: TAlign;
3227
3685
  a: TAnchorKind;
 
3686
  OldBaseBounds: TRect;
3228
3687
begin
3229
3688
  if FAlign = Value then exit;
3230
 
  //DebugLn(['TControl.SetAlign ',DbgSName(Self),' Old=',AlignNames[FAlign],' New=',AlignNames[Value],' ',Anchors<>AnchorAlign[FAlign]]);
 
3689
  //DebugLn(['TControl.SetAlign ',DbgSName(Self),' Old=',DbgS(FAlign),' New=',DbgS(Value),' ',Anchors<>AnchorAlign[FAlign]]);
 
3690
  DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.setalign'){$ENDIF};
 
3691
  OldBaseBounds:=BaseBounds;
3231
3692
  OldAlign := FAlign;
3232
3693
  FAlign := Value;
3233
 
  for a:=low(TAnchorKind) to High(TAnchorKind) do
3234
 
  begin
3235
 
    if not (a in AnchorAlign[FAlign]) then continue;
3236
 
    AnchorSide[a].Control:=nil;
3237
 
    AnchorSide[a].Side:=asrTop;
 
3694
  if (not (csLoading in ComponentState))
 
3695
  and (Align in [alLeft,alTop,alRight,alBottom,alClient]) then begin
 
3696
    // Align for alLeft,alTop,alRight,alBottom,alClient takes precedence
 
3697
    // over AnchorSides => clean up
 
3698
    for a:=low(TAnchorKind) to High(TAnchorKind) do
 
3699
    begin
 
3700
      if not (a in AnchorAlign[FAlign]) then continue;
 
3701
      AnchorSide[a].Control:=nil;
 
3702
      AnchorSide[a].Side:=asrTop;
 
3703
    end;
3238
3704
  end;
3239
 
  // if anchors were on default then change them to new default
3240
 
  // This is done for Delphi compatibility.
 
3705
  // Notes:
 
3706
  // - if anchors had default values then change them to new default values
 
3707
  //   This is done for Delphi compatibility.
 
3708
  // - Anchors are not stored if they are AnchorAlign[Align]
3241
3709
  if (Anchors = AnchorAlign[OldAlign]) and (Anchors <> AnchorAlign[FAlign]) then
3242
 
    Anchors := AnchorAlign[FAlign]
3243
 
  else
3244
 
    RequestAlign;
 
3710
    Anchors := AnchorAlign[FAlign];
 
3711
  if not (csLoading in ComponentState) then
 
3712
    BoundsRect:=OldBaseBounds;
 
3713
  //DebugLn(['TControl.SetAlign ',DbgSName(Self),' Cur=',DbgS(FAlign),' New=',DbgS(Value),' ',Anchors<>AnchorAlign[FAlign],' Anchors=',dbgs(Anchors)]);
 
3714
  EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.setalign'){$ENDIF};
3245
3715
end;
3246
3716
 
3247
3717
{------------------------------------------------------------------------------
3258
3728
  for a:=Low(TAnchorKind) to high(TAnchorKind) do
3259
3729
    if (a in NewAnchors) and (AnchorSide[a].Side=asrCenter) then
3260
3730
      AnchorSide[a].FixCenterAnchoring;
 
3731
 
 
3732
  // Delphi Anchors depend on the current bounds of Self and Parent.ClientRect
 
3733
  // => fetch current BaseBounds
 
3734
  // for example:
 
3735
  // during disabled autosizing:  Width:=100; Anchors:=Anchors+[akRight];
 
3736
  UpdateAnchorRules;
 
3737
 
3261
3738
  AdjustSize;
3262
3739
end;
3263
3740
 
3295
3772
      NewBaseParentClientSize:=Size(0,0);
3296
3773
  end else
3297
3774
    NewBaseParentClientSize:=FBaseParentClientSize;
3298
 
  if CompareRect(@NewBaseBounds,@FBaseBounds)
3299
 
  and (NewBaseParentClientSize.cx=FBaseParentClientSize.cx)
3300
 
  and (NewBaseParentClientSize.cy=FBaseParentClientSize.cy)
3301
 
  then exit;
3302
 
  //if csDesigning in ComponentState then
3303
 
  {$IFDEF CHECK_POSITION}
3304
 
  if CheckPosition(Self) then
3305
 
    DebugLn(['TControl.UpdateBaseBounds '+DbgSName(Self),
3306
 
    ' OldBounds='+dbgs(FBaseBounds),
3307
 
    ' OldParentClientSize='+dbgs(FBaseParentClientSize),
3308
 
    ' NewBounds='+dbgs(NewBaseBounds),
3309
 
    ' NewParentClientSize='+dbgs(NewBaseParentClientSize),
3310
 
    '']);
3311
 
  {$ENDIF}
3312
 
  FBaseBounds:=NewBaseBounds;
 
3775
 
 
3776
  if (not CompareRect(@NewBaseBounds,@FBaseBounds))
 
3777
  or (NewBaseParentClientSize.cx<>FBaseParentClientSize.cx)
 
3778
  or (NewBaseParentClientSize.cy<>FBaseParentClientSize.cy)
 
3779
  then begin
 
3780
    //if csDesigning in ComponentState then
 
3781
    {$IFDEF CHECK_POSITION}
 
3782
    if CheckPosition(Self) then
 
3783
      DebugLn(['TControl.UpdateBaseBounds '+DbgSName(Self),
 
3784
      ' OldBounds='+dbgs(FBaseBounds),
 
3785
      ' OldParentClientSize='+dbgs(FBaseParentClientSize),
 
3786
      ' NewBounds='+dbgs(NewBaseBounds),
 
3787
      ' NewParentClientSize='+dbgs(NewBaseParentClientSize),
 
3788
      '']);
 
3789
    {$ENDIF}
 
3790
 
 
3791
    FBaseBounds:=NewBaseBounds;
 
3792
    FBaseParentClientSize:=NewBaseParentClientSize;
 
3793
  end;
3313
3794
  Include(FControlFlags,cfBaseBoundsValid);
3314
 
  FBaseParentClientSize:=NewBaseParentClientSize;
3315
3795
end;
3316
3796
 
3317
3797
procedure TControl.WriteLayoutDebugReport(const Prefix: string);
3322
3802
  DbgOut(Prefix,'TControl.WriteLayoutDebugReport ');
3323
3803
  DbgOut(DbgSName(Self),' Bounds=',dbgs(BoundsRect));
3324
3804
  if Align<>alNone then
3325
 
    DbgOut(' Align=',AlignNames[Align]);
 
3805
    DbgOut(' Align=',DbgS(Align));
3326
3806
  DbgOut(' Anchors=[');
3327
3807
  NeedSeparator:=false;
3328
3808
  for a:=Low(TAnchorKind) to High(TAnchorKind) do begin
3339
3819
  DebugLn;
3340
3820
end;
3341
3821
 
 
3822
procedure TControl.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
 
3823
  const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer);
 
3824
var
 
3825
  lXProportion, lYProportion: Double;
 
3826
  NewLeft, NewTop, NewHeight, NewWidth: Integer;
 
3827
  lMode: TLayoutAdjustmentPolicy;
 
3828
begin
 
3829
  // First resolve ladDefault
 
3830
  lMode := AMode;
 
3831
  if lMode = lapDefault then lMode := Application.LayoutAdjustmentPolicy;
 
3832
 
 
3833
  // X-axis adjustment proportion
 
3834
  if lMode = lapAutoAdjustWithoutHorizontalScrolling then
 
3835
  begin
 
3836
    if AOldFormWidth > 0 then lXProportion := ANewFormWidth / AOldFormWidth
 
3837
    else lXProportion := 1.0;
 
3838
  end
 
3839
  else if lMode = lapAutoAdjustForDPI then
 
3840
  begin
 
3841
    if AFromDPI > 0 then lXProportion := AToDPI / AFromDPI
 
3842
    else lXProportion := 1.0;
 
3843
  end;
 
3844
 
 
3845
  // y-axis adjustment proportion
 
3846
  if AFromDPI > 0 then lYProportion := AToDPI / AFromDPI
 
3847
  else lYProportion := 1.0;
 
3848
 
 
3849
  // Apply the changes
 
3850
  if (lMode = lapAutoAdjustWithoutHorizontalScrolling) or
 
3851
   (lMode = lapAutoAdjustForDPI) then
 
3852
  begin
 
3853
    if ShouldAutoAdjustLeftAndTop then
 
3854
    begin
 
3855
      NewLeft := Round(Left * lXProportion);
 
3856
      NewTop := Round(Top * lYProportion);
 
3857
    end
 
3858
    else
 
3859
    begin
 
3860
      NewLeft := Left;
 
3861
      NewTop := Top;
 
3862
    end;
 
3863
    if ShouldAutoAdjustWidthAndHeight then
 
3864
    begin
 
3865
      NewWidth := Round(Width * lXProportion);
 
3866
      NewHeight := Round(Height * lYProportion);
 
3867
    end
 
3868
    else
 
3869
    begin
 
3870
      // Give a shake at the autosize to recalculate font sizes for example
 
3871
      if AutoSize then AdjustSize();
 
3872
      NewWidth := Width;
 
3873
      NewHeight := Height;
 
3874
    end;
 
3875
    SetBounds(NewLeft, NewTop, NewWidth, NewHeight);
 
3876
  end;
 
3877
end;
 
3878
 
 
3879
// The layout should only be auto-adjusted for controls with the most simple
 
3880
// default absolute positioning
 
3881
function TControl.ShouldAutoAdjustLeftAndTop: Boolean;
 
3882
begin
 
3883
  Result := (Align = alNone) and (Anchors = [akTop, akLeft]) and (Parent <> nil);
 
3884
end;
 
3885
 
 
3886
function TControl.ShouldAutoAdjustWidthAndHeight: Boolean;
 
3887
begin
 
3888
  Result := (Align = alNone) and (Anchors = [akTop, akLeft]) and (AutoSize = False);
 
3889
end;
 
3890
 
3342
3891
procedure TControl.UpdateAnchorRules;
3343
3892
begin
3344
3893
  UpdateBaseBounds(true,true,false);
3707
4256
        else
3708
4257
          AsWincontrol := nil;
3709
4258
        InvalidatePreferredSize;
3710
 
        if AsWincontrol <> nil then
 
4259
        if Assigned(AsWincontrol) then
3711
4260
          AsWincontrol.InvalidatePreferredChildSizes;
3712
4261
        AdjustSize;
3713
 
        if (not Visible) and (Parent<>nil) then
 
4262
        if (not Visible) and Assigned(Parent) then
3714
4263
        begin
3715
4264
          // control became invisible, so AdjustSize was not propagated
3716
 
          // propagate
 
4265
          // => propagate now
3717
4266
          Parent.InvalidatePreferredSize;
3718
4267
          Parent.AdjustSize;
3719
4268
        end;
3751
4300
------------------------------------------------------------------------------}
3752
4301
function TControl.HandleObjectShouldBeVisible: boolean;
3753
4302
begin
3754
 
  Result := (not (csDestroying in ComponentState)) and IsControlVisible;
 
4303
  Result := not ((csDestroying in ComponentState) or (csDestroyingHandle in FControlState)) and IsControlVisible;
3755
4304
  if Result and Assigned(Parent) then
3756
4305
    Result := Parent.HandleObjectShouldBeVisible;
3757
4306
  //DebugLn(['TControl.HandleObjectShouldBeVisible ',DbgSName(Self),' ',Result]);
4089
4638
  RemoveHandler(chtOnVisibleChanged,TMethod(OnVisibleChangedEvent));
4090
4639
end;
4091
4640
 
 
4641
procedure TControl.AddHandlerOnEnabledChanged(
 
4642
  const OnEnabledChangedEvent: TNotifyEvent; AsFirst: boolean);
 
4643
begin
 
4644
  AddHandler(chtOnEnabledChanged,TMethod(OnEnabledChangedEvent),AsFirst);
 
4645
end;
 
4646
 
 
4647
procedure TControl.RemoveHandlerOnEnableChanging(
 
4648
  const OnEnableChangingEvent: TNotifyEvent);
 
4649
begin
 
4650
  RemoveHandler(chtOnEnabledChanged,TMethod(OnEnableChangingEvent));
 
4651
end;
 
4652
 
4092
4653
procedure TControl.AddHandlerOnKeyDown(const OnKeyDownEvent: TKeyEvent;
4093
4654
  AsFirst: boolean);
4094
4655
begin
4100
4661
  RemoveHandler(chtOnKeyDown,TMethod(OnKeyDownEvent));
4101
4662
end;
4102
4663
 
 
4664
procedure TControl.AddHandlerOnBeforeDestruction(
 
4665
  const OnBeforeDestructionEvent: TNotifyEvent; AsFirst: boolean);
 
4666
begin
 
4667
  AddHandler(chtOnBeforeDestruction,TMethod(OnBeforeDestructionEvent));
 
4668
end;
 
4669
 
 
4670
procedure TControl.RemoveHandlerOnBeforeDestruction(
 
4671
  const OnBeforeDestructionEvent: TNotifyEvent);
 
4672
begin
 
4673
  RemoveHandler(chtOnBeforeDestruction,TMethod(OnBeforeDestructionEvent));
 
4674
end;
 
4675
 
4103
4676
procedure TControl.RemoveAllHandlersOfObject(AnObject: TObject);
4104
4677
var
4105
4678
  HandlerType: TControlHandlerType;
4215
4788
  //DebugLn('[TControl.Destroy] A ',Name,':',ClassName);
4216
4789
  // make sure the capture is released
4217
4790
  MouseCapture := False;
 
4791
  // explicit notification about component destruction. this can be a drag target
 
4792
  DragManager.Notification(Self, opRemove);
4218
4793
  Application.ControlDestroyed(Self);
4219
4794
  if (FHostDockSite <> nil) and not (csDestroying in FHostDockSite.ComponentState) then
4220
4795
  begin
4222
4797
    SetParent(nil);
4223
4798
    Dock(nil, BoundsRect);
4224
4799
    FHostDockSite := nil;
4225
 
  end else begin
4226
 
    if (FHostDockSite<>nil) and (FHostDockSite.FDockClients<>nil) then begin
 
4800
  end else
 
4801
  begin
 
4802
    if Assigned(FHostDockSite) and Assigned(FHostDockSite.FDockClients) then
 
4803
    begin
4227
4804
      FHostDockSite.FDockClients.Remove(Self);
4228
 
      FHostDockSite:=nil;
 
4805
      FHostDockSite := nil;
4229
4806
    end;
4230
4807
    SetParent(nil);
4231
4808
  end;
4246
4823
  FreeThenNil(FBorderSpacing);
4247
4824
  FreeThenNil(FConstraints);
4248
4825
  FreeThenNil(FFont);
 
4826
  FreeThenNil(FAccessibleObject);
4249
4827
  //DebugLn('[TControl.Destroy] B ',DbgSName(Self));
4250
4828
  inherited Destroy;
4251
4829
  //DebugLn('[TControl.Destroy] END ',DbgSName(Self));
4256
4834
  {$ENDIF}
4257
4835
end;
4258
4836
 
 
4837
procedure TControl.BeforeDestruction;
 
4838
begin
 
4839
  inherited BeforeDestruction;
 
4840
  DoCallNotifyHandler(chtOnBeforeDestruction);
 
4841
end;
 
4842
 
4259
4843
{------------------------------------------------------------------------------
4260
4844
  Method: TControl.Create
4261
4845
  Params:  None
4276
4860
    // no csOpaque: delphi compatible, win32 themes notebook depend on it
4277
4861
    // csOpaque means entire client area will be drawn
4278
4862
    // (most controls are semi-transparent)
 
4863
    FAccessibleObject := CreateAccessibleObject();
4279
4864
    FControlStyle := FControlStyle
4280
4865
                   +[csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks];
4281
4866
    FConstraints:= TSizeConstraints.Create(Self);
4292
4877
    FParentBidiMode := True;
4293
4878
    FParentColor := True;
4294
4879
    FParentFont := True;
 
4880
    FDesktopFont := True;
4295
4881
    FParentShowHint := True;
4296
4882
    FWindowProc := @WndProc;
4297
4883
    FCursor := crDefault;
4362
4948
 ------------------------------------------------------------------------------}
4363
4949
function TControl.IsParentOf(AControl: TControl): boolean;
4364
4950
begin
4365
 
  Result:=false;
4366
 
  while AControl<>nil do begin
4367
 
    AControl:=AControl.Parent;
4368
 
    if Self=AControl then begin
4369
 
      Result:=true;
4370
 
      exit;
4371
 
    end;
 
4951
  Result := False;
 
4952
  while Assigned(AControl) do
 
4953
  begin
 
4954
    AControl := AControl.Parent;
 
4955
    if Self = AControl then
 
4956
      Exit(True);
4372
4957
  end;
4373
4958
end;
4374
4959
 
4375
4960
function TControl.GetTopParent: TControl;
4376
4961
begin
4377
 
  Result:=Self;
4378
 
  while Result.Parent<>nil do
4379
 
    Result:=Result.Parent;
 
4962
  Result := Self;
 
4963
  while Assigned(Result.Parent) do
 
4964
    Result := Result.Parent;
4380
4965
end;
4381
4966
 
4382
4967
{------------------------------------------------------------------------------
4893
5478
  if CheckPosition(Self) then
4894
5479
  DebugLn('[TControl.WMSize] Name=',Name,':',ClassName,' Message.Width=',DbgS(Message.Width),' Message.Height=',DbgS(Message.Height),' Width=',DbgS(Width),' Height=',DbgS(Height));
4895
5480
  {$ENDIF}
4896
 
  //Assert(False, Format('Trace:[TWinControl.WMSize] %s', [ClassName]));
 
5481
  //DebugLn(Format('Trace:[TWinControl.WMSize] %s', [ClassName]));
4897
5482
 
4898
 
  if Parent<>nil then
 
5483
  if Assigned(Parent) then
4899
5484
    SetBoundsKeepBase(Left,Top,Message.Width,Message.Height)
4900
5485
  else
4901
5486
    SetBounds(Left,Top,Message.Width,Message.Height);
4917
5502
  DebugLn('[TControl.WMMove] Name=',Name,':',ClassName,' Message.XPos=',DbgS(Message.XPos),' Message.YPos=',DbgS(Message.YPos),' OldLeft=',DbgS(Left),' OldTop=',DbgS(Top));
4918
5503
  {$ENDIF}
4919
5504
  // Just sync the coordinates
4920
 
  if Parent<>nil then
 
5505
  if Assigned(Parent) then
4921
5506
    SetBoundsKeepBase(Message.XPos, Message.YPos, Width, Height)
4922
5507
  else
4923
5508
    SetBounds(Message.XPos, Message.YPos, Width, Height);
4962
5547
    Invalidate;
4963
5548
end;
4964
5549
 
 
5550
procedure TControl.CMSysFontChanged(var Message: TLMessage);
 
5551
begin
 
5552
  if FDesktopFont then
 
5553
  begin
 
5554
    Font := Screen.SystemFont;
 
5555
    FDesktopFont := True;
 
5556
  end;
 
5557
end;
 
5558
 
4965
5559
{------------------------------------------------------------------------------
4966
5560
       TControl.CMParentBidiModeChanged
4967
5561