File: gtkwsprivate.pp

package info (click to toggle)
lazarus 2.0.0%2Bdfsg-2
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 214,460 kB
  • sloc: pascal: 1,862,622; xml: 265,709; cpp: 56,595; sh: 3,008; java: 609; makefile: 535; perl: 297; sql: 222; ansic: 137
file content (391 lines) | stat: -rw-r--r-- 10,474 bytes parent folder | download | duplicates (6)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
{ $Id: gtkwsprivate.pp 41387 2013-05-24 18:30:06Z juha $ }
{
                  ----------------------------------------
                  GtkWSprivate.pp  -  Gtk internal classes
                  ----------------------------------------

 @created(Thu Feb 1st WET 2007)
 @lastmod($Date: 2013-05-24 20:30:06 +0200 (Fr, 24 Mai 2013) $)
 @author(Marc Weustink <marc@@lazarus.dommelstein.net>)

 This unit contains the private classhierarchy for the gtk implemetations
 This hierarchy reflects (more or less) the gtk widget hierarchy

 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************
}

unit GtkWSPrivate;
{$mode objfpc}{$H+}

interface

uses
  // libs
  {$IFDEF GTK2}
  Gtk2, Glib2, Gdk2,
  {$ELSE}
  Gtk, Glib, Gdk,
  {$ENDIF}
  // RTL
  Classes, SysUtils, 
  // LCL
  LCLType, LMessages, LCLProc, Controls, Forms,
  // widgetset
  WSControls, WSLCLClasses, WSProc,
  // interface
  GtkDef, GtkProc, GtkWsControls;


