← Back to branch summary

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

« back to all changes in this revision

Viewing changes to lcl/interfaces/customdrawn/customdrawnproc.pas

  • 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/interfaces/customdrawn/customdrawnproc.pas
 
1
unit customdrawnproc;
 
2
 
 
3
{$mode objfpc}{$H+}
 
4
{$include customdrawndefines.inc}
 
5
 
 
6
interface
 
7
 
 
8
uses
 
9
  // rtl+ftl
 
10
  Types, Classes, SysUtils,
 
11
  fpimage, fpcanvas, Math,
 
12
  // LazUtils
 
13
  fileutil,
 
14
  {$ifndef CD_UseNativeText}
 
15
  // LazFreeType
 
16
  TTTypes, LazFreeTypeIntfDrawer, LazFreeType, EasyLazFreeType, IniFiles,
 
17
  {$endif}
 
18
  // Custom Drawn Canvas
 
19
  IntfGraphics, lazcanvas, lazregions, customdrawndrawers, customdrawncontrols,
 
20
  // LCL
 
21
  GraphType, Controls, LCLMessageGlue, WSControls, LCLType, LCLProc,
 
22
  StdCtrls, ExtCtrls, Forms, Graphics, ComCtrls,
 
23
  InterfaceBase, LCLIntf;
 
24
 
 
25
type
 
26
  TUpdateLazImageFormat = (
 
27
    clfRGB16_R5G6B5,
 
28
    clfRGB24, clfRGB24UpsideDown, clfBGR24,
 
29
    clfBGRA32, clfRGBA32, clfARGB32);
 
30
 
 
31
  { TCDBaseControl }
 
32
 
 
33
  TCDBaseControl = class
 
34
  private
 
35
    FProps: TStringList;
 
36
    function GetProps(AnIndex: String): pointer;
 
37
    procedure SetProps(AnIndex: String; AValue: pointer);
 
38
  protected
 
39
    FWinControl: TWinControl;
 
40
  public
 
41
    Children: TFPList; // of TCDWinControl;
 
42
    // For scrolling a control
 
43
    // The initial values are x=0, y=0 After scrolling downwards (by dragging upwards)
 
44
    // it will be for example x=0, y=+27
 
45
    ScrollX, ScrollY: Integer;
 
46
    LastMousePos: TPoint;
 
47
    IsScrolling: Boolean;
 
48
    // Counter to keep track of when we requested Invalidate
 
49
    // Some systems like X11 and Win32 will keep sending unnecessary paint messages
 
50
    // so for them we just throw the previously painted image
 
51
    InvalidateCount: Integer;
 
52
    // painting objects
 
53
    ControlImage: TLazIntfImage;
 
54
    ControlCanvas: TLazCanvas;
 
55
    constructor Create; virtual;
 
56
    destructor Destroy; override;
 
57
    procedure IncInvalidateCount;
 
58
    function AdjustCoordinatesForScrolling(AX, AY: Integer): TPoint;
 
59
    procedure UpdateImageAndCanvas; virtual;
 
60
    function IsControlBackgroundVisible: Boolean; virtual;
 
61
    property Props[AnIndex:String]:pointer read GetProps write SetProps;
 
62
  end;
 
63
 
 
64
  { TCDWinControl }
 
65
 
 
66
  TCDWinControl = class(TCDBaseControl)
 
67
  public
 
68
    Region: TLazRegionWithChilds;
 
69
    WinControl: TWinControl;
 
70
    CDControl: TCDControl;
 
71
    CDControlInjected: Boolean;
 
72
    procedure UpdateImageAndCanvas; override;
 
73
    function IsControlBackgroundVisible: Boolean; override;
 
74
  end;
 
75
 
 
76
  { TCDForm }
 
77
 
 
78
  TCDForm = class(TCDBaseControl)
 
79
  public
 
80
    LCLForm: TCustomForm;
 
81
    NativeHandle: HWND;
 
82
    //
 
83
    LastMouseDownControl: TWinControl; // Stores the control which should receive the next MouseUp
 
84
    FocusedControl: TWinControl; // The control focused in the form
 
85
    FocusedIntfControl: TWinControl; // The intf control focused in the form
 
86
    LayoutAutoAdjusted: Boolean; // Indicates if the form layout was already auto-adjusted once
 
87
    // For merging invalidate requests, currently utilized in X11
 
88
    InvalidateRequestedInAnyControl: Boolean;
 
89
    // painting objects which represent the composed form image, don't confuse with ControlImage/ControlCanvas
 
90
    Image: TLazIntfImage;
 
91
    Canvas: TLazCanvas;
 
92
    constructor Create; virtual;
 
93
    function GetFocusedControl: TWinControl;
 
94
    function GetFormVirtualHeight(AScreenHeight: Integer): Integer;
 
95
    procedure SanityCheckScrollPos();
 
96
    procedure UpdateImageAndCanvas; override;
 
97
    function IsControlBackgroundVisible: Boolean; override;
 
98
  end;
 
99
 
 
100
  TCDNonNativeForm = class(TCDForm)
 
101
  public
 
102
    Visible: Boolean;
 
103
  end;
 
104
 
 
105
  { TCDBitmap }
 
106
 
 
107
  TCDBitmap = class
 
108
  public
 
109
    Image: TLazIntfImage;
 
110
    destructor Destroy; override;
 
111
  end;
 
112
 
 
113
  TCDTimer = class
 
114
  public
 
115
    NativeHandle: PtrInt; // The X11 timer uses this to store the current time which is summed up to the next interval
 
116
    Interval: integer;
 
117
    TimerFunc: TWSTimerProc;
 
118
  end;
 
119
 
 
120
// Routines for form managing (both native and non-native)
 
121
 
 
122
procedure AddCDWinControlToForm(const AForm: TCustomForm; ACDWinControl: TCDWinControl);
 
123
function GetCDWinControlList(const AForm: TCustomForm): TFPList;
 
124
 
 
125
// Routines for non-native form managing
 
126
procedure InitNonNativeForms();
 
127
function GetCurrentForm(): TCDNonNativeForm;
 
128
function GetForm(AIndex: Integer): TCDNonNativeForm;
 
129
function GetFormCount(): Integer;
 
130
function AddNewForm(AForm: TCustomForm): TCDNonNativeForm;
 
131
procedure AddFormWithCDHandle(AHandle: TCDForm);
 
132
function FindFormWithNativeHandle(AHandle: HWND): TCDForm;
 
133
procedure ShowForm(ACDForm: TCDNonNativeForm);
 
134
procedure HideForm(ACDForm: TCDNonNativeForm);
 
135
procedure BringFormToFront(ACDForm: TCDNonNativeForm);
 
136
procedure SendFormToBack(ACDForm: TCDNonNativeForm);
 
