1{ $Id: gtkwscontrols.pp 57164 2018-01-27 18:12:35Z ondrej $}
2{
3 *****************************************************************************
4 *                             GtkWSControls.pp                              *
5 *                             ----------------                              *
6 *                                                                           *
7 *                                                                           *
8 *****************************************************************************
9
10 *****************************************************************************
11  This file is part of the Lazarus Component Library (LCL)
12
13  See the file COPYING.modifiedLGPL.txt, included in this distribution,
14  for details about the license.
15 *****************************************************************************
16}
17unit GtkWSControls;
18
19{$mode objfpc}{$H+}
20
21{$DEFINE UseGDKErrorTrap}
22
23interface
24
25uses
26  {$IFDEF GTK2}
27  Gtk2, Glib2, Gdk2, Gdk2Pixbuf,
28  {$ELSE}
29  Gtk, Glib, Gdk,
30  {$ENDIF}
31  SysUtils, Classes, Controls, LMessages, InterfaceBase,
32  WSControls, WSLCLClasses, WSProc,
33  Graphics, ComCtrls, Forms, LCLType,
34  GtkDef, GTKExtra, GtkDebug;
35
36type
37
38  { TGtkWSDragImageListResolution }
39
40  TGtkWSDragImageListResolution = class(TWSDragImageListResolution)
41  published
42    class function BeginDrag(const ADragImageList: TDragImageListResolution; Window: HWND; AIndex, X, Y: Integer): Boolean; override;
43    class function DragMove(const ADragImageList: TDragImageListResolution; X, Y: Integer): Boolean; override;
44    class procedure EndDrag(const ADragImageList: TDragImageListResolution); override;
45    class function HideDragImage(const ADragImageList: TDragImageListResolution;
46      ALockedWindow: HWND; DoUnLock: Boolean): Boolean; override;
47    class function ShowDragImage(const ADragImageList: TDragImageListResolution;
48      ALockedWindow: HWND; X, Y: Integer; DoLock: Boolean): Boolean; override;
49  end;
50
51  { TGtkWSControl }
52
53  TGtkWSControl = class(TWSControl)
54  published
55  end;
56
57
58  { TGtkWSWinControl }
59
60  TGtkWSWinControl = class(TWSWinControl)
61  private
62  protected
63  {$IFDEF GTK1}
64    class procedure SetCCCallbacks(const AWidget: PGtkWidget; const AWidgetInfo: PWidgetInfo);
65  {$ENDIF}
66  public
67    // Internal public
68    class procedure SetCallbacks(const AGTKObject: PGTKObject; const AComponent: TComponent);
69  published
70  {$IFDEF GTK1}
71    class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): HWND; override;
72  {$ENDIF}
73    class procedure AddControl(const AControl: TControl); override;
74    class function  CanFocus(const AWinControl: TWinControl): Boolean; override;
75    class procedure ConstraintsChange(const AWinControl: TWinControl); override;
76    class procedure DestroyHandle(const AWinControl: TWinControl); override;
77    class procedure Invalidate(const AWinControl: TWinControl); override;
78
79    class function  GetText(const AWinControl: TWinControl; var AText: String): Boolean; override;
80
81    class procedure SetBorderStyle(const AWinControl: TWinControl; const ABorderStyle: TBorderStyle); override;
82    class procedure SetBounds(const AWinControl: TWinControl; const ALeft, ATop, AWidth, AHeight: Integer); override;
83    class procedure SetChildZPosition(const AWinControl, AChild: TWinControl; const AOldPos, ANewPos: Integer; const AChildren: TFPList); override;
84    class procedure SetColor(const AWinControl: TWinControl); override;
85    class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override;
86    class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
87    class procedure SetSize(const AWinControl: TWinControl; const AWidth, AHeight: Integer); override;
88    class procedure SetPos(const AWinControl: TWinControl; const ALeft, ATop: Integer); override;
89    class procedure SetText(const AWinControl: TWinControl; const AText: string); override;
90    class procedure SetShape(const AWinControl: TWinControl; const AShape: HBITMAP); override;
91
92    class procedure PaintTo(const AWinControl: TWinControl; ADC: HDC; X, Y: Integer); override;
93    class procedure ShowHide(const AWinControl: TWinControl); override;
94  end;
95
96  { TGtkWSGraphicControl }
97
98  TGtkWSGraphicControl = class(TWSGraphicControl)
99  published
100  end;
101
102  { TGtkWSCustomControl }
103
104  TGtkWSCustomControl = class(TWSCustomControl)
105  published
106  end;
107
108  { TGtkWSImageList }
109
110  TGtkWSImageList = class(TWSImageList)
111  published
112  end;
113
114  { TGtkWSBaseScrollingWinControl }
115  {
116    TGtkWSBaseScrollingWinControl is a shared gtk only base implementation of
117    all scrolling widgets, like TListView, TScrollingWinControl etc.
118    It only creates a scrolling widget and handles the LM_HSCROLL and LM_VSCROLL
119    messages
120  }
121  PBaseScrollingWinControlData = ^TBaseScrollingWinControlData;
122  TBaseScrollingWinControlData = record
123    HValue: Integer;
124    HScroll: PGTKWidget;
125    VValue: Integer;
126    VScroll: PGTKWidget;
127  end;
128
129  { TGtkWSBaseScrollingWinControl }
130
131  TGtkWSBaseScrollingWinControl = class(TWSWinControl)
132  public
133    class procedure SetCallbacks(const AWidget: PGtkWidget; const AWidgetInfo: PWidgetInfo); virtual;
134  published
135    class function  CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): HWND; override;
136  end;
137
138procedure GtkWindowShowModal(GtkWindow: PGtkWindow);
139function GetWidgetHAdjustment(AWidget: PGTKWidget): PGTKAdjustment;
140function GetWidgetVAdjustment(AWidget: PGTKWidget): PGTKAdjustment;
141
142implementation
143
144uses
145  GTKWSPrivate,
146  {$ifdef gtk1}
147  GTK1WSPrivate,
148  {$endif}
149  GtkInt, gtkglobals, gtkproc, GTKWinApiWindow,
150  StdCtrls, LCLProc, LCLIntf;
151
152
153
154{ TGtkWSWinControl }
155
156type
157  TWinControlHack = class(TWinControl)
158  end;
159
160class procedure TGtkWSWinControl.AddControl(const AControl: TControl);
161var
162  AParent: TWinControl;
163  ParentWidget: PGTKWidget;
164  ChildWidget: PGTKWidget;
165  pFixed: PGTKWidget;
166begin
167  {$IFDEF OldToolBar}
168  if (AControl.Parent is TToolbar) then
169    exit;
170  {$ENDIF}
171
172  AParent := TWinControl(AControl).Parent;
173  //debugln('LM_AddChild: ',TWinControl(Sender).Name,' ',dbgs(AParent<>nil));
174  if not Assigned(AParent) then
175    Assert(true, Format('Trace: [TGtkWSWinControl.AddControl] %s --> Parent is not assigned', [AControl.ClassName]))
176  else
177  begin
178    //DebugLn(Format('Trace:  [TGtkWSWinControl.AddControl] %s --> Calling Add Child: %s', [AParent.ClassName, AControl.ClassName]));
179    ParentWidget := Pgtkwidget(AParent.Handle);
180    pFixed := GetFixedWidget(ParentWidget);
181    if pFixed <> ParentWidget then
182    begin
183      // parent changed for child
184      ChildWidget := PGtkWidget(TWinControl(AControl).Handle);
185      FixedPutControl(pFixed, ChildWidget, AControl.Left, AControl.Top);
186      RegroupAccelerator(ChildWidget);
187    end;
188  end;
189end;
190
191class function TGtkWSWinControl.CanFocus(const AWinControl: TWinControl): Boolean;
192var
193  Widget, FocusWidget: PGtkWidget;
194begin
195  if AWinControl.HandleAllocated then
196  begin
197    Widget := PGtkWidget(AWinControl.Handle);
198    FocusWidget := FindFocusWidget(Widget);
199    Result := (FocusWidget <> nil) and GTK_WIDGET_CAN_FOCUS(FocusWidget);
200  end else
201    Result := False;
202end;
203
204class procedure TGtkWSWinControl.ConstraintsChange(const AWinControl: TWinControl);
205var
206  Widget: PGtkWidget;
207  Geometry: TGdkGeometry;
208begin
209  Widget := PGtkWidget(AWinControl.Handle);
210  if (Widget <> nil) and (GtkWidgetIsA(Widget, gtk_window_get_type)) then
211  begin
212    with Geometry do
213    begin
214      if AWinControl.Constraints.MinWidth > 0 then
215        min_width := AWinControl.Constraints.MinWidth
216      else
217        min_width := 1;
218      if AWinControl.Constraints.MaxWidth > 0 then
219        max_width := AWinControl.Constraints.MaxWidth
220      else
221        max_width := 32767;
222      if AWinControl.Constraints.MinHeight > 0 then
223        min_height := AWinControl.Constraints.MinHeight
224      else
225        min_height := 1;
226      if AWinControl.Constraints.MaxHeight > 0 then
227        max_height := AWinControl.Constraints.MaxHeight
228      else
229        max_height := 32767;
230
231      base_width := AWinControl.Width;
232      base_height := AWinControl.Height;
233      width_inc := 1;
234      height_inc := 1;
235      min_aspect := 0;
236      max_aspect := 1;
237    end;
238    //debugln('TGtkWSWinControl.ConstraintsChange A ',GetWidgetDebugReport(Widget),' max=',dbgs(Geometry.max_width),'x',dbgs(Geometry.max_height));
239    gtk_window_set_geometry_hints(PGtkWindow(Widget), nil, @Geometry,
240                                  GDK_HINT_MIN_SIZE or GDK_HINT_MAX_SIZE);
241  end;
242end;
243
244class procedure TGtkWSWinControl.DestroyHandle(const AWinControl: TWinControl);
245begin
246  //DebugLn('TGtkWSWinControl.DestroyHandle ',DbgSName(AWinControl));
247  TGtkWidgetSet(WidgetSet).DestroyLCLComponent(AWinControl);
248end;
249
250class function TGtkWSWinControl.GetText(const AWinControl: TWinControl; var AText: String): Boolean;
251var
252  CS: PChar;
253  Handle: HWND;
254begin
255  Result := False;
256  if not WSCheckHandleAllocated(AWinControl, 'GetText')
257  then Exit;
258
259  Result := true;
260  Handle := AWinControl.Handle;
261  case AWinControl.fCompStyle of
262   csComboBox:
263     begin
264       AText := StrPas(gtk_entry_get_text(PGtkEntry(PGtkCombo(Handle)^.entry)));
265     end;
266
267   csEdit, csSpinEdit:
268       AText:= StrPas(gtk_entry_get_text(PgtkEntry(Handle)));
269
270   csMemo    : begin
271                  CS := gtk_editable_get_chars(PGtkOldEditable(
272                    GetWidgetInfo(Pointer(Handle), True)^.CoreWidget), 0, -1);
273                  AText := StrPas(CS);
274                  g_free(CS);
275               end;
276  else
277    Result := false;
278  end;
279end;
280
281class procedure TGtkWSWinControl.Invalidate(const AWinControl: TWinControl);
282begin
283  if not WSCheckHandleAllocated(AWinControl, 'Invalidate')
284  then Exit;
285
286  //DebugLn('Trace:Trying to invalidate window... !!!');
287  gtk_widget_queue_draw(PGtkWidget(AWinControl.Handle));
288end;
289
290class procedure TGtkWSWinControl.ShowHide(const AWinControl: TWinControl);
291begin
292  // other methods use ShowHide also, can't move code
293  TGtkWidgetSet(WidgetSet).SetVisible(AWinControl, AWinControl.HandleObjectShouldBeVisible);
294end;
295
296class procedure TGtkWSWinControl.SetBounds(const AWinControl: TWinControl;
297  const ALeft, ATop, AWidth, AHeight: Integer);
298begin
299  if not WSCheckHandleAllocated(AWinControl, 'SetBounds')
300  then Exit;
301
302  ResizeHandle(AWinControl);
303end;
304
305class procedure TGtkWSWinControl.SetBorderStyle(const AWinControl: TWinControl;
306  const ABorderStyle: TBorderStyle);
307var
308  Widget: PGtkWidget;
309begin
310  if not WSCheckHandleAllocated(AWinControl, 'SetBorderStyle')
311  then Exit;
312
313  Widget := PGtkWidget(AWinControl.Handle);
314  if GtkWidgetIsA(Widget, GTKAPIWidget_GetType) then
315    GTKAPIWidget_SetShadowType(PGTKAPIWidget(Widget), BorderStyleShadowMap[ABorderStyle])
316  else
317  if GTK_IS_FRAME(Widget) then
318    gtk_frame_set_shadow_type(PGtkFrame(Widget), BorderStyleShadowMap[ABorderStyle])
319  else
320  if GTK_IS_VIEWPORT(Widget) then
321    gtk_viewport_set_shadow_type(PGtkViewport(Widget), BorderStyleShadowMap[ABorderStyle]);
322end;
323
324{$IFDEF GTK1}
325class procedure TGtkWSWinControl.SetCCCallbacks(const AWidget: PGtkWidget;
326  const AWidgetInfo: PWidgetInfo);
327begin
328  SetCallbacks(PGtkObject(AWidget), TComponent(AWidgetInfo^.LCLObject));
329  with TGTKWidgetSet(Widgetset) do
330  begin
331    SetCallback(LM_HSCROLL, PGtkObject(AWidget), AWidgetInfo^.LCLObject);
332    SetCallback(LM_VSCROLL, PGtkObject(AWidget), AWidgetInfo^.LCLObject);
333  end;
334end;
335{$ENDIF}
336
337class procedure TGtkWSWinControl.SetCallbacks(const AGTKObject: PGTKObject;
338  const AComponent: TComponent);
339begin
340  GtkWidgetSet.SetCommonCallbacks(AGtkObject, AComponent);
341end;
342
343{$IFDEF GTK1}
344class function TGtkWSWinControl.CreateHandle(const AWinControl: TWinControl;
345  const AParams: TCreateParams): HWND;
346var
347  Widget: PGtkWidget;
348  WidgetInfo: PWidgetInfo;
349  Allocation: TGTKAllocation;
350begin
351  Widget := TGtkWidgetset(Widgetset).CreateAPIWidget(AWinControl);
352  {$IFDEF DebugLCLComponents}
353  DebugGtkWidgets.MarkCreated(Widget, dbgsName(AWinControl));
354  {$ENDIF}
355
356  Result := THandle(PtrUInt(Widget));
357  if Result = 0 then Exit;
358
359  WidgetInfo := GetWidgetInfo(Widget); // Widget info already created in CreateAPIWidget
360  WidgetInfo^.Style := AParams.Style;
361  WidgetInfo^.ExStyle := AParams.ExStyle;
362  WidgetInfo^.WndProc := PtrUInt(AParams.WindowClass.lpfnWndProc);
363
364  // set allocation
365  Allocation.X := AParams.X;
366  Allocation.Y := AParams.Y;
367  Allocation.Width := AParams.Width;
368  Allocation.Height := AParams.Height;
369  gtk_widget_size_allocate(Widget, @Allocation);
370
371  Set_RC_Name(AWinControl, Widget);
372  SetCCCallbacks(Widget, WidgetInfo);
373end;
374{$ENDIF}
375
376class procedure TGtkWSWinControl.SetChildZPosition(
377  const AWinControl, AChild: TWinControl;
378  const AOldPos, ANewPos: Integer; const AChildren: TFPList);
379var
380  n: Integer;
381  child: TWinControlHack;
382begin
383  if not WSCheckHandleAllocated(AWincontrol, 'SetChildZPosition')
384  then Exit;
385
386  if ANewPos < AChildren.Count div 2
387  then begin
388    // move down (and others below us)
389    for n := ANewPos downto 0 do
390    begin
391      child := TWinControlHack(AChildren[n]);
392      if child.HandleAllocated
393      then TGtkPrivateWidgetClass(child.WidgetSetClass.WSPrivate).
394                  SetZPosition(child, wszpBack);
395    end;
396  end
397  else begin
398    // move up (and others above us)
399    for n := ANewPos to AChildren.Count - 1 do
400    begin
401      child := TWinControlHack(AChildren[n]);
402      if child.HandleAllocated
403      then TGtkPrivateWidgetClass(child.WidgetSetClass.WSPrivate).SetZPosition(child, wszpFront);
404    end;
405  end;
406end;
407
408class procedure TGtkWSWinControl.SetCursor(const AWinControl: TWinControl; const ACursor: HCursor);
409var
410  WidgetInfo: PWidgetInfo;
411begin
412  if not WSCheckHandleAllocated(AWinControl, 'SetCursor')
413  then Exit;
414
415  WidgetInfo := GetWidgetInfo(Pointer(AWinControl.Handle));
416  if (WidgetInfo^.ControlCursor = ACursor) and
417     (WidgetInfo^.DefaultCursor <> HCursor(-1)) then Exit;
418  if ACursor <> Screen.Cursors[crDefault] then
419    WidgetInfo^.ControlCursor := ACursor
420  else
421  begin
422    if WidgetInfo^.DefaultCursor = HCursor(-1) then
423      TGtkPrivateWidgetClass(AWinControl.WidgetSetClass.WSPrivate).SetDefaultCursor(WidgetInfo);
424    WidgetInfo^.ControlCursor := WidgetInfo^.DefaultCursor;
425  end;
426  TGtkPrivateWidgetClass(AWinControl.WidgetSetClass.WSPrivate).UpdateCursor(WidgetInfo);
427end;
428
429class procedure TGtkWSWinControl.SetFont(const AWinControl: TWinControl;
430  const AFont: TFont);
431var
432  Widget: PGtkWidget;
433begin
434  if not WSCheckHandleAllocated(AWinControl, 'SetFont')
435  then Exit;
436
437  Widget := PGtkWidget(AWinControl.Handle);
438  if GtkWidgetIsA(Widget, GTKAPIWidget_GetType) then
439    exit;
440
441  //DebugLn('TGtkWSWinControl.SetFont ',DbgSName(AWinControl));
442  GtkWidgetSet.SetWidgetFont(Widget, AFont);
443  GtkWidgetSet.SetWidgetColor(Widget, AFont.Color, clNone,
444                              [GTK_STATE_NORMAL,GTK_STATE_ACTIVE,
445                               GTK_STATE_PRELIGHT,GTK_STATE_SELECTED
446                               {$IFDEF GTK2},GTK_STYLE_TEXT{$ENDIF}]);
447end;
448
449class procedure TGtkWSWinControl.SetPos(const AWinControl: TWinControl;
450  const ALeft, ATop: Integer);
451var
452  Widget: PGtkWidget;
453  Allocation: TGTKAllocation;
454begin
455  if not WSCheckHandleAllocated(AWinControl, 'SetPos')
456  then Exit;
457  {$IFDEF VerboseSizeMsg}
458  DebugLn(['TGtkWSWinControl.SetPos ',DbgSName(AWinControl),' ',ALeft,',',ATop]);
459  {$ENDIF}
460
461  Widget := PGtkWidget(AWinControl.Handle);
462  Allocation.X := gint16(ALeft);
463  Allocation.Y := gint16(ATop);
464  Allocation.Width := guint16(Widget^.Allocation.Width);
465  Allocation.Height := guint16(Widget^.Allocation.Height);
466  gtk_widget_size_allocate(Widget, @Allocation);// Beware: this triggers callbacks
467end;
468
469class procedure TGtkWSWinControl.SetSize(const AWinControl: TWinControl;
470  const AWidth, AHeight: Integer);
471var
472  Widget: PGtkWidget;
473  Allocation: TGTKAllocation;
474begin
475  if not WSCheckHandleAllocated(AWinControl, 'SetSize')
476  then Exit;
477  {$IFDEF VerboseSizeMsg}
478  DebugLn(['TGtkWSWinControl.SetSize ',DbgSName(AWinControl),' ',AWidth,',',AHeight]);
479  {$ENDIF}
480
481  Widget := PGtkWidget(AWinControl.Handle);
482  Allocation.X := Widget^.Allocation.X;
483  Allocation.Y := Widget^.Allocation.Y;
484  Allocation.Width := guint16(AWidth);
485  Allocation.Height := guint16(AHeight);
486  gtk_widget_size_allocate(Widget, @Allocation);// Beware: this triggers callbacks
487end;
488
489class procedure TGtkWSWinControl.SetColor(const AWinControl: TWinControl);
490begin
491  if not WSCheckHandleAllocated(AWinControl, 'SetColor')
492  then Exit;
493
494  if ((csOpaque in AWinControl.ControlStyle) and
495      GtkWidgetIsA(pGtkWidget(AWinControl.handle),GTKAPIWidget_GetType)) then
496    Exit;
497
498  //DebugLn('TGtkWSWinControl.SetColor ',DbgSName(AWinControl));
499  GtkWidgetSet.SetWidgetColor(PGtkWidget(AWinControl.Handle),
500                              AWinControl.Font.Color, AWinControl.Color,
501                              [GTK_STATE_NORMAL, GTK_STATE_ACTIVE,
502                               GTK_STATE_PRELIGHT, GTK_STATE_SELECTED]);
503//    GtkWidgetSet.setWidgetFont(pGtkWidget(AWinControl.handle),aWinControl.font);
504  UpdateWidgetStyleOfControl(AWinControl);
505end;
506
507class procedure TGtkWSWinControl.SetText(const AWinControl: TWinControl;
508  const AText: string);
509
510  procedure SetNotebookPageTabLabel;
511  var
512    NoteBookWidget: PGtkWidget; // the notebook
513    PageWidget: PGtkWidget;     // the page (content widget)
514    TabWidget: PGtkWidget;      // the tab (hbox containing a pixmap, a label
515                                //          and a close button)
516    TabLabelWidget: PGtkWidget; // the label in the tab
517    MenuWidget: PGtkWidget;     // the popup menu (hbox containing a pixmap and
518                                // a label)
519    MenuLabelWidget: PGtkWidget; // the label in the popup menu item
520    NewText: PChar;
521  begin
522    // dig through the hierachy to get the labels
523    NoteBookWidget:=PGtkWidget((AWinControl.Parent).Handle);
524    PageWidget:=PGtkWidget(AWinControl.Handle);
525    TabWidget:=gtk_notebook_get_tab_label(PGtkNoteBook(NotebookWidget),
526                                          PageWidget);
527    if TabWidget<>nil then
528      TabLabelWidget:=gtk_object_get_data(PGtkObject(TabWidget), 'TabLabel')
529    else
530      TabLabelWidget:=nil;
531    MenuWidget:=gtk_notebook_get_menu_label(PGtkNoteBook(NotebookWidget),
532                                            PageWidget);
533    if MenuWidget<>nil then
534      MenuLabelWidget:=gtk_object_get_data(PGtkObject(MenuWidget), 'TabLabel')
535    else
536      MenuLabelWidget:=nil;
537    // set new text
538    NewText:=PChar(AText);
539    if TabLabelWidget<>nil then
540      gtk_label_set_text(pGtkLabel(TabLabelWidget), NewText);
541    if MenuLabelWidget<>nil then
542      gtk_label_set_text(pGtkLabel(MenuLabelWidget), NewText);
543  end;
544
545var
546  P : Pointer;
547  aLabel, pLabel: pchar;
548begin
549  if not WSCheckHandleAllocated(AWinControl, 'SetText')
550  then Exit;
551
552  //TODO: create classprocedures for this in the corresponding classes
553
554  P := Pointer(AWinControl.Handle);
555  Assert(p <> nil, 'Trace:WARNING: [TGtkWidgetSet.SetLabel] --> got nil pointer');
556  //DebugLn('Trace:Setting Str1 in SetLabel');
557  pLabel := pchar(AText);
558
559  case AWinControl.fCompStyle of
560  csBitBtn,
561  csButton: DebugLn('[WARNING] Obsolete call to TGTKOBject.SetLabel for ', AWinControl.ClassName);
562
563{$IFDEF OldToolBar}
564  csToolButton:
565    with PgtkButton(P)^ do
566    begin
567      //aLabel := StrAlloc(Length(AnsiString(PLabel)) + 1);
568      aLabel := Ampersands2Underscore(PLabel);
569      Try
570        //StrPCopy(aLabel, AnsiString(PLabel));
571        //Accel := Ampersands2Underscore(aLabel);
572        if gtk_bin_get_child(P) = nil then
573        begin
574          //DebugLn(Format('trace:  [TGtkWidgetSet.SetLabel] %s has no child label', [AWinControl.ClassName]));
575           gtk_container_add(P, gtk_label_new(aLabel));
576        end
577        else begin
578          //DebugLn(Format('trace:  [TGtkWidgetSet.SetLabel] %s has child label', [AWinControl.ClassName]));
579          gtk_label_set_text(pgtkLabel( gtk_bin_get_child(P)), aLabel);
580        end;
581        //If Accel <> -1 then
582        AccelKey:=gtk_label_parse_uline(PGtkLabel( gtk_bin_get_child(P)), aLabel);
583        Accelerate(AWinControl,PGtkWidget(P),AccelKey,0,'clicked');
584      Finally
585        StrDispose(aLabel);
586      end;
587    end;
588{$ENDIF OldToolBar}
589
590  csForm,
591  csFileDialog, csOpenFileDialog, csSaveFileDialog, csSelectDirectoryDialog,
592  csPreviewFileDialog,
593  csColorDialog,
594  csFontDialog:
595    if GtkWidgetIsA(p,gtk_window_get_type) then
596      gtk_window_set_title(pGtkWindow(p),PLabel);
597
598  csCheckBox,
599  csToggleBox,
600  csRadioButton:
601    begin
602      aLabel := Ampersands2Underscore(PLabel);
603      Try
604        gtk_label_set_text(
605                    pGtkLabel(gtk_bin_get_child(PGtkBin(@PGTKToggleButton(p)^.Button))),
606                    aLabel);
607        gtk_label_parse_uline(pGtkLabel(gtk_bin_get_child(PGtkBin(@PGTKToggleButton(p)^.Button))),
608          aLabel);
609      Finally
610        StrDispose(aLabel);
611      end;
612    end;
613
614  csEdit        : begin
615                    LockOnChange(PGtkObject(p),+1);
616                    gtk_entry_set_text(pGtkEntry(P), pLabel);
617                    LockOnChange(PGtkObject(p),-1);
618                  end;
619
620  csSpinEdit    : begin
621                    LockOnChange(PGtkObject(p),+1);
622                    gtk_entry_set_text(pGtkEntry(P), pLabel);
623                    gtk_spin_button_update(PGtkSpinButton(p));
624                    LockOnChange(PGtkObject(p),-1);
625                  end;
626
627  csMemo        : begin
628                    P:= GetWidgetInfo(P, True)^.CoreWidget;
629                    //debugln('TGtkWSWinControl.SetText A ',dbgs(gtk_text_get_length(PGtkText(P))),' AText="',AText,'"');
630                    gtk_text_freeze(PGtkText(P));
631                    gtk_text_set_point(PGtkText(P), 0);
632                    gtk_text_forward_delete(PGtkText(P), gtk_text_get_length(PGtkText(P)));
633                    gtk_text_insert(PGtkText(P), nil, nil, nil, pLabel, -1);
634                    gtk_text_thaw(PGtkText(P));
635                    //debugln('TGtkWSWinControl.SetText B ',dbgs(gtk_text_get_length(PGtkText(P))));
636                  end;
637
638  csPage:
639    SetNotebookPageTabLabel;
640
641  else
642    // DebugLn('WARNING: [TGtkWidgetSet.SetLabel] --> not handled for class ',Sender.ClassName);
643  end;
644  //DebugLn(Format('trace:  [TGtkWidgetSet.SetLabel] %s --> END', [AWinControl.ClassName]));
645end;
646
647class procedure TGtkWSWinControl.SetShape(const AWinControl: TWinControl;
648  const AShape: HBITMAP);
649var
650  GtkWidget, FixedWidget: PGtkWidget;
651  GdkBitmap: PGDKBitmap;
652begin
653  if not WSCheckHandleAllocated(AWinControl, 'SetShape') then
654    Exit;
655
656  GtkWidget := PGtkWidget(AWinControl.Handle);
657  FixedWidget := GetFixedWidget(GtkWidget);
658
659  if AShape <> 0 then
660  begin
661    if GtkWidgetset.IsValidGDIObjectType(AShape, gdiBitmap) then
662      GdkBitmap := PGdiObject(AShape)^.GDIBitmapObject
663    else
664      GdkBitmap := nil;
665  end
666  else
667    GdkBitmap := nil;
668
669  gtk_widget_shape_combine_mask(GtkWidget, GdkBitmap, 0, 0);
670  if FixedWidget <> GtkWidget then
671    gtk_widget_shape_combine_mask(FixedWidget, GdkBitmap, 0, 0);
672end;
673
674{
675  Paint control to X, Y point of device context.
676}
677class procedure TGtkWSWinControl.PaintTo(const AWinControl: TWinControl;
678  ADC: HDC; X, Y: Integer);
679var
680  DC: TGtkDeviceContext absolute ADC;
681
682  procedure PaintWindow(AWindow: PGdkWindow; AOffset: TPoint);
683  var
684    W, H: gint;
685    {$ifndef gtk1}
686    Pixbuf: PGdkPixbuf;
687    {$endif}
688  begin
689    gdk_window_get_size(AWindow, @W, @H);
690    {$ifdef gtk1}
691    gdk_window_copy_area(DC.Drawable, DC.GC, X, Y, AWindow,
692      AOffset.X, AOffset.Y, W, H);
693    {$else}
694    // for some reason gdk_window_copy_area does not work
695    Pixbuf := gdk_pixbuf_get_from_drawable(nil, AWindow, nil,
696      AOffset.X, AOffset.Y, 0, 0, W, H);
697    gdk_pixbuf_render_to_drawable(Pixbuf, DC.Drawable, DC.GC, 0, 0, X, Y,
698      -1, -1, GDK_RGB_DITHER_NONE, 0, 0);
699    gdk_pixbuf_unref(Pixbuf);
700    {$endif}
701  end;
702
703  procedure PaintWidget(AWidget: PGtkWidget);
704  var
705    AOffset: TPoint;
706    AWindow: PGdkWindow;
707  begin
708    AWindow := GetControlWindow(AWidget);
709    AOffset := Point(AWidget^.allocation.x, AWidget^.allocation.y);
710
711    if AWindow <> nil then
712      PaintWindow(AWindow, AOffset);
713  end;
714
715begin
716  if not WSCheckHandleAllocated(AWinControl, 'PaintTo')
717  then Exit;
718  PaintWidget(GetFixedWidget(PGtkWidget(AWinControl.Handle)));
719end;
720
721{ helper/common routines }
722
723procedure GtkWindowShowModal(GtkWindow: PGtkWindow);
724begin
725  if (GtkWindow=nil) then exit;
726  UnsetResizeRequest(PgtkWidget(GtkWindow));
727
728  if ModalWindows=nil then ModalWindows:=TFPList.Create;
729  ModalWindows.Add(GtkWindow);
730  {$IFNDEF gtk_no_set_modal}
731  gtk_window_set_modal(GtkWindow, true);
732  {$ENDIF}
733  {$IFDEF Gtk1}
734  gtk_widget_show(PGtkWidget(GtkWindow));
735  GDK_WINDOW_ACTIVATE(PGdkWindowPrivate(PGtkWidget(GtkWindow)^.window));
736  {$ELSE}
737  gtk_window_present(GtkWindow);
738  {$ENDIF}
739
740  {$IFDEF VerboseTransient}
741  DebugLn('TGtkWidgetSet.ShowModal ',Sender.ClassName);
742  {$ENDIF}
743  TGtkWidgetSet(WidgetSet).UpdateTransientWindows;
744end;
745
746function GetWidgetHAdjustment(AWidget: PGTKWidget): PGTKAdjustment;
747begin
748  if GtkWidgetIsA(AWidget,GTK_TYPE_SCROLLED_WINDOW) then
749    Result:=gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(AWidget))
750  {$IFDEF Gtk2}
751  else if GtkWidgetIsA(AWidget,GTK_TYPE_TREE_VIEW) then
752    Result:=gtk_tree_view_get_hadjustment(PGtkTreeView(AWidget))
753  {$ENDIF}
754  else
755    Result:=nil;
756end;
757
758function GetWidgetVAdjustment(AWidget: PGTKWidget): PGTKAdjustment;
759begin
760  if GtkWidgetIsA(AWidget,GTK_TYPE_SCROLLED_WINDOW) then
761    Result:=gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(AWidget))
762  {$IFDEF Gtk2}
763  else if GtkWidgetIsA(AWidget,GTK_TYPE_TREE_VIEW) then
764    Result:=gtk_tree_view_get_vadjustment(PGtkTreeView(AWidget))
765  {$ENDIF}
766  else
767    Result:=nil;
768end;
769
770
771{ TGtkWSBaseScrollingWinControl }
772
773function GtkWSBaseScrollingWinControl_HValueChanged(AAdjustment: PGTKAdjustment; AInfo: PWidgetInfo): GBoolean; cdecl;
774var
775  ScrollingData: PBaseScrollingWinControlData;
776  Msg: TLMHScroll;
777  OldValue, V, U, L, StepI, PageI: Integer;
778  X, Y: GInt;
779  Mask: TGdkModifierType;
780begin
781  Result := CallBackDefaultReturn;
782  if AInfo^.ChangeLock > 0 then Exit;
783
784  ScrollingData := AInfo^.UserData;
785
786  // round values
787  V := Round(AAdjustment^.Value);
788  U := Round(AAdjustment^.Upper);
789  L := Round(AAdjustment^.Lower);
790  StepI := Round(AAdjustment^.Step_Increment);
791  PageI := Round(AAdjustment^.Page_Increment);
792
793  OldValue := ScrollingData^.HValue;
794  ScrollingData^.HValue := V;
795
796  // get keystates
797  Mask := 0;
798  if ScrollingData^.HScroll <> nil
799  then begin
800    {$IFDEF UseGDKErrorTrap}
801    BeginGDKErrorTrap;
802    {$ENDIF}
803    gdk_window_get_pointer(GetControlWindow(ScrollingData^.HScroll), @X, @Y, @Mask);
804    {$IFDEF UseGDKErrorTrap}
805    EndGDKErrorTrap;
806    {$ENDIF}
807  end;
808
809  Msg.msg := LM_HSCROLL;
810  // get scrollcode
811  if ssLeft in GTKEventStateToShiftState(Word(Mask))
812  then Msg.ScrollCode := SB_THUMBTRACK
813  else if V <= L
814  then Msg.ScrollCode := SB_TOP
815  else if V >= U
816  then Msg.ScrollCode := SB_BOTTOM
817  else if V - OldValue = StepI
818  then Msg.ScrollCode := SB_LINERIGHT
819  else if OldValue - V = StepI
820  then Msg.ScrollCode := SB_LINELEFT
821  else if V - OldValue = PageI
822  then Msg.ScrollCode := SB_PAGERIGHT
823  else if OldValue - V = PageI
824  then Msg.ScrollCode := SB_PAGELEFT
825  else Msg.ScrollCode := SB_THUMBPOSITION;
826  Msg.Pos := V;
827  if V < High(Msg.SmallPos)
828  then Msg.SmallPos := V
829  else Msg.SmallPos := High(Msg.SmallPos);
830  Msg.ScrollBar := HWND(PtrUInt(ScrollingData^.HScroll));
831
832  Result := (DeliverMessage(AInfo^.LCLObject, Msg) <> 0) xor CallBackDefaultReturn;
833end;
834
835function GtkWSBaseScrollingWinControl_VValueChanged(AAdjustment: PGTKAdjustment; AInfo: PWidgetInfo): GBoolean; cdecl;
836var
837  ScrollingData: PBaseScrollingWinControlData;
838  Msg: TLMHScroll;
839  OldValue, V, U, L, StepI, PageI: Integer;
840  X, Y: GInt;
841  Mask: TGdkModifierType;
842begin
843  Result := CallBackDefaultReturn;
844  if AInfo^.ChangeLock > 0 then Exit;
845
846  ScrollingData := AInfo^.UserData;
847
848  // round values
849  V := Round(AAdjustment^.Value);
850  U := Round(AAdjustment^.Upper);
851  L := Round(AAdjustment^.Lower);
852  StepI := Round(AAdjustment^.Step_Increment);
853  PageI := Round(AAdjustment^.Page_Increment);
854
855  OldValue := ScrollingData^.VValue;
856  ScrollingData^.VValue := V;
857
858  // get keystates
859  Mask := 0;
860  if ScrollingData^.VScroll <> nil
861  then begin
862    {$IFDEF UseGDKErrorTrap}
863    BeginGDKErrorTrap;
864    {$ENDIF}
865    gdk_window_get_pointer(GetControlWindow(ScrollingData^.VScroll), @X, @Y, @Mask);
866    {$IFDEF UseGDKErrorTrap}
867    EndGDKErrorTrap;
868    {$ENDIF}
869  end;
870
871  Msg.msg := LM_VSCROLL;
872  // Get scrollcode
873  if ssLeft in GTKEventStateToShiftState(Word(Mask))
874  then Msg.ScrollCode := SB_THUMBTRACK
875  else if V <= L
876  then Msg.ScrollCode := SB_TOP
877  else if V >= U
878  then Msg.ScrollCode := SB_BOTTOM
879  else if V - OldValue = StepI
880  then Msg.ScrollCode := SB_LINEDOWN
881  else if OldValue - V = StepI
882  then Msg.ScrollCode := SB_LINEUP
883  else if V - OldValue = PageI
884  then Msg.ScrollCode := SB_PAGEDOWN
885  else if OldValue - V = PageI
886  then Msg.ScrollCode := SB_PAGEUP
887  else Msg.ScrollCode := SB_THUMBPOSITION;
888  Msg.Pos := V;
889  if V < High(Msg.SmallPos)
890  then Msg.SmallPos := V
891  else Msg.SmallPos := High(Msg.SmallPos);
892  Msg.ScrollBar := HWND(PtrUInt(ScrollingData^.HScroll));
893
894  Result := (DeliverMessage(AInfo^.LCLObject, Msg) <> 0) xor CallBackDefaultReturn;
895end;
896
897class function TGtkWSBaseScrollingWinControl.CreateHandle(
898  const AWinControl: TWinControl; const AParams: TCreateParams): HWND;
899var
900  Widget: PGtkWidget;
901  WidgetInfo: PWidgetInfo;
902  ScrollingData: PBaseScrollingWinControlData;
903  Allocation: TGTKAllocation;
904begin
905  Widget := gtk_scrolled_window_new(nil, nil);
906  {$IFDEF DebugLCLComponents}
907  DebugGtkWidgets.MarkCreated(Widget,dbgsName(AWinControl));
908  {$ENDIF}
909
910  Result := THandle(PtrUInt(Widget));
911  if Result = 0 then Exit;
912
913  gtk_widget_show(Widget);
914
915  WidgetInfo := CreateWidgetInfo(Widget, AWinControl, AParams);
916  New(ScrollingData);
917  ScrollingData^.HValue := 0;
918  ScrollingData^.VValue := 0;
919  ScrollingData^.HScroll := PGtkScrolledWindow(Widget)^.HScrollbar;
920  ScrollingData^.VScroll := PGtkScrolledWindow(Widget)^.VScrollbar;
921  WidgetInfo^.UserData := ScrollingData;
922  WidgetInfo^.DataOwner := True;
923
924  // set allocation
925  Allocation.X := AParams.X;
926  Allocation.Y := AParams.Y;
927  Allocation.Width := AParams.Width;
928  Allocation.Height := AParams.Height;
929  gtk_widget_size_allocate(Widget, @Allocation);
930  Set_RC_Name(AWinControl, Widget);
931
932  // SetCallbacks isn't called here, it should be done in the 'derived' class
933end;
934
935class procedure TGtkWSBaseScrollingWinControl.SetCallbacks(
936  const AWidget: PGtkWidget; const AWidgetInfo: PWidgetInfo);
937begin
938  TGtkWSWinControl.SetCallbacks(PGtkObject(AWidget),
939                                TComponent(AWidgetInfo^.LCLObject));
940  SignalConnect(
941    PGtkWidget(GetWidgetHAdjustment(AWidget)),
942    'value-changed',
943    @GtkWSBaseScrollingWinControl_HValueChanged,
944    AWidgetInfo
945  );
946  SignalConnect(
947    PGtkWidget(GetWidgetVAdjustment(AWidget)),
948    'value-changed',
949    @GtkWSBaseScrollingWinControl_VValueChanged,
950    AWidgetInfo
951  );
952end;
953
954{ TGtkWSDragImageListResolution }
955
956class function TGtkWSDragImageListResolution.BeginDrag(
957  const ADragImageList: TDragImageListResolution; Window: HWND; AIndex, X, Y: Integer
958  ): Boolean;
959var
960  ABitmap: TBitmap;
961  GDIObject: PGDIObject;
962  Pixmap: PGdkPixmap;
963  Mask: PGdkBitmap;
964begin
965  ABitmap := TBitmap.Create;
966  ADragImageList.GetBitmap(AIndex, ABitmap);
967
968  if (ABitmap.Handle = 0) or (ABitmap.Width = 0) or (ABitmap.Height = 0) then
969  begin
970    Result := False;
971    Exit;
972  end;
973
974  GDIObject := PGDIObject(ABitmap.Handle);
975
976  Pixmap := nil;
977  Mask := nil;
978  case GDIObject^.GDIBitmapType of
979    gbBitmap:
980      begin
981        Pixmap := GDIObject^.GDIBitmapObject;
982        gdk_bitmap_ref(Pixmap);
983        Mask := nil;
984      end;
985    gbPixmap:
986      begin
987        Pixmap := GDIObject^.GDIPixmapObject.Image;
988        Mask := GDIObject^.GDIPixmapObject.Mask;
989        gdk_pixmap_ref(Pixmap);
990        gdk_bitmap_ref(Mask);
991      end;
992    gbPixbuf:
993      begin
994        Pixmap := nil;
995        Mask := nil;
996        gdk_pixbuf_render_pixmap_and_mask(GDIObject^.GDIPixbufObject, Pixmap, Mask, $80);
997      end;
998  end;
999
1000  Result := GtkWidgetset.DragImageList_BeginDrag(Pixmap, Mask, ADragImageList.DragHotSpot);
1001  if Result then
1002    GtkWidgetset.DragImageList_DragMove(X, Y);
1003  gdk_pixmap_unref(Pixmap);
1004  gdk_bitmap_unref(Mask);
1005  ABitmap.Free;
1006end;
1007
1008class function TGtkWSDragImageListResolution.DragMove(
1009  const ADragImageList: TDragImageListResolution; X, Y: Integer): Boolean;
1010begin
1011  Result := GtkWidgetset.DragImageList_DragMove(X, Y);
1012end;
1013
1014class procedure TGtkWSDragImageListResolution.EndDrag(
1015  const ADragImageList: TDragImageListResolution);
1016begin
1017  GtkWidgetset.DragImageList_EndDrag;
1018end;
1019
1020class function TGtkWSDragImageListResolution.HideDragImage(
1021  const ADragImageList: TDragImageListResolution; ALockedWindow: HWND; DoUnLock: Boolean
1022  ): Boolean;
1023begin
1024  Result := GtkWidgetset.DragImageList_SetVisible(False);
1025end;
1026
1027class function TGtkWSDragImageListResolution.ShowDragImage(
1028  const ADragImageList: TDragImageListResolution; ALockedWindow: HWND; X, Y: Integer;
1029  DoLock: Boolean): Boolean;
1030begin
1031  Result := GtkWidgetset.DragImageList_DragMove(X, Y) and GtkWidgetset.DragImageList_SetVisible(True);
1032end;
1033
1034end.
1035