type
  { TGtkPrivate }
  { Generic base class, don't know if it is needed }

  TGtkPrivate = class(TWSPrivate)
  private
  protected
  public
  end;

  { TGtkPrivateWidget }
  { Private class for all gtk widgets }

  TGtkPrivateWidget = class(TGtkPrivate)
  private
  protected
  public
    class procedure SetZPosition(const AWinControl: TWinControl; const APosition: TWSZPosition); virtual;
    class procedure UpdateCursor(AInfo: PWidgetInfo); virtual;
    class procedure SetDefaultCursor(AInfo: PWidgetInfo); virtual;
  end;
  TGtkPrivateWidgetClass = class of TGtkPrivateWidget;
  
  { TGtkPrivateEntry }
  { Private class for gtkentries (text fields) }
  
  TGtkPrivateEntry = class(TGtkPrivateWidget)
  private
  protected
  public
    class procedure SetDefaultCursor(AInfo: PWidgetInfo); override;
  end;

  { TGtkPrivateContainer }
  { Private class for gtkcontainers }

  TGtkPrivateContainer = class(TGtkPrivateWidget)
  private
  protected
  public
  end;
  
  
  { ------------------------------------}
  { temp classes to keep things working }
  
  { TGtkWSScrollingPrivate }
  { we may want to use something  like a compund class }

  TGtkPrivateScrolling = class(TGtkPrivateContainer)
  private
  protected
  public
    class procedure SetZPosition(const AWinControl: TWinControl; const APosition: TWSZPosition); override;
  end;
  
  TGtkPrivateScrollingWinControl = class(TGtkPrivateScrolling)
  private
  protected
  public
    class procedure SetZPosition(const AWinControl: TWinControl; const APosition: TWSZPosition); override;
  end;
  { ------------------------------------}




  { TGtkPrivateBin }
  { Private class for gtkbins }

  TGtkPrivateBin = class(TGtkPrivateContainer)
  private
  protected
  public
  end;


  { TGtkPrivateWindow }
  { Private class for gtkwindows }

  TGtkPrivateWindow = class(TGtkPrivateBin)
  private
  protected
  public
  end;


  { TGtkPrivateDialog }
  { Private class for gtkdialogs }

  TGtkPrivateDialog = class(TGtkPrivateWindow)
  private
  protected
  public
  end;


  { TGtkPrivateButton }
  { Private class for gtkbuttons }

  TGtkPrivateButton = class(TGtkPrivateBin)
  private
  protected
  public
  end;

  { TGtkPrivateList }
  { Private class for gtklists }

  TGtkPrivateListClass = class of TGtkPrivateList;
  TGtkPrivateList = class(TGtkPrivateScrolling)
  private
  protected
  public
    class procedure SetCallbacks(const AGtkWidget: PGtkWidget; const AWidgetInfo: PWidgetInfo); virtual;
  end;

  { TGtkPrivateNotebook }
  { Private class for gtknotebooks }

  TGtkPrivateNotebook = class(TGtkPrivateBin)
  private
  protected
  public
  end;
  
  { TGtkPrivatePaned }
  { Private class for gtkpaned }
  TGtkPrivatePaned = class(TGtkPrivateContainer)
  private
  protected
  public
    class procedure UpdateCursor(AInfo: PWidgetInfo); override;
  end;
  

function GetWidgetWithWindow(const AHandle: THandle): PGtkWidget;
procedure SetWindowCursor(AWindow: PGdkWindow; ACursor: HCursor; ARecursive: Boolean);
procedure SetCursorForWindowsWithInfo(AWindow: PGdkWindow; AInfo: PWidgetInfo);

implementation

// some circles are needed.
uses
  GtkInt;

// Helper functions

function GetWidgetWithWindow(const AHandle: THandle): PGtkWidget;
var
  Children: PGList;
begin
  Result := PGTKWidget(AHandle);
  while (Result <> nil) and GTK_WIDGET_NO_WINDOW(Result)
  and GtkWidgetIsA(Result,gtk_container_get_type) do
  begin
    Children := gtk_container_children(PGtkContainer(Result));
    if Children = nil
    then Result := nil
    else Result := Children^.Data;
  end;
end;

{------------------------------------------------------------------------------
  procedure: SetWindowCursor
  Params:  AWindow : PGDkWindow, ACursor: HCursor, ARecursive: Boolean
  Returns: Nothing

  Sets the cursor for a window (or recursively for window with children)
 ------------------------------------------------------------------------------}
procedure SetWindowCursor(AWindow: PGdkWindow; ACursor: HCursor; ARecursive: Boolean);
var
  Cursor: PGdkCursor;

  procedure SetCursorRecursive(AWindow: PGdkWindow);
  var
    ChildWindows, ListEntry: PGList;
  begin
    gdk_window_set_cursor(AWindow, Cursor);

    ChildWindows := gdk_window_get_children(AWindow);

    ListEntry := ChildWindows;
    while ListEntry <> nil do
    begin
      SetCursorRecursive(PGdkWindow(ListEntry^.Data));
      ListEntry := ListEntry^.Next;
    end;
    g_list_free(ChildWindows);
  end;
begin
  Cursor := PGdkCursor(ACursor);
  if Cursor = nil then Exit;
  if ARecursive
  then SetCursorRecursive(AWindow)
  else gdk_window_set_cursor(AWindow, Cursor);
end;

procedure SetCursorForWindowsWithInfo(AWindow: PGdkWindow; AInfo: PWidgetInfo);
var
  Cursor: PGdkCursor;
  Data: gpointer;
  Info: PWidgetInfo;

  procedure SetCursorRecursive(AWindow: PGdkWindow);
  var
    ChildWindows, ListEntry: PGList;
  begin
    gdk_window_get_user_data(AWindow, @Data);
    if (Data <> nil) and GTK_IS_WIDGET(Data) then
    begin
      Info := GetWidgetInfo(PGtkWidget(Data), False);
      if Info = AInfo then
        gdk_window_set_cursor(AWindow, Cursor);
    end;

    ChildWindows := gdk_window_get_children(AWindow);

    ListEntry := ChildWindows;
    while ListEntry <> nil do
    begin
      SetCursorRecursive(PGdkWindow(ListEntry^.Data));
      ListEntry := ListEntry^.Next;
    end;
    g_list_free(ChildWindows);
  end;
begin
  if AInfo = nil then Exit;
  Cursor := PGdkCursor(AInfo^.ControlCursor);
  if Cursor = nil then Exit;
  SetCursorRecursive(AWindow);
end;

{ TGtkPrivateScrolling }
{ temp class to keep things working }

class procedure TGtkPrivateScrolling.SetZPosition(const AWinControl: TWinControl; const APosition: TWSZPosition);
var
  ScrollWidget: PGtkScrolledWindow;
//  WidgetInfo: PWidgetInfo;
  Widget: PGtkWidget;
begin
  if not WSCheckHandleAllocated(AWincontrol, 'SetZPosition')
  then Exit;

  ScrollWidget := Pointer(AWinControl.Handle);
//  WidgetInfo := GetWidgetInfo(ScrollWidget);
  // Some controls have viewports, so we get the first window.
  Widget := GetWidgetWithWindow(AWinControl.Handle);

  case APosition of
    wszpBack:  begin
      //gdk_window_lower(WidgetInfo^.CoreWidget^.Window);
      gdk_window_lower(Widget^.Window);
      if ScrollWidget^.hscrollbar <> nil
      then gdk_window_lower(ScrollWidget^.hscrollbar^.Window);
      if ScrollWidget^.vscrollbar <> nil
      then gdk_window_lower(ScrollWidget^.vscrollbar^.Window);
    end;
    wszpFront: begin
      //gdk_window_raise(WidgetInfo^.CoreWidget^.Window);
      gdk_window_raise(Widget^.Window);
      if ScrollWidget^.hscrollbar <> nil
      then gdk_window_raise(ScrollWidget^.hscrollbar^.Window);
      if ScrollWidget^.vscrollbar <> nil
      then gdk_window_raise(ScrollWidget^.vscrollbar^.Window);
    end;
  end;
end;

{ TGtkPrivateScrollingWinControl }

class procedure TGtkPrivateScrollingWinControl.SetZPosition(
  const AWinControl: TWinControl; const APosition: TWSZPosition);
var
  Widget: PGtkWidget;
  ScrollWidget: PGtkScrolledWindow;
//  WidgetInfo: PWidgetInfo;
begin
  if not WSCheckHandleAllocated(AWincontrol, 'SetZPosition')
  then Exit;

  //TODO: when all scrolling controls are "derived" from TGtkWSBaseScrollingWinControl
  //      retrieve scrollbars from WidgetInfo^.Userdata. In that case, the following
  //      code can be removed and a call to TGtkWSBaseScrollingWinControl.SetZPosition
  //      can be made. This is not possible now since we have a frame around us

  Widget := Pointer(AWinControl.Handle);
  //  WidgetInfo := GetWidgetInfo(Widget);

  // Only do the scrollbars, leave the core to the default (we might have a viewport)
  TGtkPrivateWidget.SetZPosition(AWinControl, APosition);

  if GtkWidgetIsA(Widget, gtk_frame_get_type) then
    ScrollWidget := PGtkScrolledWindow(PGtkFrame(Widget)^.Bin.Child)
  else
  if GtkWidgetIsA(Widget, gtk_scrolled_window_get_type) then
    ScrollWidget := PGtkScrolledWindow(Widget)
  else
    ScrollWidget := nil;

  if ScrollWidget <> nil then
  begin
    case APosition of
      wszpBack:  begin
        // gdk_window_lower(WidgetInfo^.CoreWidget^.Window);
        if ScrollWidget^.hscrollbar <> nil then
        begin
          {$ifndef gtk1}
          if GDK_IS_WINDOW(ScrollWidget^.hscrollbar^.Window) then
          {$endif}
            gdk_window_lower(ScrollWidget^.hscrollbar^.Window);
        end;

        if ScrollWidget^.vscrollbar <> nil then
        begin
          {$ifndef gtk1}
          if GDK_IS_WINDOW(ScrollWidget^.vscrollbar^.Window) then
          {$endif}
            gdk_window_lower(ScrollWidget^.vscrollbar^.Window);
        end;
      end;
      wszpFront: begin
        // gdk_window_raise(WidgetInfo^.CoreWidget^.Window);
        if ScrollWidget^.hscrollbar <> nil then
        begin
          {$ifndef gtk1}
          if GDK_IS_WINDOW(ScrollWidget^.hscrollbar^.Window) then
          {$endif}
            gdk_window_raise(ScrollWidget^.hscrollbar^.Window);
        end;
        if ScrollWidget^.vscrollbar <> nil then
        begin
          {$ifndef gtk1}
          if GDK_IS_WINDOW(ScrollWidget^.vscrollbar^.Window) then
          {$endif}
            gdk_window_raise(ScrollWidget^.vscrollbar^.Window);
        end;
      end;
    end;
  end;
end;

{$I gtkprivatewidget.inc}
{$I gtkprivatelist.inc}

end.