137
function FindTopMostVisibleForm: TCDNonNativeForm;
 
138
 
 
139
// Routines for non-native wincontrol
 
140
 
 
141
procedure UpdateControlLazImageAndCanvas(var AImage: TLazIntfImage;
 
142
  var ACanvas: TLazCanvas; AWidth, AHeight: Integer; AFormat: TUpdateLazImageFormat;
 
143
  AData: Pointer = nil; AForceUpdate: Boolean = False;
 
144
  AFreeImageOnUpdate: Boolean = True; ADataOwner: Boolean = True);
 
145
procedure DrawFormBackground(var AImage: TLazIntfImage; var ACanvas: TLazCanvas);
 
146
procedure RenderChildWinControls(var AImage: TLazIntfImage;
 
147
  var ACanvas: TLazCanvas; ACDControlsList: TFPList; ACDForm: TCDForm);
 
148
function RenderWinControl(var AImage: TLazIntfImage;
 
149
  var ACanvas: TLazCanvas; ACDWinControl: TCDWinControl; ACDForm: TCDForm): Boolean;
 
150
procedure RenderWinControlAndChildren(var AImage: TLazIntfImage;
 
151
  var ACanvas: TLazCanvas; ACDWinControl: TCDWinControl; ACDForm: TCDForm);
 
152
procedure RenderForm(var AImage: TLazIntfImage;
 
153
  var ACanvas: TLazCanvas; AForm: TCustomForm);
 
154
function FindControlWhichReceivedEvent(AForm: TCustomForm;
 
155
  AControlsList: TFPList; AX, AY: Integer): TWinControl;
 
156
function FindControlPositionRelativeToTheForm(ALCLControl: TWinControl; AConsiderScrolling: Boolean = False): TPoint;
 
157
function FormPosToControlPos(ALCLControl: TWinControl; AX, AY: Integer): TPoint;
 
158
 
 
159
// Other routines
 
160
 
 
161
function DateTimeToMilliseconds(aDateTime: TDateTime): Int64;
 
162
function IsValidDC(ADC: HDC): Boolean;
 
163
function IsValidGDIObject(AGDIObj: HGDIOBJ): Boolean;
 
164
function IsValidBitmap(ABitmap: HBITMAP): Boolean;
 
165
function RemoveAccelChars(AStr: string): string;
 
166
 
 
167
// Timers list management (for platforms that need it)
 
168
 
 
169
procedure InitTimersList();
 
170
procedure AddTimer(ATimer: TCDTimer);
 
171
function GetTimer(AIndex: Integer): TCDTimer;
 
172
function GetTimerCount(): Integer;
 
173
function GetSmallestTimerInterval(): Integer;
 
174
procedure RemoveTimer(ATimer: TCDTimer);
 
175
function FindTimerWithNativeHandle(ANativeHandle: PtrInt): TCDTimer;
 
176
 
 
177
// Font choosing routines
 
178
 
 
179
{$ifndef CD_UseNativeText}
 
180
procedure VerifyAndCleanUpFontDirectories(AFontDirectories: TStringList);
 
181
procedure FontsScanForTTF(APath: string; var AFontTable: THashedStringList);
 
182
procedure FontsScanDir(APath: string; var AFontPaths: TStringList; var AFontList: THashedStringList);
 
183
{$endif}
 
184
 
 
185
implementation
 
186
 
 
187
var
 
188
  // List with the Z-order of non-native forms, index=0 is the bottom-most form
 
189
  NonNativeForms: TFPList = nil;
 
190
  lCurrentForm: TCDNonNativeForm = nil;
 
191
 
 
192
  // List of timers
 
193
  TimersList: TFPList = nil;
 
194
 
 
195
procedure AddCDWinControlToForm(const AForm: TCustomForm; ACDWinControl: TCDWinControl);
 
196
var
 
197
  lWindowInfo: TCDForm;
 
198
begin
 
199
  lWindowInfo := TCDForm(AForm.Handle);
 
200
  if lWindowInfo.Children = nil then lWindowInfo.Children := TFPList.Create;
 
201
  lWindowInfo.Children.Add(ACDWinControl);
 
202
end;
 
203
 
 
204
function GetCDWinControlList(const AForm: TCustomForm): TFPList;
 
205
var
 
206
  lWindowInfo: TCDForm;
 
207
begin
 
208
  lWindowInfo := TCDForm(AForm.Handle);
 
209
  if lWindowInfo.Children = nil then lWindowInfo.Children := TFPList.Create;
 
210
  Result := lWindowInfo.Children;
 
211
end;
 
212
 
 
213
procedure InitNonNativeForms();
 
214
begin
 
215
  if NonNativeForms <> nil then Exit;
 
216
  NonNativeForms := TFPList.Create;
 
217
end;
 
218
 
 
219
function GetCurrentForm(): TCDNonNativeForm;
 
220
begin
 
221
  {$IFDEF VerboseCDForms}
 
222
    DebugLn('GetCurrentForm');
 
223
  {$ENDIF}
 
224
  Result := lCurrentForm;
 
225
end;
 
226
 
 
227
function GetForm(AIndex: Integer): TCDNonNativeForm;
 
228
begin
 
229
  InitNonNativeForms();
 
230
  Result := TCDNonNativeForm(NonNativeForms.Items[AIndex]);
 
231
end;
 
232
 
 
233
function GetFormCount: Integer;
 
234
begin
 
235
  InitNonNativeForms();
 
236
  Result := NonNativeForms.Count;
 
237
end;
 
238
 
 
239
function AddNewForm(AForm: TCustomForm): TCDNonNativeForm;
 
240
var
 
241
  lFormInfo: TCDNonNativeForm;
 
242
begin
 
243
  {$IFDEF VerboseCDForms}
 
244
    DebugLn('AddNewForm');
 
245
  {$ENDIF}
 
246
  lFormInfo := TCDNonNativeForm.Create;
 
247
  lFormInfo.LCLForm := AForm;
 
248
  AddFormWithCDHandle(lFormInfo);
 
249
  Result := lFormInfo;
 
250
end;
 
251
 
 
252
procedure AddFormWithCDHandle(AHandle: TCDForm);
 
253
begin
 
254
  InitNonNativeForms();
 
255
  NonNativeForms.Insert(0, AHandle);
 
256
end;
 
257
 
 
258
function FindFormWithNativeHandle(AHandle: HWND): TCDForm;
 
259
var
 
260
  lCDForm: TCDForm;
 
261
  i: Integer;
 
262
begin
 
263
  Result := nil;
 
264
  InitNonNativeForms();
 
265
  for i := 0 to NonNativeForms.Count - 1 do
 
266
  begin
 
267
    lCDForm := TCDForm(NonNativeForms.Items[i]);
 
268
    if lCDForm.NativeHandle = AHandle then
 
269
    begin
 
270
      Result := lCDForm;
 
271
      Exit;
 
272
    end;
 
273
  end;
 
274
end;
 
275
 
 
276
procedure ShowForm(ACDForm: TCDNonNativeForm);
 
277
begin
 
278
  {$IFDEF VerboseCDForms}
 
279
    DebugLn(Format('ShowForm LCLForm=%s:%s', [ACDForm.LCLForm.Name, ACDForm.LCLForm.ClassName]));
 
280
  {$ENDIF}
 
281
  ACDForm.Visible := True;
 
282
  BringFormToFront(ACDForm);
 
283
  lCurrentForm := ACDForm;
 
284
end;
 
285
 
 
286
procedure HideForm(ACDForm: TCDNonNativeForm);
 
287
begin
 
288
  ACDForm.Visible := False;
 
289
  // update the Current Form if required, and invalidate too
 
290
  if lCurrentForm = ACDForm then
 
291
  begin
 
292
    lCurrentForm := FindTopMostVisibleForm();
 
293
    LCLIntf.InvalidateRect(HWND(lCurrentForm), nil, True);
 
294
  end;
 
295
  // Warn the LCL that the form was hidden
 
296
  LCLSendCloseQueryMsg(ACDForm.LCLForm);
 
297
end;
 
298
 
 
299
procedure BringFormToFront(ACDForm: TCDNonNativeForm);
 
300
var
 
301
  lCount, lCurIndex: Integer;
 
302
begin
 
303
  InitNonNativeForms();
 
304
  lCount := NonNativeForms.Count;
 
305
  lCurIndex := NonNativeForms.IndexOf(ACDForm);
 
306
  {$IFDEF VerboseCDForms}
 
307
    DebugLn(Format('BringFormToFront lOldIndex=%d lNewIndex=%d', [lCurIndex, lCount-1]));
 
308
  {$ENDIF}
 
309
  NonNativeForms.Move(lCurIndex, lCount-1);
 
310
end;
 
311
 
 
312
procedure SendFormToBack(ACDForm: TCDNonNativeForm);
 
313
var
 
314
  lCount, lCurIndex: Integer;
 
315
begin
 
316
  // Hide the form
 
317
  ACDForm.Visible := False;
 
318
 
 
319
  InitNonNativeForms();
 
320
  lCount := NonNativeForms.Count;
 
321
  lCurIndex := NonNativeForms.IndexOf(ACDForm);
 
322
  {$IFDEF VerboseCDForms}
 
323
    DebugLn(Format('SendFormToBack lOldIndex=%d lNewIndex=0', [lCurIndex]));
 
324
  {$ENDIF}
 
325
  NonNativeForms.Move(lCurIndex, 0);
 
326
end;
 
327
 
 
328
function FindTopMostVisibleForm: TCDNonNativeForm;
 
329
var
 
330
  lCount: Integer;
 
331
  lForm: TCDNonNativeForm;
 
332
  i: Integer;
 
333
begin
 
334
  Result := nil;
 
335
  InitNonNativeForms();
 
336
  // Iterate starting from Count to zero until we find a visible form
 
337
  lCount := NonNativeForms.Count;
 
338
 
 
339
  for i := lCount-1 downto 0 do
 
340
  begin
 
341
    lForm := TCDNonNativeForm(NonNativeForms.Items[i]);
 
342
    if lForm.Visible then
 
343
    begin
 
344
      Result := lForm;
 
345
      Break;
 
346
    end;
 
347
  end;
 
348
  {$IFDEF VerboseCDForms}
 
349
    DebugLn(Format('FindTopMostVisibleForm FoundIndex=%d FoundForm=%s:%s',
 
350
      [i, Result.LCLForm.Name, Result.LCLForm.ClassName]));
 
351
  {$ENDIF}
 
352
end;
 
353
 
 
354
// If AForceUpdate=True then it will update even if the width and height remain the same
 
355
procedure UpdateControlLazImageAndCanvas(var AImage: TLazIntfImage;
 
356
  var ACanvas: TLazCanvas; AWidth, AHeight: Integer; AFormat: TUpdateLazImageFormat;
 
357
  AData: Pointer = nil; AForceUpdate: Boolean = False;
 
358
  AFreeImageOnUpdate: Boolean = True; ADataOwner: Boolean = True);
 
359
var
 
360
  lRawImage: TRawImage;
 
361
  lPixelSize: Byte;
 
362
begin
 
363
  {$IFDEF VerboseCDLazCanvas}
 
364
    DebugLn(Format(':>[UpdateControlLazImageAndCanvas] Input Image: %x Canvas: %x',
 
365
      [PtrInt(AImage), PtrInt(ACanvas)]));
 
366
  {$ENDIF}
 
367
  // Check if the image needs update
 
368
  if (AImage = nil) or (AWidth <> AImage.Width) or (AHeight <> AImage.Height)
 
369
    or AForceUpdate then
 
370
  begin
 
371
    if (AImage <> nil) and AFreeImageOnUpdate then AImage.Free;
 
372
    // Free the canvas and create a new one if it is a dummy Canvas created for text metrics reading by GetDC(control)
 
373
    if (ACanvas <> nil) and ACanvas.HasNoImage then
 
374
    begin
 
375
      ACanvas.Free;
 
376
      ACanvas := nil;
 
377
    end;
 
378
 
 
379
    lRawImage.Init;
 
380
    case AFormat of
 
381
    clfRGB16_R5G6B5:  lRawImage.Description.Init_BPP16_R5G6B5(AWidth, AHeight);
 
382
    clfRGB24:  lRawImage.Description.Init_BPP24_R8G8B8_BIO_TTB(AWidth, AHeight);
 
383
    clfRGB24UpsideDown: lRawImage.Description.Init_BPP24_R8G8B8_BIO_TTB_UpsideDown(AWidth, AHeight);
 
384
    clfBGR24:  lRawImage.Description.Init_BPP24_B8G8R8_BIO_TTB(AWidth, AHeight);
 
385
    clfBGRA32: lRawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(AWidth, AHeight);
 
386
    clfRGBA32: lRawImage.Description.Init_BPP32_R8G8B8A8_BIO_TTB(AWidth, AHeight);
 
387
    clfARGB32: lRawImage.Description.Init_BPP32_A8R8G8B8_BIO_TTB(AWidth, AHeight);
 
388
    end;
 
389
 
 
390
    // Now connect the pixel buffer or create one
 
391
    if AData = nil then lRawImage.CreateData(True)
 
392
    else
 
393
    begin
 
394
      case AFormat of
 
395
      clfRGB16_R5G6B5:
 
396
        lPixelSize := 2;
 
397
      clfRGB24, clfRGB24UpsideDown, clfBGR24:
 
398
        lPixelSize := 3;
 
399
      clfBGRA32, clfRGBA32, clfARGB32:
 
400
        lPixelSize := 4;
 
401
      end;
 
402
 
 
403
      lRawImage.Data := AData;
 
404
      lRawImage.DataSize := AWidth * lPixelSize * AHeight;
 
405
    end;
 
406
 
 
407
    AImage := TLazIntfImage.Create(AWidth, AHeight);
 
408
    AImage.SetRawImage(lRawImage, ADataOwner);
 
409
 
 
410
    if (ACanvas <> nil) then ACanvas.Free;
 
411
    ACanvas := TLazCanvas.Create(AImage);
 
412
  end;
 
413
  {$IFDEF VerboseCDLazCanvas}
 
414
    DebugLn(Format(':<[UpdateControlLazImageAndCanvas] Output Image: %x Canvas: %x',
 
415
      [PtrInt(AImage), PtrInt(ACanvas)]));
 
416
  {$ENDIF}
 
417
end;
 
418
 
 
419
procedure DrawFormBackground(var AImage: TLazIntfImage; var ACanvas: TLazCanvas);
 
420
begin
 
421
  ACanvas.SaveState;
 
422
  ACanvas.ResetCanvasState;
 
423
  ACanvas.Brush.FPColor := TColorToFPColor(ColorToRGB(clForm));
 
424
  ACanvas.Pen.FPColor := TColorToFPColor(ColorToRGB(clForm));
 
425
  ACanvas.Rectangle(0, 0, AImage.Width, AImage.Height);
 
426
  ACanvas.RestoreState(-1);
 
427
end;
 
428
 
 
429
// This does not render the win control itself, only it's children
 
430
// The WinControls themselves will render child TControls not descending from TWinControl
 
431
procedure RenderChildWinControls(var AImage: TLazIntfImage;
 
432
  var ACanvas: TLazCanvas; ACDControlsList: TFPList; ACDForm: TCDForm);
 
433
var
 
434
  i, lChildrenCount: Integer;
 
435
  lCDWinControl: TCDWinControl;
 
436
begin
 
437
  lChildrenCount := ACDControlsList.Count;
 
438
  {$ifdef VerboseCDWinControl}
 
439
  DebugLn(Format('[RenderChildWinControls] ACanvas=%x ACDControlsList=%x lChildrenCount=%d',
 
440
    [PtrInt(ACanvas), PtrInt(ACDControlsList), lChildrenCount]));
 
441
  {$endif}
 
442
 
 
443
  for i := 0 to lChildrenCount-1 do
 
444
  begin
 
445
    {$ifdef VerboseCDWinControl}
 
446
    DebugLn(Format('[RenderChildWinControls] i=%d', [i]));
 
447
    {$endif}
 
448
 
 
449
    lCDWinControl := TCDWinControl(ACDControlsList.Items[i]);
 
450
 
 
451
    RenderWinControlAndChildren(AImage, ACanvas, lCDWinControl, ACDForm);
 
452
  end;
 
453
end;
 
454
 
 
455
// Renders a WinControl, but not it's children
 
456
// Returns if the control is visible and therefore if its children should be rendered
 
457
function RenderWinControl(var AImage: TLazIntfImage; var ACanvas: TLazCanvas;
 
458
  ACDWinControl: TCDWinControl; ACDForm: TCDForm): Boolean;
 
459
var
 
460
  lWinControl, lParentControl: TWinControl;
 
461
  struct : TPaintStruct;
 
462
  lCanvas: TCanvas;
 
463
  lControlCanvas: TLazCanvas;
 
464
  lBaseWindowOrg: TPoint;
 
465
  lControlStateEx: TCDControlStateEx;
 
466
  lDrawControl: Boolean;
 
467
begin
 
468
  Result := False;
 
469
 
 
470
  lWinControl := ACDWinControl.WinControl;
 
471
 
 
472
  {$ifdef VerboseCDWinControl}
 
473
  DebugLn(Format('[RenderWinControl] lWinControl=%x Name=%s:%s Left=%d'
 
474
    + ' Top=%d Width=%d Height=%d', [PtrInt(lWinControl), lWinControl.Name, lWinControl.ClassName,
 
475
    lWinControl.Left, lWinControl.Top, lWinControl.Width, lWinControl.Height]));
 
476
  {$endif}
 
477
 
 
478
  if lWinControl.Visible = False then Exit;
 
479
 
 
480
  // Disable the drawing itself, but keep the window org and region operations
 
481
  // or else clicking and other things are broken
 
482
  lDrawControl := ACDWinControl.IsControlBackgroundVisible();
 
483
 
 
484
  // Save the Canvas state
 
485
  ACanvas.SaveState;
 
486
  ACanvas.ResetCanvasState;
 
487
 
 
488
  // lBaseWindowOrg makes debugging easier
 
489
  // Iterate to find the appropriate BaseWindowOrg relative to the parent control
 
490
  lBaseWindowOrg := FindControlPositionRelativeToTheForm(lWinControl);
 
491
  ACanvas.BaseWindowOrg := Point(lBaseWindowOrg.X, lBaseWindowOrg.Y - ACDForm.ScrollY);
 
492
  ACanvas.WindowOrg := Point(0, 0);
 
493
 
 
494
  // Prepare the clippping relative to the form
 
495
  ACanvas.Clipping := True;
 
496
  ACDWinControl.Region.Rect := Bounds(lBaseWindowOrg.X, lBaseWindowOrg.Y - ACDForm.ScrollY,
 
497
    lWinControl.Width, lWinControl.Height);
 
498
  ACanvas.ClipRegion := ACDWinControl.Region;
 
499
 
 
500
  lControlCanvas := ACanvas;
 
501
 
 
502
  if (ACDWinControl.InvalidateCount > 0) and lDrawControl then
 
503
  begin
 
504
    ACDWinControl.UpdateImageAndCanvas();
 
505
    lControlCanvas := ACDWinControl.ControlCanvas;
 
506
    ACDWinControl.InvalidateCount := 0;
 
507
 
 
508
    // Special drawing for some native controls
 
509
    if (lWinControl is TCustomPanel) or (lWinControl is TTabSheet)
 
510
     or (lWinControl is TCustomPage) or (lWinControl is TNotebook)  then
 
511
    begin
 
512
      // Erase the background of TPanel controls, since it can draw it's own border, but fails to draw it's own background
 
513
      // and also erase the background for TTabSheet (children of TPageControl) and TCustomPage (children of TNotebook)
 
514
      lControlCanvas.SaveState;
 
515
      lControlCanvas.Brush.FPColor := TColorToFPColor(lWinControl.GetRGBColorResolvingParent());
 
516
      lControlCanvas.Pen.FPColor := lControlCanvas.Brush.FPColor;
 
517
      lControlCanvas.Rectangle(Bounds(0, 0, lWinControl.Width, lWinControl.Height));
 
518
      lControlCanvas.RestoreState(-1);
 
519
    end
 
520
    else if lWinControl is TCustomGroupBox then
 
521
    begin
 
522
      lControlCanvas.SaveState;
 
523
      lControlStateEx := TCDControlStateEx.Create;
 
524
      try
 
525
        lControlStateEx.Font := lWinControl.Font;
 
526
        lControlStateEx.Caption := lWinControl.Caption;
 
527
        lControlStateEx.ParentRGBColor := lWinControl.GetRGBColorResolvingParent();
 
528
        GetDefaultDrawer().DrawGroupBox(lControlCanvas, Size(lWinControl.Width, lWinControl.Height),
 
529
          [], lControlStateEx);
 
530
      finally
 
531
        lControlStateEx.Free;
 
532
        lControlCanvas.RestoreState(-1);
 
533
      end;
 
534
    end;
 
535
 
 
536
    // Send the drawing message
 
537
    {$ifdef VerboseCDWinControl}
 
538
    DebugLn('[RenderWinControl] before LCLSendPaintMsg');
 
539
    {$endif}
 
540
    FillChar(struct, SizeOf(TPaintStruct), 0);
 
541
    struct.hdc := HDC(lControlCanvas);
 
542
    LCLSendEraseBackgroundMsg(lWinControl, struct.hdc);
 
543
    LCLSendPaintMsg(lWinControl, struct.hdc, @struct);
 
544
    {$ifdef VerboseCDWinControl}
 
545
    DebugLn('[RenderWinControl] after LCLSendPaintMsg');
 
546
    {$endif}
 
547
  end;
 
548
 
 
549
  // Here we actually blit the control to the form canvas
 
550
  if lDrawControl then
 
551
  ACanvas.CanvasCopyRect(ACDWinControl.ControlCanvas, 0, 0, 0, 0,
 
552
    lWinControl.Width, lWinControl.Height);
 
553
 
 
554
  // Now restore it
 
555
  ACanvas.RestoreState(-1);
 
556
 
 
557
  Result := True;
 
558
end;
 
559
 
 
560
// Render a WinControl and all it's children
 
561
procedure RenderWinControlAndChildren(var AImage: TLazIntfImage;
 
562
  var ACanvas: TLazCanvas; ACDWinControl: TCDWinControl; ACDForm: TCDForm);
 
563
begin
 
564
  if not RenderWinControl(AImage, ACanvas, ACDWinControl, ACDForm) then Exit;
 
565
 
 
566
  // Now Draw all sub-controls
 
567
  if ACDWinControl.Children <> nil then
 
568
    RenderChildWinControls(AImage, ACanvas, ACDWinControl.Children, ACDForm);
 
569
end;
 
570
 
 
571
// Draws a form and all of its child controls
 
572
procedure RenderForm(var AImage: TLazIntfImage; var ACanvas: TLazCanvas;
 
573
  AForm: TCustomForm);
 
574
var
 
575
  struct : TPaintStruct;
 
576
  lWindowHandle: TCDForm;
 
577
  lFormCanvas: TLazCanvas;
 
578
  lDrawControl: Boolean;
 
579
begin
 
580
  lWindowHandle := TCDForm(AForm.Handle);
 
581
 
 
582
  // Disable the drawing itself, but keep the window org and region operations
 
583
  // or else clicking and other things are broken, specially in Android
 
584
  lDrawControl := lWindowHandle.IsControlBackgroundVisible();
 
585
 
 
586
  if lDrawControl then
 
587
    DrawFormBackground(AImage, ACanvas);
 
588
 
 
589
  // Consider the form scrolling
 
590
  // ToDo: Figure out why this "div 2" factor is necessary for drawing non-windows controls and remove this factor
 
591
  // If you remove this factor then the wincontrols are fine,
 
592
  // but graphiccontrols scroll with a different speed which is a huge problem
 
593
  ACanvas.BaseWindowOrg := Point(0, - lWindowHandle.ScrollY div 2);
 
594
  ACanvas.WindowOrg := Point(0, 0);
 
595
 
 
596
  lFormCanvas := ACanvas;
 
597
 
 
598
  if lDrawControl then
 
599
  begin
 
600
    // Send the paint message to the LCL
 
601
    {$IFDEF VerboseCDForms}
 
602
      DebugLn(Format('[RenderForm] OnPaint event started context: %x', [struct.hdc]));
 
603
    {$ENDIF}
 
604
    FillChar(struct, SizeOf(TPaintStruct), 0);
 
605
    struct.hdc := HDC(lFormCanvas);
 
606
    LCLSendPaintMsg(AForm, struct.hdc, @struct);
 
607
    {$IFDEF VerboseCDForms}
 
608
      DebugLn('[RenderForm] OnPaint event ended');
 
609
    {$ENDIF}
 
610
  end;
 
611
 
 
612
  // Now paint all child win controls
 
613
  RenderChildWinControls(AImage, ACanvas, GetCDWinControlList(AForm), lWindowHandle);
 
614
end;
 
615
 
 
616
function FindControlWhichReceivedEvent(AForm: TCustomForm;
 
617
  AControlsList: TFPList; AX, AY: Integer): TWinControl;
 
618
var
 
619
  i: Integer;
 
620
  lRegionOfEvent: TLazRegionWithChilds;
 
621
  lCurCDControl: TCDWinControl;
 
622
  lEventPos: TPoint; // local, already adjusted for the scrolling
 
623
begin
 
624
  Result := AForm;
 
625
  lEventPos := Point(AX, AY); // Don't adjust for the scrolling because the regions are scrolled too
 
626
 
 
627
  // The order of this loop is important to respect the Z-order of controls
 
628
  for i := AControlsList.Count-1 downto 0 do
 
629
  begin
 
630
    lCurCDControl := TCDWinControl(AControlsList.Items[i]);
 
631
    if lCurCDControl.Region = nil then Continue;
 
632
    if not lCurCDControl.WinControl.HandleObjectShouldBeVisible then Continue;
 
633
    lRegionOfEvent := lCurCDControl.Region.IsPointInRegion(lEventPos.X, lEventPos.Y);
 
634
    if lRegionOfEvent <> nil then
 
635
    begin
 
636
      if lRegionOfEvent.UserData = nil then
 
637
        raise Exception.Create('[FindControlWhichReceivedEvent] Malformed tree of regions');
 
638
      Result := TWinControl(lRegionOfEvent.UserData);
 
639
 
 
640
      // If it is a native LCL control, redirect to the CDControl
 
641
      if lCurCDControl.CDControl <> nil then
 
642
        Result := lCurCDControl.CDControl;
 
643
 
 
644
      Exit;
 
645
    end;
 
646
  end;
 
647
end;
 
648
 
 
649
function FindControlPositionRelativeToTheForm(ALCLControl: TWinControl; AConsiderScrolling: Boolean = False): TPoint;
 
650
var
 
651
  lParentControl: TWinControl;
 
652
  lParentHandle: TCDBaseControl;
 
653
  lScroll, lParentPos: TPoint;
 
654
begin
 
655
  // Iterate to find the appropriate BaseWindowOrg relative to the parent control
 
656
  Result := Point(ALCLControl.Left, ALCLControl.Top);
 
657
  lParentControl := ALCLControl.Parent;
 
658
  while (lParentControl <> nil) do
 
659
  begin
 
660
    if AConsiderScrolling and lParentControl.HandleAllocated then
 
661
    begin
 
662
      lParentHandle := TCDBaseControl(lParentControl.Handle);
 
663
      lScroll := Point(lParentHandle.ScrollX, lParentHandle.ScrollY);
 
664
    end
 
665
    else lScroll := Point(0, 0);
 
666
 
 
667
    if (lParentControl is TCustomForm) then lParentPos := Point(0, 0)
 
668
    else lParentPos := Point(lParentControl.Left, lParentControl.Top);
 
669
 
 
670
    Result.X := Result.X + lParentPos.X - lScroll.X;
 
671
    Result.Y := Result.Y + lParentPos.Y - lScroll.Y;
 
672
    lParentControl := lParentControl.Parent;
 
673
  end;
 
674
end;
 
675
 
 
676
function FormPosToControlPos(ALCLControl: TWinControl; AX, AY: Integer): TPoint;
 
677
var
 
678
  lControlPos: TPoint;
 
679
begin
 
680
  lControlPos := FindControlPositionRelativeToTheForm(ALCLControl, True);
 
681
  Result.X := AX - lControlPos.X;
 
682
  Result.Y := AY - lControlPos.Y;
 
683
end;
 
684
 
 
685
function DateTimeToMilliseconds(aDateTime: TDateTime): Int64;
 
686
var
 
687
  TimeStamp: TTimeStamp;
 
688
begin
 
689
  {Call DateTimeToTimeStamp to convert DateTime to TimeStamp:}
 
690
  TimeStamp:= DateTimeToTimeStamp (aDateTime);
 
691
  {Multiply and add to complete the conversion:}
 
692
  Result:= TimeStamp.Time;
 
693
end;
 
694
 
 
695
function IsValidDC(ADC: HDC): Boolean;
 
696
begin
 
697
  Result := ADC <> 0;
 
698
end;
 
699
 
 
700
function IsValidGDIObject(AGDIObj: HGDIOBJ): Boolean;
 
701
begin
 
702
  Result := AGDIObj <> 0;
 
703
end;
 
704
 
 
705
function IsValidBitmap(ABitmap: HBITMAP): Boolean;
 
706
begin
 
707
  Result := ABitmap <> 0;
 
708
end;
 
709
 
 
710
function RemoveAccelChars(AStr: string): string;
 
711
begin
 
712
  // ToDo convert && to & and keep it
 
713
  Result := StringReplace(AStr, '&', '', [rfReplaceAll]);
 
714
end;
 
715
 
 
716
procedure InitTimersList;
 
717
begin
 
718
  if TimersList = nil then TimersList := TFPList.Create;
 
719
end;
 
720
 
 
721
procedure AddTimer(ATimer: TCDTimer);
 
722
begin
 
723
  InitTimersList();
 
724
  TimersList.Add(ATimer);
 
725
end;
 
726
 
 
727
function GetTimer(AIndex: Integer): TCDTimer;
 
728
begin
 
729
  InitTimersList();
 
730
  Result := TCDTimer(TimersList.Items[AIndex]);
 
731
end;
 
732
 
 
733
function GetTimerCount: Integer;
 
734
begin
 
735
  InitTimersList();
 
736
  Result := TimersList.Count;
 
737
end;
 
738
 
 
739
function GetSmallestTimerInterval: Integer;
 
740
var
 
741
  i: Integer;
 
742
  lTimer: TCDTimer;
 
743
begin
 
744
  Result := High(Integer);
 
745
  for i := 0 to GetTimerCount()-1 do
 
746
  begin
 
747
    lTimer := GetTimer(i);
 
748
    Result := Min(Result, lTimer.Interval);
 
749
  end;
 
750
  if Result = High(Integer) then Result := -1;
 
751
end;
 
752
 
 
753
procedure RemoveTimer(ATimer: TCDTimer);
 
754
begin
 
755
  InitTimersList();
 
756
  TimersList.Remove(ATimer);
 
757
end;
 
758
 
 
759
function FindTimerWithNativeHandle(ANativeHandle: PtrInt): TCDTimer;
 
760
var
 
761
  lTimer: TCDTimer;
 
762
  i: Integer;
 
763
begin
 
764
  Result := nil;
 
765
  InitTimersList();
 
766
  for i := 0 to TimersList.Count - 1 do
 
767
  begin
 
768
    lTimer := TCDTimer(TimersList.Items[i]);
 
769
    if lTimer.NativeHandle = ANativeHandle then
 
770
      Exit(lTimer);
 
771
  end;
 
772
end;
 
773
 
 
774
{$ifndef CD_UseNativeText}
 
775
procedure VerifyAndCleanUpFontDirectories(AFontDirectories: TStringList);
 
776
var
 
777
  i, j: Integer;
 
778
begin
 
779
  // Add path delimitiers to the end of all paths
 
780
  for i := 0 to AFontDirectories.Count -1 do
 
781
  begin
 
782
    AFontDirectories.Strings[i] := IncludeTrailingPathDelimiter(AFontDirectories.Strings[i]);
 
783
  end;
 
784
 
 
785
  // remove all duplicates
 
786
  i := 0;
 
787
  while i < AFontDirectories.Count do
 
788
  begin
 
789
    j := i+1;
 
790
    while j < AFontDirectories.Count do
 
791
    begin
 
792
      if AFontDirectories.Strings[i] = AFontDirectories.Strings[j] then
 
793
        AFontDirectories.Delete(j);
 
794
      Inc(j);
 
795
    end;
 
796
    Inc(i);
 
797
  end;
 
798
 
 
799
  // Now remove all directories which don't exist
 
800
  i := 0;
 
801
  while i < AFontDirectories.Count do
 
802
  begin
 
803
    if not DirectoryExistsUTF8(AFontDirectories.Strings[i]) then
 
804
      AFontDirectories.Delete(i);
 
805
    Inc(i);
 
806
  end;
 
807
 
 
808
  // Raise an exception if there are no font directories
 
809
  if AFontDirectories.Count = 0 then
 
810
    raise Exception.Create('[VerifyAndCleanUpFontDirectories] After cleaning up no font directories were found.');
 
811
end;
 
812
 
 
813
{------------------------------------------------------------------------------
 
814
 Procedure: BackendScanForTTF - Scope=local
 
815
 Params: APath - path for a font directory
 
816
         AFontTable - Font name to Font path Hashed List
 
817
 
 
818
 Scan a directory for ttf fonts and updates the FontTable
 
819
------------------------------------------------------------------------------}
 
820
procedure FontsScanForTTF(APath: string; var AFontTable: THashedStringList);
 
821
var
 
822
  Rslt: TSearchRec;
 
823
  AFace: TT_Face;
 
824
  ErrNum: TT_Error;
 
825
  SearchResult, J: Integer;
 
826
  FontPath: String;
 
827
  NameCount: Integer;
 
828
  NameString: Pchar;
 
829
  NameLen: Integer;
 
830
  Platform,Encoding,Language: Integer;
 
831
  NameID: Integer;
 
832
  AName: String;
 
833
{$ifdef CD_Debug_TTF}
 
834
  DebugList: TstringList;
 
835
{$endif}
 
836
begin
 
837
  SearchResult := FindFirstUTF8(APath+'*.ttf', faAnyFile, Rslt);
 
838
{$ifdef CD_Debug_TTF}
 
839
  DebugList:= TStringList.Create;
 
840
{$endif}
 
841
  while SearchResult = 0 do
 
842
  begin
 
843
    FontPath:= APath+Rslt.Name;
 
844
 
 
845
    {$ifdef CD_Debug_TTF}
 
846
      DebugLn(Format('[FontsScanForTTF] font=', [FontPath]));
 
847
    {$endif}
 
848
 
 
849
    // Work around for fonts which cause errors. See bug 21456
 
850
    if Rslt.Name = 'tunga.ttf' then
 
851
    begin
 
852
      SearchResult := FindNextUTF8(Rslt);
 
853
      Continue;
 
854
    end;
 
855
 
 
856
    ErrNum:= TT_Open_Face(FontPath, AFace);
 
857
    if ErrNum = TT_Err_Ok then
 
858
    begin
 
859
      NameCount:= TT_Get_Name_Count(AFace);
 
860
      for J:= 0 to NameCount-1 do
 
861
      begin
 
862
        ErrNum:= TT_Get_Name_ID(AFace, J, Platform, Encoding, Language, NameID);
 
863
        { -------------------------------------------------------------------
 
864
            NameID: 0= Copyright
 
865
                    1= Font Family (e.g. Arial, Times, Liberation )
 
866
                    2= Font Subfamily (e.g. Bold, Italic, Condensed)
 
867
                    3= Unique Font Identifier
 
868
                    4= Full Name - Human readable - the one used by the IDE
 
869
        -----------------------------------------------------------------------}
 
870
        {$ifdef CD_Debug_TTF}
 
871
        if ErrNum = TT_Err_Ok then
 
872
        begin
 
873
          ErrNum:= TT_Get_Name_String(AFace,J,NameString,NameLen);
 
874
          AName:= NameString;
 
875
          if NameString <> '' then //DBG
 
876
          begin
 
877
            SetLength(AName,NameLen);
 
878
            DebugList.Add('ID='+IntToStr(NameID)+' Path='+FontPath+' Name='+AName);
 
879
          end
 
880
          else DebugList.Add('ID='+IntToStr(NameID)+' Path='+FontPath+' Name=<Empty String>');
 
881
        end;
 
882
        {$endif}
 
883
        if (ErrNum = TT_Err_Ok) and (NameID = 4) then begin
 
884
          ErrNum:= TT_Get_Name_String(AFace,J,NameString,NameLen);
 
885
          AName:= NameString;
 
886
          // Skip empty entries
 
887
          if NameString <> '' then begin
 
888
            SetLength(AName,NameLen);
 
889
            AFontTable.Add(AName+'='+FontPath);
 
890
          end;
 
891
        end;
 
892
      end;
 
893
    end;
 
894
    {$ifdef CD_Debug_TTF}
 
895
    DebugList.Add('------');
 
896
    {$endif}
 
897
    ErrNum:= TT_Close_Face(AFace);
 
898
    SearchResult := FindNextUTF8(Rslt);
 
899
  end;
 
900
  FindCloseUTF8(Rslt);
 
901
{$ifdef CD_Debug_TTF}
 
902
  AName:= ExtractFileDir(Apath);
 
903
  AName:= ExtractFileName(AName) + '.txt';
 
904
  DebugList.SaveToFile({$ifdef UNIX}'/tmp/'+{$endif}{$ifdef Windows}'C:\'+{$endif}AName);
 
905
  DebugList.Free;
 
906
{$endif}
 
907
end;
 
908
 
 
909
{------------------------------------------------------------------------------
 
910
 Procedure: BackendScanDir - Scope=Local
 
911
 Params: APath - path for a font directory
 
912
         AFontPaths - Font path List
 
913
 
 
914
 Recursively scans font directories to find the ones populated only
 
915
by fonts
 
916
------------------------------------------------------------------------------}
 
917
procedure FontsScanDir(APath: string; var AFontPaths: TStringList; var AFontList: THashedStringList);
 
918
var
 
919
  NextPath: string;
 
920
  Rslt: TSearchRec;
 
921
  I: Integer;
 
922
  DirFound,DirEmpty: Boolean;
 
923
  TmpList: THashedStringList;
 
924
begin
 
925
  DirFound:= False;
 
926
  DirEmpty:= True;
 
927
  I:= FindFirstUTF8(APath+'*',faAnyFile,Rslt);
 
928
  while I >= 0 do begin
 
929
    if (Rslt.Name <> '.') and (Rslt.Name <> '..') then
 
930
    begin
 
931
      DirEmpty:= False;
 
932
      if (Rslt.Attr and faDirectory) <> 0 then
 
933
      begin
 
934
        NextPath:= APath + Rslt.Name + PathDelim;
 
935
        DirFound:= true;
 
936
        FontsScanDir(NextPath,AFontPaths,AFontList);
 
937
      end;
 
938
    end;
 
939
    I:= FindNextUTF8(Rslt);
 
940
  end;
 
941
  FindCloseUTF8(Rslt);
 
942
  if (not DirFound) and (not DirEmpty) then
 
943
    AFontPaths.Add(APath);
 
944
end;
 
945
 
 
946
{$endif}
 
947
 
 
948
{ TCDWinControl }
 
949
 
 
950
procedure TCDWinControl.UpdateImageAndCanvas;
 
951
begin
 
952
  UpdateControlLazImageAndCanvas(ControlImage, ControlCanvas,
 
953
    WinControl.Width, WinControl.Height, clfARGB32);
 
954
end;
 
955
 
 
956
function TCDWinControl.IsControlBackgroundVisible: Boolean;
 
957
begin
 
958
  FWinControl := WinControl;
 
959
  Result:=inherited IsControlBackgroundVisible;
 
960
end;
 
961
 
 
962
{ TCDBitmap }
 
963
 
 
964
destructor TCDBitmap.Destroy;
 
965
begin
 
966
  if Image <> nil then Image.Free;
 
967
  inherited Destroy;
 
968
end;
 
969
 
 
970
{ TCDBaseControl }
 
971
 
 
972
function TCDBaseControl.GetProps(AnIndex: String): pointer;
 
973
var
 
974
  i: Integer;
 
975
begin
 
976
  i:=Fprops.IndexOf(AnIndex);
 
977
  if i>=0 then
 
978
  begin
 
979
    result:=Fprops.Objects[i];
 
980
    exit;
 
981
  end;
 
982
  result := nil;
 
983
end;
 
984
 
 
985
procedure TCDBaseControl.SetProps(AnIndex: String; AValue: pointer);
 
986
var
 
987
  i: Integer;
 
988
begin
 
989
  i := Fprops.IndexOf(AnIndex);
 
990
  if i < 0 then
 
991
    i := FProps.Add(AnIndex);
 
992
  Fprops.Objects[i] := TObject(AValue);
 
993
end;
 
994
 
 
995
constructor TCDBaseControl.Create;
 
996
begin
 
997
  inherited Create;
 
998
  FProps := TStringList.Create;
 
999
  //FProps.CaseSensitive:=false; commented as in the qt widgetset
 
1000
  FProps.Sorted:=true;
 
1001
  IncInvalidateCount(); // Always starts needing an invalidate
 
1002
 
 
1003
  Children := TFPList.Create;
 
1004
end;
 
1005
 
 
1006
destructor TCDBaseControl.Destroy;
 
1007
begin
 
1008
  FProps.Free;
 
1009
  Children.Free;
 
1010
 
 
1011
  // Free the Canvas and Image if required
 
1012
  // Dont free for the Form because elsewhere this is taken care of
 
1013
  if ControlCanvas <> nil then ControlCanvas.Free;
 
1014
  if ControlImage <> nil then ControlImage.Free;
 
1015
 
 
1016
  inherited Destroy;
 
1017
end;
 
1018
 
 
1019
procedure TCDBaseControl.IncInvalidateCount;
 
1020
begin
 
1021
  Inc(InvalidateCount);
 
1022
end;
 
1023
 
 
1024
function TCDBaseControl.AdjustCoordinatesForScrolling(AX, AY: Integer): TPoint;
 
1025
begin
 
1026
  DebugLn(Format('AX=%d AY=%d ScrollX=%d ScrollY=%d', [AX, AY, ScrollX, ScrollY]));
 
1027
  Result := Point(AX + ScrollX, AY + ScrollY);
 
1028
end;
 
1029
 
 
1030
procedure TCDBaseControl.UpdateImageAndCanvas;
 
1031
begin
 
1032
 
 
1033
end;
 
1034
 
 
1035
// This is utilized for optimizing the painting. If we figure out that there is
 
1036
// nothing visible from a control, just give up drawing it completely
 
1037
//
 
1038
// What usually happens is that child controls might completely cover their
 
1039
// parent controls
 
1040
//
 
1041
// We should watch out for alpha-blending, however
 
1042
function TCDBaseControl.IsControlBackgroundVisible: Boolean;
 
1043
var
 
1044
  i: Integer;
 
1045
  lChild: TControl;
 
1046
  lWinChild: TWinControl;
 
1047
begin
 
1048
  Result := True;
 
1049
  if FWinControl = nil then Exit;
 
1050
  for i := 0 to FWinControl.ControlCount-1 do
 
1051
  begin
 
1052
    lChild := FWinControl.Controls[i];
 
1053
    if not (lChild is TWinControl) then Continue;
 
1054
    lWinChild := TWinControl(lChild);
 
1055
 
 
1056
    // ToDo: Ignore alpha blended controls
 
1057
 
 
1058
    // Basic case: alClient
 
1059
    if lWinChild.Align = alClient then Exit(False);
 
1060
 
 
1061
    // Another case: coordinates match
 
1062
    if (lWinChild.Left = 0) and (lWinChild.Top = 0) and
 
1063
       (lWinChild.Width = FWinControl.Width) and (lWinChild.Height = FWinControl.Height) then
 
1064
       Exit(False);
 
1065
  end;
 
1066
end;
 
1067
 
 
1068
{ TCDForm }
 
1069
 
 
1070
constructor TCDForm.Create;
 
1071
begin
 
1072
  inherited Create;
 
1073
  InvalidateCount := 1;
 
1074
end;
 
1075
 
 
1076
function TCDForm.GetFocusedControl: TWinControl;
 
1077
begin
 
1078
  if FocusedIntfControl <> nil then Result := FocusedIntfControl
 
1079
  else if FocusedControl <> nil then Result := FocusedControl
 
1080
  else Result := LCLForm;
 
1081
end;
 
1082
 
 
1083
function TCDForm.GetFormVirtualHeight(AScreenHeight: Integer): Integer;
 
1084
var
 
1085
  i, lControlRequiredHeight: Integer;
 
1086
  lControl: TControl;
 
1087
begin
 
1088
  Result := AScreenHeight;
 
1089
  for i := 0 to LCLForm.ControlCount-1 do
 
1090
  begin
 
1091
    lControl := LCLForm.Controls[i];
 
1092
    lControlRequiredHeight := lControl.Top + lControl.Height;
 
1093
    Result := Max(lControlRequiredHeight, Result);
 
1094
  end;
 
1095
end;
 
1096
 
 
1097
procedure TCDForm.SanityCheckScrollPos;
 
1098
begin
 
1099
  ScrollY := Max(ScrollY, 0);
 
1100
  ScrollY := Min(ScrollY, GetFormVirtualHeight(Image.Height) - Image.Height);
 
1101
end;
 
1102
 
 
1103
procedure TCDForm.UpdateImageAndCanvas;
 
1104
begin
 
1105
  UpdateControlLazImageAndCanvas(ControlImage, ControlCanvas,
 
1106
    LCLForm.ClientWIdth, LCLForm.ClientHeight, clfARGB32);
 
1107
end;
 
1108
 
 
1109
function TCDForm.IsControlBackgroundVisible: Boolean;
 
1110
begin
 
1111
  FWinControl := LCLForm;
 
1112
  Result:=inherited IsControlBackgroundVisible;
 
1113
end;
 
1114
 
 
1115
end.
 
1116