1{%MainUnit gtk2int.pas}
2{ $Id: gtk2lclintf.inc 56872 2017-12-29 20:22:29Z michl $ }
3{******************************************************************************
4                 All GTK2 interface communication implementations.
5                   Initial Revision  : Sat Jan 17 19:00:00 2004
6
7
8  !! Keep alphabetical !!
9
10  Support routines go to gtk2proc.pp
11
12 ******************************************************************************
13 Implementation
14 ******************************************************************************
15
16 *****************************************************************************
17  This file is part of the Lazarus Component Library (LCL)
18
19  See the file COPYING.modifiedLGPL.txt, included in this distribution,
20  for details about the license.
21 *****************************************************************************
22}
23
24
25//##apiwiz##sps##   // Do not remove
26
27function TGtk2WidgetSet.CreateRubberBand(const ARect: TRect; const ABrush: HBrush): HWND;
28var
29  Widget: PGtkWidget absolute Result;
30  dx, dy: integer;
31  Pixmap: PGdkPixmap;
32  gc: PGdkGC;
33  AColor: TGdkColor;
34begin
35  dx := ARect.Right - ARect.Left;
36  dy := ARect.Bottom - ARect.Top;
37  if dx < 0 then
38    dx := 0;
39  if dy < 0 then
40    dy := 0;
41
42  // rubber band is just a window without a title
43  Result := {%H-}HWND(gtk_window_new(GTK_WINDOW_POPUP));
44  gtk_window_set_default_size({%H-}PGtkWindow(Result), dx, dy);
45  gtk_widget_set_uposition(Widget, ARect.Left, ARect.Top);
46  gtk_widget_set_app_paintable(Widget, True);
47  gtk_widget_realize(Widget);
48  gdk_window_set_decorations(Widget^.window, 0);
49  gdk_window_set_functions(Widget^.window, GDK_FUNC_RESIZE or GDK_FUNC_CLOSE);
50  gtk_window_set_opacity({%H-}PGtkWindow(Result), 0.25);
51  if ABrush = 0 then
52    SetWidgetColor(Widget, clNone, clGradientActiveCaption, [GTK_STATE_NORMAL])
53  else
54  if {%H-}PGDIObject(ABrush)^.GDIBrushFill = GDK_SOLID then
55    SetWidgetColor(Widget, clNone, {%H-}PGDIObject(ABrush)^.GDIBrushColor.ColorRef, [GTK_STATE_NORMAL])
56  else
57  begin
58    Pixmap := gdk_pixmap_new(Widget^.window, dx, dy, -1);
59    gc := gdk_gc_new(Pixmap);
60    AColor := AllocGDKColor(clWhite);
61    gdk_gc_set_foreground(gc, @AColor);
62    gdk_gc_set_fill(gc, {%H-}PGDIObject(ABrush)^.GDIBrushFill);
63    case {%H-}PGDIObject(ABrush)^.GDIBrushFill of
64      GDK_TILED: gdk_gc_set_tile(gc, {%H-}PGDIObject(ABrush)^.GDIBrushPixMap);
65      GDK_STIPPLED: gdk_gc_set_stipple(gc, {%H-}PGDIObject(ABrush)^.GDIBrushPixMap);
66    end;
67    gdk_draw_rectangle(Pixmap, gc, -1, 0, 0, dx, dy);
68    gdk_gc_unref(gc);
69    gdk_window_set_back_pixmap(Widget^.window, Pixmap, False);
70    g_object_unref(Pixmap);
71  end;
72
73  gtk_widget_show(Widget);
74end;
75
76procedure TGtk2WidgetSet.DestroyRubberBand(ARubberBand: HWND);
77begin
78  gtk_widget_destroy({%H-}PGtkWidget(ARubberBand));
79end;
80
81procedure TGtk2WidgetSet.DrawDefaultDockImage(AOldRect, ANewRect: TRect;
82  AOperation: TDockImageOperation);
83const
84  LineWidth = 2;
85var
86  Mask: PGdkBitmap;
87  gc: PGdkGC;
88  dx, dy: integer;
89  AColor: TGdkColor;
90{$ifdef GTK_2_10}
91  Colormap: PGdkColormap;
92  Screen: PGdkScreen;
93{$endif}
94begin
95  dx := ANewRect.Right - ANewRect.Left;
96  dy := ANewRect.Bottom - ANewRect.Top;
97  if dx < 0 then
98    dx := 0;
99  if dy < 0 then
100    dy := 0;
101  if FDockImage = nil then
102  begin
103    // dock image is just a window without title
104    FDockImage := gtk_window_new(GTK_WINDOW_POPUP);
105    gtk_window_set_default_size(PGtkWindow(FDockImage),
106      dx, dy);
107    gtk_widget_realize(FDockImage);
108    gdk_window_set_decorations(FDockImage^.window, 0);
109    gdk_window_set_functions(FDockImage^.window, GDK_FUNC_RESIZE or GDK_FUNC_CLOSE);
110    SetWidgetColor(FDockImage, clNone, clGradientActiveCaption, [GTK_STATE_NORMAL]);
111    {$ifdef GTK_2_10}
112    // attemp to make window semi-transparent
113    Screen := gtk_widget_get_screen(FDockImage);
114    Colormap := gdk_screen_get_rgba_colormap(Screen);
115    if (Colormap <> nil) and gdk_screen_is_composited(Screen) then
116      gtk_widget_set_colormap(FDockImage, Colormap);
117    {$endif}
118  end;
119
120  gdk_window_move_resize(FDockImage^.window, ANewRect.Left, ANewRect.Top,
121    dx, dy);
122  if (dx > 0) and (dy > 0) then
123  begin
124    // create a hole inside window
125    Mask := gdk_pixmap_new(nil, dx, dy, 1);
126    gc := gdk_gc_new(Mask);
127    AColor.pixel := 1;
128    gdk_gc_set_foreground(gc, @AColor);
129    gdk_draw_rectangle(Mask, gc, 1, 0, 0, dx, dy);
130    AColor.pixel := 0;
131    gdk_gc_set_foreground(gc, @AColor);
132    gdk_draw_rectangle(Mask, gc, 1, LineWidth, LineWidth,
133      dx - LineWidth * 2, dy - LineWidth * 2);
134    gdk_gc_unref(gc);
135    gtk_widget_shape_combine_mask(FDockImage, Mask, 0, 0);
136    gdk_pixmap_unref(Mask);
137  end;
138  case AOperation of
139    disShow: gtk_widget_show(FDockImage);
140    disHide: gtk_widget_hide(FDockImage);
141  end;
142end;
143
144procedure TGtk2WidgetSet.DrawGrid(DC: HDC; const R: TRect; DX, DY: Integer);
145var
146  X, Y: Integer;
147  W, H: Integer;
148  SavedDC: Integer;
149begin
150  SavedDC := SaveDC(DC);
151  try
152    W := (R.Right - R.Left - 1) div DX;
153    H := (R.Bottom - R.Top - 1) div DY;
154
155    // remove rows from clip rect
156    for Y := 0 to H do
157    begin
158      ExcludeClipRect(DC, R.Left, R.Top + Y * DY + 1, R.Right + 1, R.Top + (Y + 1) * DY);
159    end;
160
161    // draw vertical lines cross excluded rows -> only grid cross points painted
162    for X := 0 to W do
163    begin
164      if MoveToEx(DC, R.Left + X * DX, R.Top, nil) then
165        LineTo(DC, R.Left + X * DX, R.Bottom + 1);
166    end;
167  finally
168    RestoreDC(DC, SavedDC);
169  end;
170end;
171
172
173{------------------------------------------------------------------------------
174  function TGtk2WidgetSet.ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint;
175    Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
176
177  As ExtTextOut except that Str is treated as UTF8
178 ------------------------------------------------------------------------------}
179function TGtk2WidgetSet.ExtUTF8Out(DC: HDC; X, Y: Integer; Options: Longint;
180  Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
181begin
182  // all fonts are UTF-8 under gtk2 => no mapping needed
183  Result:=ExtTextOut(DC,X,Y,Options,Rect,Str,Count,Dx);
184end;
185
186function TGtk2WidgetSet.TextUTF8Out(DC: HDC; X, Y: Integer; Str: PChar; Count: Longint): Boolean;
187begin
188  // all fonts are UTF-8 under gtk2 => no mapping needed
189  Result := TextOut(DC, X, Y, Str, Count);
190end;
191
192{------------------------------------------------------------------------------
193  function TGtk2WidgetSet.FontCanUTF8(Font: HFont): boolean;
194
195  True if font recognizes Unicode UTF8 encoding.
196 ------------------------------------------------------------------------------}
197function TGtk2WidgetSet.FontCanUTF8(Font: HFont): boolean;
198begin
199  Result:=IsValidGDIObject(Font);
200end;
201
202{------------------------------------------------------------------------------
203  function TGtk2WidgetSet.FontIsMonoSpace(Font: HFont): boolean;
204
205  True if font characters have all the same width.
206 ------------------------------------------------------------------------------}
207function TGtk2WidgetSet.FontIsMonoSpace(Font: HFont): boolean;
208begin
209  Result:=IsValidGDIObject(Font)
210          and FontIsMonoSpaceFont({%H-}PGdiObject(Font)^.GDIFontObject);
211end;
212
213{------------------------------------------------------------------------------
214  Function: GetAcceleratorString
215  Params: AVKey:
216          AShiftState:
217  Returns:
218
219 ------------------------------------------------------------------------------}
220function TGtk2WidgetSet.GetAcceleratorString(const AVKey: Byte;
221  const AShiftState: TShiftState): String;
222begin
223  Result:=inherited GetAcceleratorString(AVKey,AShiftState);
224end;
225
226{------------------------------------------------------------------------------
227  Function: RawImage_CreateBitmap
228  Params: ARawImage:
229          ABitmap:
230          AMask:
231          ASkipMask: When set, no mask is created
232  Returns:
233
234 ------------------------------------------------------------------------------}
235function TGtk2WidgetSet.RawImage_CreateBitmaps(const ARawImage: TRawImage; out
236  ABitmap, AMask: HBitmap; ASkipMask: boolean): boolean;
237var
238  GdiObject: PGDIObject absolute ABitmap;
239  GdiMaskObject: PGDIObject absolute AMask;
240  Desc: TRawImageDescription absolute ARawImage.Description;
241  ImgData: Pointer absolute ARawImage.Data;
242  ImgMask: Pointer absolute ARawImage.Mask;
243  ImgWidth: Cardinal absolute ARawImage.Description.Width;
244  ImgHeight: Cardinal absolute ARawImage.Description.Height;
245  ImgDepth: Byte absolute ARawImage.Description.Depth;
246  ImgDataSize: PtrUInt absolute ARawImage.DataSize;
247  Drawable: PGdkDrawable;
248  Pixbuf, TmpPixBuf: PGdkPixbuf;
249  GC: PGdkGC;
250  Visual: PGdkVisual;
251  GdkImage: PGdkImage;
252  RowStride: Cardinal;
253  Ridx, Gidx, Bidx, Aidx: Byte;
254  Data: Pointer;
255  Src, Dst, SrcRowPtr, DstRowPtr: PByte;
256  x, y: Cardinal;
257  CreateWithAlpha: boolean;
258  ADivResult, ARemainder: DWord;
259begin
260  Result := False;
261  ABitmap := 0;
262  AMask := 0;
263
264  if ImgWidth = 0 then Exit;
265  if ImgHeight = 0 then Exit;
266
267  CreateWithAlpha := True;
268  try
269    {$IFDEF VerboseRawImage}
270    DebugLn('TGtk2WidgetSet.CreateBitmapFromRawImage A ',
271      ' ASkipMask='+dbgs(ASkipMask),
272      ' Depth='+dbgs(Desc.Depth),
273      ' Width='+dbgs(Desc.Width),
274      ' Height='+dbgs(Desc.Height),
275      ' Data='+DbgS(ARawImage.Data),
276      ' DataSize='+dbgs(ARawImage.DataSize)+
277      ' Mask='+DbgS(ARawImage.Mask)+
278      ' MaskSize='+dbgs(ARawImage.MaskSize)+
279      ' Palette='+DbgS(ARawImage.Palette)+
280      ' PaletteSize='+dbgs(ARawImage.PaletteSize)+
281      ' BitsPerPixel='+dbgs(Desc.BitsPerPixel)+
282      '');
283    {$ENDIF}
284
285    // ToDo: check description
286
287    GdiObject := NewGDIObject(gdiBitmap);
288    GdiObject^.GDIBitmapType := gbPixmap;
289    GdiObject^.Depth := ImgDepth;
290
291    // create Pixmap from data
292    if ImgDepth = 1 then
293    begin
294      // create a GdkBitmap
295      if ImgData <> nil then
296      begin
297        Drawable := gdk_bitmap_create_from_data(nil, ImgData, ImgWidth, ImgHeight);
298        //gtk2 crashes if we create mask on gdkbitmap.issue #21673
299        ASkipMask := True;
300      end else
301        Drawable := gdk_pixmap_new(nil, ImgWidth, ImgHeight, 1);
302
303      GdiObject^.GDIBitmapObject := Drawable;
304      GdiObject^.GDIBitmapType := gbBitmap;
305    end else
306    begin
307      if (ImgData <> nil) and (ImgDepth = 32)
308      then begin
309        case Desc.LineEnd of
310          rileQWordBoundary: begin
311            RowStride := ImgWidth;
312            if ImgWidth and 1 <> 0 then Inc(RowStride);
313            RowStride := RowStride shl 2;
314          end;
315          rileDQWordBoundary: begin
316            RowStride := ImgWidth shr 1;
317            if ImgWidth and 3 <> 0 then Inc(RowStride);
318            RowStride := RowStride shl 3;
319          end;
320        else
321          RowStride := ImgWidth shl 2;
322        end;
323
324        // check if the pixels are in order, pixbuf expects them in R-G-B-A
325        Desc.GetRGBIndices(Ridx, Gidx, Bidx, AIdx);
326
327        if (Ridx <> 0) or (Gidx <> 1) or (Bidx <> 2) or (AIdx <> 3) then
328        begin
329          // put components in right order
330          GetMem(Data, ImgDataSize);
331          DstRowPtr := Data;
332          SrcRowPtr := ImgData;
333          y := ImgHeight;
334          while y > 0 do
335          begin
336            Src := SrcRowPtr;
337            Dst := DstRowPtr;
338            x := ImgWidth;
339            while x > 0 do
340            begin
341              Dst[0] := Src[Ridx];
342              Dst[1] := Src[Gidx];
343              Dst[2] := Src[Bidx];
344              Dst[3] := Src[Aidx];
345
346              Inc(Src, 4);
347              Inc(Dst, 4);
348              Dec(x);
349            end;
350            Inc(SrcRowPtr, Rowstride);
351            Inc(DstRowPtr, Rowstride);
352            Dec(y);
353          end;
354        end
355        else begin
356          // components are in place
357
358          // gtkPixbuf doesn't like invalid dataSize/MaskSize < 32. issue #8553.
359          if (ARawImage.MaskSize > 0) and (ImgDepth = 32) then
360          begin
361            // seem that gdkPixbuf does not like many of our masks
362            ADivResult := 0;
363            ARemainder := 0;
364            DivMod(ARawImage.DataSize, ARawImage.MaskSize, ADivResult, ARemainder);
365            CreateWithAlpha := ARemainder = 0;
366            {$IFDEF VerboseRawImage}
367            if not CreateWithAlpha then
368              DebugLn('TGtk2WidgetSet.CreateBitmapFromRawImage B WARNING: This image have invalid DataSize / MaskSize.');
369            {$ENDIF}
370          end;
371          Data := ImgData;
372        end;
373
374        TmpPixBuf := gdk_pixbuf_new_from_data(Data, GDK_COLORSPACE_RGB, CreateWithAlpha,
375          8, ImgWidth, ImgHeight, RowStride, nil, nil);
376
377        // we need to copy our pixbuf into a new one to allow data deallocation
378        Pixbuf := gdk_pixbuf_copy(TmpPixBuf);
379        gdk_pixbuf_unref(TmpPixBuf);
380        GdiObject^.GDIBitmapType := gbPixbuf;
381        GdiObject^.GDIPixbufObject := Pixbuf;
382        if Data <> ImgData
383        then FreeMem(Data);
384        GdiObject^.visual := gdk_visual_get_system();
385        gdk_visual_ref(GdiObject^.visual);
386        //DbgDumpPixbuf(Pixbuf, 'CreateBitmaps (32)');
387      end
388      else begin
389        // check if the depth is supported
390        Visual := gdk_visual_get_best_with_depth(Min(ImgDepth, 24));
391        // try some alternative (I'm not sure if we should fail here instead)
392        // if we don't have a visual we cannot draw anyway
393        //if Visual = nil
394        //then Visual := gdk_visual_get_best;
395        if Visual = nil
396        then Exit; // this depth is not supported
397
398        Drawable := gdk_pixmap_new(nil, ImgWidth, ImgHeight, Visual^.depth);
399
400        // create a GdkPixmap
401        if ImgData <> nil
402        then begin
403          { The gdk_pixmap_create_from_data creates only a two-color pixmap so we can not use it }
404
405          GdkImage := gdk_image_new(GDK_IMAGE_FASTEST, Visual, ImgWidth, ImgHeight);
406
407          {$ifdef VerboseRawImage}
408          //DebugLn('TGtk2WidgetSet.CreateBitmapFromRawImage GdkImage: ',
409          //  ' BytesPerLine=',dbgs(GdkImage^.bpl),
410          //  ' BitsPerPixel=',dbgs(GetPGdkImageBitsPerPixel(GdkImage)),
411          //  ' ByteOrder=',dbgs(ord(GdkImage^.byte_order)),
412          //  '');
413          {$endif}
414
415          if ARawImage.Description.BitsPerPixel <> GetGdkImageBitsPerPixel(GdkImage)
416          then begin
417            RaiseGDBException('TGtk2WidgetSet.CreateBitmapFromRawImage Incompatible BitsPerPixel');
418          end;
419          if ImgDataSize <> GdkImage^.bpl * ImgHeight
420          then begin
421            RaiseGDBException('TGtk2WidgetSet.CreateBitmapFromRawImage Incompatible DataSize');
422          end;
423
424          System.Move(ImgData^, GdkImage^.mem^, ImgDataSize);
425          if ImgDepth = 1
426          then CheckGdkImageBitOrder(GdkImage, GdkImage^.mem, ImgDataSize);
427          GC := gdk_gc_new(Drawable);
428          gdk_draw_image(Drawable, GC, GdkImage, 0, 0, 0, 0, ImgWidth, ImgHeight);
429          gdk_gc_unref(GC);
430          gdk_image_destroy(GdkImage);
431
432          //DbgDumpPixmap(Drawable, 'CreateBitmaps');
433        end;
434
435        GdiObject^.GDIPixmapObject.Image := Drawable;
436        GdiObject^.Visual := gdk_window_get_visual(Drawable);
437        gdk_visual_ref(GdiObject^.Visual);
438      end;
439    end;
440
441    if ASkipMask
442    then begin
443      Result := True;
444      Exit;
445    end;
446
447    // create mask
448
449    {$IFDEF VerboseRawImage}
450    DebugLn('TGtk2WidgetSet.CreateBitmapFromRawImage creating mask .. ');
451    {$ENDIF}
452
453    if ARawImage.IsMasked(False)
454    then Drawable := gdk_bitmap_create_from_data(nil, ImgMask, ImgWidth, ImgHeight)
455    else begin
456      Drawable := gdk_pixmap_new(nil, ImgWidth, ImgHeight, 1);
457      // clear drawable, the contents of a new pixmap are indefined
458      GC := gdk_gc_new(Drawable);
459      gdk_draw_rectangle(Drawable, GC, 1, 0, 0, ImgWidth, ImgHeight);
460      gdk_gc_unref(GC);
461    end;
462
463    GdiMaskObject := NewGDIObject(gdiBitmap);
464    GdiMaskObject^.Depth := 1;
465    GdiMaskObject^.GDIBitmapType := gbBitmap;
466    GdiMaskObject^.GDIBitmapObject := Drawable;
467
468    //DbgDumpBitmap(Drawable, 'CreateBitmaps - Mask');
469
470    Result := True;
471  except
472    DeleteObject(ABitmap);
473    ABitmap := 0;
474    DeleteObject(AMask);
475    AMask := 0;
476  end;
477end;
478
479{------------------------------------------------------------------------------
480  Function: RawImage_DescriptionFromBitmap
481  Params: Bitmap: HBITMAP;
482          Desc: PRawImageDescription
483  Returns: boolean;
484
485 ------------------------------------------------------------------------------}
486function TGtk2WidgetSet.RawImage_DescriptionFromBitmap(ABitmap: HBITMAP; out ADesc: TRawImageDescription): boolean;
487var
488  GDIObject: PGDIObject absolute ABitmap;
489begin
490  Result := False;
491  if not IsValidGDIObject(ABitmap)
492  then begin
493    DebugLn('WARNING: [TGtk2WidgetSet.GetBitmapRawImageDescription] invalid Bitmap!');
494    exit;
495  end;
496
497  case GDIObject^.GDIBitmapType of
498    gbBitmap:
499      Result := RawImage_DescriptionFromDrawable(ADesc,
500        GdiObject^.GDIBitmapObject, False);
501    gbPixmap:
502      Result := RawImage_DescriptionFromDrawable(ADesc,
503        GdiObject^.GDIPixmapObject.Image, GdiObject^.GDIPixmapObject.Mask <> nil);
504    gbPixbuf:
505      Result := RawImage_DescriptionFromPixbuf(ADesc, GdiObject^.GDIPixbufObject);
506  else
507    DebugLn('WARNING: [TGtk2WidgetSet.RawImage_DescriptionFromBitmap] Unknown GDIBitmapType');
508    Exit;
509  end;
510end;
511
512{------------------------------------------------------------------------------
513  function RawImage_DescriptionFromDevice
514  Params: DC: HDC;
515          Desc: PRawImageDescription
516  Returns: boolean;
517
518  Retrieves the information about the structure of the supported image data.
519 ------------------------------------------------------------------------------}
520function TGtk2WidgetSet.RawImage_DescriptionFromDevice(ADC: HDC; out
521  ADesc: TRawImageDescription): Boolean;
522var
523  DevCon: TGtkDeviceContext absolute ADC;
524
525  Drawable: PGdkDrawable;
526  UseAlpha: Boolean;
527begin
528  UseAlpha := False;
529  if IsValidDC(ADC)
530  then begin
531    Drawable := DevCon.Drawable;
532    if DevCon.CurrentBitmap <> nil
533    then begin
534      case DevCon.CurrentBitmap^.GDIBitmapType of
535        gbBitmap: Drawable := DevCon.CurrentBitmap^.GDIBitmapObject;
536        gbPixmap: begin
537          Drawable := DevCon.CurrentBitmap^.GDIPixmapObject.Image;
538          UseAlpha := DevCon.CurrentBitmap^.GDIPixmapObject.Mask <> nil;
539        end;
540        gbPixbuf: begin
541          Result := RawImage_DescriptionFromPixbuf(ADesc, DevCon.CurrentBitmap^.GDIPixbufObject);
542          Exit;
543        end;
544      end;
545    end;
546  end
547  else
548    Drawable := nil;
549
550  Result := RawImage_DescriptionFromDrawable(ADesc, Drawable, UseAlpha);
551end;
552
553{------------------------------------------------------------------------------
554  Function: RawImage_QueryDescription
555  Params: AFlags:
556          ADesc:
557  Returns:
558
559 ------------------------------------------------------------------------------}
560function TGtk2WidgetSet.RawImage_QueryDescription(AFlags: TRawImageQueryFlags; var ADesc: TRawImageDescription): Boolean;
561var
562  Desc: TRawImageDescription;
563begin
564  Desc.Init;
565  Result := RawImage_DescriptionFromDrawable(Desc, nil, riqfAlpha in AFlags);
566  if not Result then Exit;
567
568  if not (riqfUpdate in AFlags) then
569    ADesc.Init;
570
571  // if there's mask gtk2 assumes it's rgba (not XBM format).issue #12362
572  if (riqfUpdate in AFlags) and (riqfMono in AFlags) and (riqfMask in AFlags) then
573      AFlags := AFlags - [riqfMono] + [riqfRgb];
574
575  if riqfMono in AFlags then
576  begin
577    ADesc.Format := ricfGray;
578    ADesc.Depth := 1;
579    ADesc.BitOrder := Desc.MaskBitOrder;
580    ADesc.ByteOrder := riboLSBFirst;
581    ADesc.LineOrder := Desc.LineOrder;
582    ADesc.LineEnd := Desc.MaskLineEnd;
583    ADesc.BitsPerPixel := Desc.MaskBitsPerPixel;
584    ADesc.RedPrec := 1;
585    ADesc.RedShift := Desc.MaskShift;
586    // in theory only redshift is used, but if someone reads it as color thsi works too.
587    ADesc.GreenPrec := 1;
588    ADesc.GreenShift := Desc.MaskShift;
589    ADesc.BluePrec := 1;
590    ADesc.BlueShift := Desc.MaskShift;
591  end
592  else if riqfGrey in AFlags
593  then begin
594    ADesc.Format := ricfGray;
595    ADesc.Depth := 8;
596    ADesc.BitOrder := Desc.BitOrder;
597    ADesc.ByteOrder := Desc.ByteOrder;
598    ADesc.LineOrder := Desc.LineOrder;
599    ADesc.LineEnd := Desc.LineEnd;
600    ADesc.BitsPerPixel := 8;
601    ADesc.RedPrec := 8;
602    ADesc.RedShift := 0;
603  end
604  else
605  if riqfRGB in AFlags then
606  begin
607    ADesc.Format := ricfRGBA;
608    ADesc.Depth := Desc.Depth;
609    ADesc.BitOrder := Desc.BitOrder;
610    ADesc.ByteOrder := Desc.ByteOrder;
611    ADesc.LineOrder := Desc.LineOrder;
612    ADesc.LineEnd := Desc.LineEnd;
613    ADesc.BitsPerPixel := Desc.BitsPerPixel;
614    ADesc.RedPrec := Desc.RedPrec;
615    ADesc.RedShift := Desc.RedShift;
616    ADesc.GreenPrec := Desc.GreenPrec;
617    ADesc.GreenShift := Desc.GreenShift;
618    ADesc.BluePrec := Desc.BluePrec;
619    ADesc.BlueShift := Desc.BlueShift;
620  end;
621
622  if riqfAlpha in AFlags then
623  begin
624    ADesc.AlphaPrec := Desc.AlphaPrec;
625    ADesc.AlphaShift := Desc.AlphaShift;
626  end;
627
628  if riqfMask in AFlags then
629  begin
630    ADesc.MaskBitsPerPixel := Desc.MaskBitsPerPixel;
631    ADesc.MaskShift := Desc.MaskShift;
632    ADesc.MaskLineEnd := Desc.MaskLineEnd;
633    ADesc.MaskBitOrder := Desc.MaskBitOrder;
634  end;
635
636(*
637  //TODO
638  if riqfPalette in AFlags
639  then begin
640    ADesc.PaletteColorCount := Desc.PaletteColorCount;
641    ADesc.PaletteBitsPerIndex := Desc.PaletteBitsPerIndex;
642    ADesc.PaletteShift := Desc.PaletteShift;
643    ADesc.PaletteLineEnd := Desc.PaletteLineEnd;
644    ADesc.PaletteBitOrder := Desc.PaletteBitOrder;
645    ADesc.PaletteByteOrder := Desc.PaletteByteOrder;
646  end;
647*)
648end;
649
650{------------------------------------------------------------------------------
651  function TGtk2WidgetSet.GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP;
652    const SrcRect: TRect; var NewRawImage: TRawImage): boolean; override;
653 ------------------------------------------------------------------------------}
654function TGtk2WidgetSet.RawImage_FromBitmap(out ARawImage: TRawImage; ABitmap, AMask: HBITMAP; ARect: PRect): Boolean;
655var
656  GdiBitmap: PGDIObject absolute ABitmap;
657  GdiMask: PGDIObject absolute AMask;
658  Drawable: PGdkDrawable;
659  Bitmap: PGdkBitmap;
660begin
661  Result := false;
662  {$IFDEF VerboseRawImage}
663  DebugLn('TGtk2WidgetSet.GetRawImageFromBitmap A');
664  {$ENDIF}
665  ARawImage.Init;
666
667  if not IsValidGDIObject(ABitmap)
668  then begin
669    DebugLn('WARNING: [TGtk2WidgetSet.RawImage_FromBitmap] invalid Bitmap!');
670    exit;
671  end;
672  if (AMask <> 0) and not IsValidGDIObject(AMask)
673  then begin
674    DebugLn('WARNING: [TGtk2WidgetSet.RawImage_FromBitmap] invalid Mask');
675    exit;
676  end;
677
678  try
679    // get rawimage for Bitmap
680    case GdiBitmap^.GDIBitmapType of
681      gbBitmap: begin
682        Drawable := GdiBitmap^.GDIBitmapObject;
683        Bitmap := nil;
684      end;
685      gbPixmap: begin
686        Drawable := GdiBitmap^.GDIPixmapObject.Image;
687        Bitmap := GdiBitmap^.GDIPixmapObject.Mask;
688      end;
689      gbPixbuf: begin
690        Result := RawImage_FromPixbuf(ARawImage, GdiBitmap^.GDIPixbufObject, ARect);
691        Exit;
692      end;
693    else
694      DebugLn('WARNING: [TGtk2WidgetSet.RawImage_FromBitmap] Unknown GDIBitmapType');
695      Exit;
696    end;
697    {$IFDEF VerboseRawImage}
698    DebugLn('TGtk2WidgetSet.RawImage_FromBitmap A GdkPixmap=',DbgS(Drawable),' SrcMaskBitmap=',DbgS(Bitmap));
699    {$ENDIF}
700
701    //DbgDumpPixmap(Drawable, 'RawImage_FromBitmap - drawable');
702    //DbgDumpBitmap(Bitmap, 'RawImage_FromBitmap - alpha');
703
704    Result := RawImage_FromDrawable(ARawImage, Drawable, Bitmap, ARect);
705    if Result and (AMask <> 0)
706    then begin
707      if GdiMask^.GDIBitmapType <> gbBitmap
708      then begin
709        DebugLn('WARNING: [TGtk2WidgetSet.RawImage_FromBitmap] Unsupported GDIBitmapType for mask');
710        Exit;
711      end;
712
713      Bitmap := GdiMask^.GDIBitmapObject;
714      RawImage_AddMask(ARawImage, Bitmap, ARect);
715      //DbgDumpBitmap(Bitmap, 'RawImage_FromBitmap - mask');
716    end
717    else
718      ARawImage.Description.MaskBitsPerPixel := 0;
719
720    if not Result
721    then DebugLn('WARNING: [TGtk2WidgetSet.RawImage_FromBitmap] unable to GetRawImageFromGdkWindow Image');
722
723  except
724    ARawImage.FreeData;
725  end;
726end;
727
728{------------------------------------------------------------------------------
729  function TGtk2WidgetSet.GetRawImageFromDevice(SrcDC: HDC; const SrcRect: TRect;
730    var NewRawImage: TRawImage): boolean;
731
732 ------------------------------------------------------------------------------}
733function TGtk2WidgetSet.RawImage_FromDevice(out ARawImage: TRawImage; ADC: HDC;
734  const ARect: TRect): Boolean;
735var
736  DevCtx: TGtkDeviceContext absolute ADC;
737  DCOrigin: TPoint;
738  R: TRect;
739  Drawable: PGdkDrawable;
740begin
741  Result := False;
742  if not IsValidDC(ADC)
743  then begin
744    DebugLn('WARNING: TGtk2WidgetSet.GetRawImageFromDevice invalid SrcDC');
745    Exit(False);
746  end;
747
748  DCOrigin := DevCtx.Offset;
749  {$IFDEF VerboseRawImage}
750  DebugLn('TGtk2WidgetSet.GetRawImageFromDevice A DCOrigin=',dbgs(DCOrigin.X),',',dbgs(DCOrigin.Y),' SrcRect=',dbgs(ARect.Left),',',dbgs(ARect.Top),',',dbgs(ARect.Right),',',dbgs(ARect.Bottom));
751  {$ENDIF}
752  R := ARect;
753  LPtoDP(ADC, R, 2);
754  OffSetRect(R, DCOrigin.x, DCOrigin.y);
755
756  Drawable := DevCtx.Drawable;
757  if Drawable = nil then
758    // get screen shot
759    Drawable := gdk_screen_get_root_window(gdk_screen_get_default);
760  Result := RawImage_FromDrawable(ARawImage, Drawable, nil, @R);
761end;
762
763{------------------------------------------------------------------------------
764  Function: GetControlConstraints
765  Params: Constraints: TObject
766  Returns: true on success
767
768  Updates the constraints object (e.g. TSizeConstraints) with interface specific
769  bounds.
770 ------------------------------------------------------------------------------}
771function TGtk2WidgetSet.GetControlConstraints(Constraints: TObject): boolean;
772var
773  SizeConstraints: TSizeConstraints absolute Constraints;
774  Widget: PGtkWidget;
775  MinWidth: Integer;
776  MinHeight: Integer;
777  MaxWidth: Integer;
778  MaxHeight: Integer;
779begin
780  Result := True;
781
782  if Constraints is TSizeConstraints then
783  begin
784    MinWidth := 1;
785    MinHeight := 1;
786    MaxWidth := 0;
787    MaxHeight := 0;
788
789    if (SizeConstraints.Control=nil) then exit;
790
791    if SizeConstraints.Control is TScrollBar then begin
792      // TScrollBar
793      if TScrollBar(SizeConstraints.Control).Kind=sbHorizontal then begin
794        Widget:=GetStyleWidget(lgsHorizontalScrollbar);
795        MinHeight:=Widget^.requisition.Height;
796        MaxHeight:=MinHeight;
797      end else begin
798        Widget:=GetStyleWidget(lgsVerticalScrollbar);
799        MinWidth:=Widget^.requisition.Width;
800        MaxWidth:=MinWidth;
801      end;
802      //DebugLn('TGtk2WidgetSet.GetControlConstraints A '+dbgs(MinWidth)+','+dbgs(MinHeight),' ',dbgs(TScrollBar(SizeConstraints.Control).Kind=sbHorizontal),' ',TScrollBar(SizeConstraints.Control).Name);
803    end
804    else if SizeConstraints.Control is TCustomSplitter then begin
805      // TCustomSplitter
806      if TCustomSplitter(SizeConstraints.Control).ResizeAnchor in [akTop,akBottom] then
807      begin
808        Widget:=GetStyleWidget(lgsHorizontalPaned);
809        MinHeight:=Widget^.requisition.Height;
810        MaxHeight:=MinHeight;
811      end else begin
812        Widget:=GetStyleWidget(lgsVerticalPaned);
813        MinWidth:=Widget^.requisition.Width;
814        MaxWidth:=MinWidth;
815      end;
816    end
817    else if SizeConstraints.Control is TCustomMemo then begin
818      // TCustomMemo
819      Widget:=GetStyleWidget(lgsHorizontalScrollbar);
820      MinHeight:=Widget^.requisition.Height+20;
821      Widget:=GetStyleWidget(lgsVerticalScrollbar);
822      MinWidth:=Widget^.requisition.Width+20;
823    end
824    else if SizeConstraints.Control is TCustomTrackBar then begin
825      // TCustomTrackBar
826      if TCustomTrackBar(SizeConstraints.Control).Orientation=trHorizontal then
827      begin
828        Widget:=GetStyleWidget(lgsHScale);
829        MinHeight:=Widget^.requisition.height;
830      end else begin
831        Widget:=GetStyleWidget(lgsVScale);
832        MinWidth:=Widget^.requisition.width;
833      end;
834      //DebugLn(['TGtk2WidgetSet.GetControlConstraints ',DbgSName(SizeConstraints.Control),' ',MinWidth,',',MinHeight]);
835    end;
836
837    SizeConstraints.SetInterfaceConstraints(MinWidth,MinHeight,
838                                            MaxWidth,MaxHeight);
839  end;
840end;
841
842{------------------------------------------------------------------------------
843  function TGtk2WidgetSet.GetLCLOwnerObject(Handle: HWnd): TObject;
844
845 ------------------------------------------------------------------------------}
846function TGtk2WidgetSet.GetLCLOwnerObject(Handle: HWnd): TObject;
847begin
848  if Handle<>0 then
849    Result:=GetNearestLCLObject({%H-}PGtkWidget(Handle))
850  else
851    Result:=nil;
852end;
853
854function PromptUserBoxClosed(Widget : PGtkWidget; {%H-}Event : PGdkEvent;
855  data: gPointer) : GBoolean; cdecl;
856var
857  ModalResult : PtrUInt;
858begin
859  { We were requested by window manager to close so return EscapeResult}
860  if PInteger(data)^ = 0 then
861  begin
862    ModalResult:= {%H-}PtrUInt(g_object_get_data(PGObject(Widget), 'modal_result'));
863    { Don't allow to close if we don't have a default return value }
864    Result:= (ModalResult = 0);
865    if not Result then PInteger(data)^:= ModalResult
866    else DebugLn('Do not close !!!');
867  end else Result:= false;
868end;
869
870function PromptUserButtonClicked(Widget : PGtkWidget; data: gPointer) : GBoolean; cdecl;
871begin
872  PInteger(data)^ := {%H-}PtrUInt(g_object_get_data(PGObject(Widget), 'modal_result'));
873  Result := False;
874end;
875
876function TGtk2WidgetSet.AskUser(const DialogCaption, DialogMessage: string; DialogType:
877  LongInt; Buttons: TDialogButtons; HelpCtx: Longint): LongInt;
878
879const
880  ButtonResults : array[mrNone..mrYesToAll] of Longint = (
881    -1, idButtonOK, idButtonCancel, idButtonAbort, idButtonRetry,
882    idButtonIgnore, idButtonYes, idButtonNo, idButtonAll, idButtonNoToAll,
883    idButtonYesToAll);
884
885var
886  Dialog: PGtkWidget;
887
888  function ResponseID(const AnID: Integer): Integer;
889  begin
890    case AnID of
891      idButtonOK       : Result := GTK_RESPONSE_OK;
892      idButtonCancel   : Result := GTK_RESPONSE_CANCEL;
893      idButtonHelp     : Result := GTK_RESPONSE_HELP;
894      idButtonYes      : Result := GTK_RESPONSE_YES;
895      idButtonNo       : Result := GTK_RESPONSE_NO;
896      idButtonClose    : Result := GTK_RESPONSE_CLOSE;
897      idButtonAbort    : Result := GTK_RESPONSE_REJECT;
898      idButtonRetry    : Result := GTK_RESPONSE_LCL_RETRY;
899      idButtonIgnore   : Result := GTK_RESPONSE_LCL_IGNORE;
900      idButtonAll      : Result := GTK_RESPONSE_LCL_ALL;
901      idButtonNoToAll  : Result := GTK_RESPONSE_LCL_NOTOALL;
902      idButtonYesToAll : Result := GTK_RESPONSE_LCL_YESTOALL;
903    end;
904  end;
905
906  procedure CreateButton(const ALabel : String; const AResponse: Integer;
907      const AImageHint: Integer = -1);
908  var
909    NewButton: PGtkWidget;
910    BitmapHandle, MaskHandle: HBitmap;
911    GDIObject: PGDIObject;
912    Pixbuf: PGdkPixbuf;
913    Mask: PGdkBitmap;
914    Img: PGtkWidget;
915  begin
916    NewButton := gtk_dialog_add_button(PGtkDialog(Dialog),
917      PgChar(Ampersands2Underscore(ALabel)), AResponse);
918    gtk_button_set_use_underline(PGtkButton(NewButton), True);
919    if AImageHint >= 0 then
920    begin
921      if ThemeServices.GetStockImage(AImageHint, BitmapHandle, MaskHandle) then
922      begin
923        GDIObject := {%H-}PGDIObject(BitmapHandle);
924        Mask := nil;
925        Pixbuf := nil;
926        if GDIObject^.GDIBitmapType = gbPixbuf then
927          Pixbuf := GDIObject^.GDIPixbufObject
928        else
929          Mask := CreateGdkMaskBitmap(BitmapHandle, MaskHandle);
930
931        Img := gtk_image_new;
932
933        if Pixbuf <> nil then
934          gtk_image_set_from_pixbuf(PGtkImage(Img), Pixbuf)
935        else
936          gtk_image_set_from_pixmap(PGtkImage(Img), GDIObject^.GDIPixmapObject.Image, Mask);
937        gtk_button_set_image(PGtkButton(NewButton), Img);
938        if Mask <> nil then
939          g_object_unref(Mask);
940        DeleteObject(BitmapHandle);
941        DeleteObject(MaskHandle);
942      end;
943    end;
944  end;
945
946var
947  Btn: PGtkButton;
948  BtnId: Longint;
949  GtkDialogType: TGtkMessageType;
950  BtnIdx: Integer;
951  DefaultID, CancelID: Integer;
952  X: Integer;
953  MainList,ChildList: PGList;
954  Title: String;
955  ActiveWindow: HWND;
956  BtnResult: LongInt;
957  DlgBtn: TDialogButton;
958  ADialogResult: Integer;
959  Btns: TGtkButtonsType;
960begin
961  Result := mrNone;
962  ReleaseCapture;
963
964  if (Length(DialogMessage)>1000) then
965  begin
966    Result:=inherited;
967    exit;
968  end;
969
970  ADialogResult := mrCancel;
971  case DialogType of
972    idDialogWarning: GtkDialogType := GTK_MESSAGE_WARNING;
973    idDialogError: GtkDialogType := GTK_MESSAGE_ERROR;
974    idDialogInfo : GtkDialogType := GTK_MESSAGE_INFO;
975    idDialogConfirm : GtkDialogType := GTK_MESSAGE_QUESTION;
976  else
977    GtkDialogType := GTK_MESSAGE_INFO;
978  end;
979
980  Btns := GTK_BUTTONS_NONE;
981  DefaultId := 0;
982  CancelId := -1;
983  for X := 0 to Buttons.Count - 1 do
984  begin
985    DlgBtn:=Buttons[X];
986    if (Buttons.DefaultButton=DlgBtn)
987    or ((Buttons.DefaultButton=nil) and DlgBtn.Default) then
988      DefaultID := X;
989    if (Buttons.CancelButton=DlgBtn)
990    or ((Buttons.CancelButton=nil) and DlgBtn.Cancel)
991    then begin
992      CancelID := X;
993      ADialogResult := DlgBtn.ModalResult;
994    end;
995  end;
996
997
998  Dialog := gtk_message_dialog_new({$IFDEF HASX}PGtkWindow(GetDesktopWidget){$ELSE}nil{$ENDIF},
999    GTK_DIALOG_MODAL, GtkDialogType, Btns,
1000     nil);
1001
1002  gtk_message_dialog_set_markup(PGtkMessageDialog(Dialog), PGChar(DialogMessage));
1003
1004  g_signal_connect(PGtkObject(Dialog), 'delete-event',
1005    TGtkSignalFunc(@PromptUserBoxClosed),
1006    @ADialogResult);
1007
1008  if Btns = GTK_BUTTONS_NONE then
1009  begin
1010    // gtk2 have reverted buttons eg. No, Yes
1011    for BtnIdx := Buttons.Count - 1 downto 0 do
1012    begin
1013      with Buttons[BtnIdx] do
1014        if (ModalResult >= Low(ButtonResults)) and (ModalResult <= High(ButtonResults)) then
1015        begin
1016          BtnID := ButtonResults[ModalResult];
1017          case BtnID of
1018            idButtonOK       : CreateButton(Caption, GTK_RESPONSE_OK, BtnID);
1019            idButtonCancel   : CreateButton(Caption, GTK_RESPONSE_CANCEL, BtnID);
1020            idButtonHelp     : CreateButton(Caption, GTK_RESPONSE_HELP, BtnID);
1021            idButtonYes      : CreateButton(Caption, GTK_RESPONSE_YES, BtnID);
1022            idButtonNo       : CreateButton(Caption, GTK_RESPONSE_NO, BtnID);
1023            idButtonClose    : CreateButton(Caption, GTK_RESPONSE_CLOSE, BtnID);
1024            idButtonAbort    : CreateButton(Caption, GTK_RESPONSE_REJECT, BtnID);
1025            idButtonRetry    : CreateButton(Caption, GTK_RESPONSE_LCL_RETRY, BtnID);
1026            idButtonIgnore   : CreateButton(Caption, GTK_RESPONSE_LCL_IGNORE, BtnID);
1027            idButtonAll      : CreateButton(Caption, GTK_RESPONSE_LCL_ALL, BtnID);
1028            idButtonNoToAll  : CreateButton(Caption, GTK_RESPONSE_LCL_NOTOALL, BtnID);
1029            idButtonYesToAll : CreateButton(Caption, GTK_RESPONSE_LCL_YESTOALL, BtnID);
1030          end;
1031        end else
1032          CreateButton(Caption, GTK_RESPONSE_NONE, BtnID); // user defined buttons
1033    end;
1034  end;
1035
1036  MainList := gtk_container_children(PGtkContainer(PGtkDialog(Dialog)^.action_area));
1037  ChildList := MainList;
1038  BtnIdx := 0;
1039  while ChildList <> nil do
1040  begin
1041    if (ChildList^.Data <> nil) then
1042    begin
1043      if GTK_IS_BUTTON(ChildList^.Data) then
1044      begin
1045        Btn := PGtkButton(ChildList^.Data);
1046        DlgBtn := Buttons[BtnIdx];
1047
1048        BtnID := -1;
1049        BtnResult:=DlgBtn.ModalResult;
1050        if (BtnResult>=Low(ButtonResults)) and (BtnResult<=High(ButtonResults)) then
1051          BtnID := ButtonResults[DlgBtn.ModalResult];
1052        if (BtnIdx=CancelID) then
1053          g_object_set_data(PGObject(Dialog), 'modal_result', {%H-}Pointer(PtrInt(DlgBtn.ModalResult)));
1054
1055        X := DlgBtn.ModalResult;
1056        g_object_set_data(PGObject(Btn), 'modal_result',
1057          {%H-}Pointer(PtrInt(X)));
1058
1059        g_signal_connect(PGtkObject(Btn), 'clicked',
1060          TGtkSignalFunc(@PromptUserButtonClicked), @ADialogResult);
1061
1062        if DefaultID = BtnIdx then
1063        begin
1064          gtk_dialog_set_default_response(PGtkDialog(Dialog), ResponseID(BtnID));
1065          X := DlgBtn.ModalResult;
1066          if CancelID<0 then
1067            g_object_set_data(PGObject(Dialog), 'modal_result',
1068              {%H-}Pointer(PtrInt(X)));
1069        end;
1070
1071        inc(BtnIdx);
1072      end;
1073    end;
1074    ChildList := g_list_next(ChildList);
1075  end;
1076  if MainList <> nil then
1077    g_list_free(MainList);
1078
1079  if DialogCaption <> '' then
1080    gtk_window_set_title(PGtkWindow(Dialog), PGChar(DialogCaption))
1081  else
1082  begin
1083    Title := '';
1084    case DialogType of
1085      idDialogWarning: Title := rsMtWarning;
1086      idDialogError: Title := rsMtError;
1087      idDialogInfo : Title := rsMtInformation;
1088      idDialogConfirm : Title := rsMtConfirmation;
1089    end;
1090    gtk_window_set_title(PGtkWindow(Dialog), PGChar(Title));
1091  end;
1092
1093  if (gtk_major_version = 2) and (gtk_minor_version <= 12) then
1094  begin
1095    ActiveWindow := GetActiveWindow;
1096    if ActiveWindow <> 0 then
1097      gtk_window_set_transient_for(PGtkWindow(Dialog), {%H-}PGtkWindow(ActiveWindow));
1098  end;
1099  gtk_dialog_run(PGtkDialog(Dialog));
1100  gtk_widget_destroy(Dialog);
1101  Result := ADialogResult;
1102end;
1103
1104function TGtk2WidgetSet.PromptUser(const DialogCaption: string;
1105  const DialogMessage: string; DialogType: LongInt; Buttons: PLongInt;
1106  ButtonCount: LongInt; DefaultIndex: LongInt; EscapeResult: LongInt): LongInt;
1107var
1108  Btn: PGtkButton;
1109  Dialog: PGtkWidget;
1110  ADialogResult: Integer;
1111  GtkDialogType: TGtkMessageType;
1112  Btns: TGtkButtonsType;
1113  BtnIdx: Integer;
1114  DefaultID: Integer;
1115  X: Integer;
1116  MainList,ChildList: PGList;
1117  Title: String;
1118  ActiveWindow: HWND;
1119  QuotedMessage: Pgchar;
1120
1121  procedure CreateButton(const ALabel : String; const AResponse: Integer);
1122  var
1123    NewButton: PGtkButton;
1124  begin
1125    NewButton := PGtkButton(gtk_dialog_add_button(PGtkDialog(Dialog),
1126      PgChar(Ampersands2Underscore(ALabel)), AResponse));
1127    gtk_button_set_use_underline(NewButton, True);
1128  end;
1129
1130  function tr(UseWidgetStr: boolean; const TranslatedStr, WidgetStr: String): string;
1131  begin
1132    if UseWidgetStr then
1133      Result:=WidgetStr
1134    else
1135      Result:=TranslatedStr;
1136  end;
1137
1138  function ResponseID(const AnID: Integer): Integer;
1139  begin
1140    case AnID of
1141      idButtonOK       : Result := GTK_RESPONSE_OK;
1142      idButtonCancel   : Result := GTK_RESPONSE_CANCEL;
1143      idButtonHelp     : Result := GTK_RESPONSE_HELP;
1144      idButtonYes      : Result := GTK_RESPONSE_YES;
1145      idButtonNo       : Result := GTK_RESPONSE_NO;
1146      idButtonClose    : Result := GTK_RESPONSE_CLOSE;
1147      idButtonAbort    : Result := GTK_RESPONSE_REJECT;
1148      idButtonRetry    : Result := GTK_RESPONSE_LCL_RETRY;
1149      idButtonIgnore   : Result := GTK_RESPONSE_LCL_IGNORE;
1150      idButtonAll      : Result := GTK_RESPONSE_LCL_ALL;
1151      idButtonNoToAll  : Result := GTK_RESPONSE_LCL_NOTOALL;
1152      idButtonYesToAll : Result := GTK_RESPONSE_LCL_YESTOALL;
1153    end;
1154  end;
1155
1156begin
1157  Result := -1;
1158  ReleaseCapture;
1159  ADialogResult := EscapeResult;
1160  case DialogType of
1161    idDialogWarning: GtkDialogType := GTK_MESSAGE_WARNING;
1162    idDialogError: GtkDialogType := GTK_MESSAGE_ERROR;
1163    idDialogInfo : GtkDialogType := GTK_MESSAGE_INFO;
1164    idDialogConfirm : GtkDialogType := GTK_MESSAGE_QUESTION;
1165  else
1166    GtkDialogType := GTK_MESSAGE_INFO;
1167  end;
1168
1169  Btns := GTK_BUTTONS_NONE;
1170  DefaultId := 0;
1171  for X := 0 to ButtonCount - 1 do
1172  begin
1173    if X = DefaultIndex then
1174      DefaultID := Buttons[X];
1175  end;
1176
1177  Dialog := gtk_message_dialog_new({$IFDEF HASX}PGtkWindow(GetDesktopWidget){$ELSE}nil{$ENDIF},
1178    GTK_DIALOG_MODAL, GtkDialogType, Btns,
1179    nil);
1180
1181  // Can't pass message string to gtk_message_dialog_new, as % chars are interpreted
1182  // gtk_message_dialog_set_markup interpets HTML, so we need to quote that
1183  QuotedMessage := g_markup_escape_text(PGChar(DialogMessage), Length(DialogMessage));
1184  gtk_message_dialog_set_markup(PGtkMessageDialog(Dialog), QuotedMessage);
1185  g_free(QuotedMessage);
1186  g_signal_connect(PGtkObject(Dialog), 'delete-event',
1187    TGtkSignalFunc(@PromptUserBoxClosed),
1188    @ADialogResult);
1189
1190  if Btns = GTK_BUTTONS_NONE then
1191  begin
1192    // gtk2 have reverted buttons eg. No, Yes
1193    for BtnIdx := ButtonCount-1 downto 0 do
1194    begin
1195      case Buttons[BtnIdx] of
1196        idButtonOK       : CreateButton(tr(rsmbOK='&OK',rsmbOK, 'gtk-ok'), GTK_RESPONSE_OK);
1197        idButtonCancel   : CreateButton(tr(rsmbCancel='Cancel',rsmbCancel,'gtk-cancel'), GTK_RESPONSE_CANCEL);
1198        idButtonHelp     : CreateButton(tr(rsmbHelp='&Help',rsmbHelp,'gtk-help'), GTK_RESPONSE_HELP);
1199        idButtonYes      : CreateButton(tr(rsmbYes='&Yes',rsmbYes,'gtk-yes'), GTK_RESPONSE_YES);
1200        idButtonNo       : CreateButton(tr(rsmbNo='&No',rsmbNo,'gtk-no'), GTK_RESPONSE_NO);
1201        idButtonClose    : CreateButton(tr(rsmbClose='&Close',rsmbClose,'gtk-close'), GTK_RESPONSE_CLOSE);
1202        idButtonAbort    : CreateButton(rsMBAbort, GTK_RESPONSE_REJECT);
1203        idButtonRetry    : CreateButton(rsMBRetry, GTK_RESPONSE_LCL_RETRY);
1204        idButtonIgnore   : CreateButton(rsMBIgnore, GTK_RESPONSE_LCL_IGNORE);
1205        idButtonAll      : CreateButton(rsMbAll, GTK_RESPONSE_LCL_ALL);
1206        idButtonNoToAll  : CreateButton(rsMBNoToAll, GTK_RESPONSE_LCL_NOTOALL);
1207        idButtonYesToAll : CreateButton(rsMBYesToAll, GTK_RESPONSE_LCL_YESTOALL);
1208      end;
1209    end;
1210  end;
1211
1212  MainList := gtk_container_children(PGtkContainer(PGtkDialog(Dialog)^.action_area));
1213  ChildList := MainList;
1214  BtnIdx := 0;
1215
1216  while ChildList <> nil do
1217  begin
1218    if (ChildList^.Data <> nil) then
1219    begin
1220      if GTK_IS_BUTTON(ChildList^.Data) then
1221      begin
1222        Btn := PGtkButton(ChildList^.Data);
1223
1224        if Buttons[BtnIdx] = idButtonCancel then
1225          g_object_set_data(PGObject(Dialog), 'modal_result', Pointer(idButtonCancel));
1226
1227        X := Buttons[BtnIdx];
1228        g_object_set_data(PGObject(Btn), 'modal_result',
1229          {%H-}Pointer(PtrInt(X)));
1230
1231        g_signal_connect(PGtkObject(Btn), 'clicked',
1232          TGtkSignalFunc(@PromptUserButtonClicked), @ADialogResult);
1233
1234        if DefaultID = Buttons[BtnIdx] then
1235        begin
1236          gtk_dialog_set_default_response(PGtkDialog(Dialog), ResponseID(Buttons[BtnIdx]));
1237          X := Buttons[BtnIdx];
1238          g_object_set_data(PGObject(Dialog), 'modal_result',
1239            {%H-}Pointer(PtrInt(X)));
1240        end;
1241
1242        inc(BtnIdx);
1243      end;
1244    end;
1245    ChildList := g_list_next(ChildList);
1246  end;
1247  if MainList <> nil then
1248    g_list_free(MainList);
1249
1250  if DialogCaption <> '' then
1251    gtk_window_set_title(PGtkWindow(Dialog), PGChar(DialogCaption))
1252  else
1253  begin
1254    Title := '';
1255    case DialogType of
1256      idDialogWarning: Title := rsMtWarning;
1257      idDialogError: Title := rsMtError;
1258      idDialogInfo : Title := rsMtInformation;
1259      idDialogConfirm : Title := rsMtConfirmation;
1260    end;
1261    gtk_window_set_title(PGtkWindow(Dialog), PGChar(Title));
1262  end;
1263
1264  ActiveWindow := GetActiveWindow;
1265  if ActiveWindow <> 0 then
1266    gtk_window_set_transient_for(PGtkWindow(Dialog), {%H-}PGtkWindow(ActiveWindow));
1267  // the following line keeps the old behaviour making the dialog appear
1268  // at screen center instead of at ActiveWindow center
1269  gtk_window_set_position(PGtkWindow(Dialog), GTK_WIN_POS_CENTER);
1270
1271  gtk_dialog_run(PGtkDialog(Dialog));
1272  gtk_widget_destroy(Dialog);
1273  Result := ADialogResult;
1274end;
1275
1276function TGtk2WidgetSet.SetComboMinDropDownSize(Handle: HWND; MinItemsWidth,
1277  MinItemsHeight, MinItemCount: integer): boolean;
1278var
1279  p: PGtkWidget;
1280  Menu: PGtkWidget;
1281  Requisition: TGtkRequisition;
1282begin
1283  Result:=True;
1284  p := GetWidgetInfo({%H-}Pointer(Handle), False)^.CoreWidget;
1285
1286  Menu := PGtkWidget(g_object_get_data(G_OBJECT(p), 'Menu'));
1287  if Menu<>nil then begin
1288    Requisition.width := MinItemsWidth;
1289    Requisition.height := MinItemsHeight * MinItemCount;
1290    gtk_widget_size_request(Menu, @Requisition);
1291  end;
1292end;
1293
1294
1295//##apiwiz##eps##   // Do not remove, no wizard declaration after this line
1296
1297
1298function waithandle_iocallback({%H-}source: PGIOChannel; condition: TGIOCondition;
1299  data: gpointer): gboolean; cdecl;
1300var
1301  lEventHandler: PWaitHandleEventHandler absolute data;
1302begin
1303  //debugln('waithandle_iocallback lEventHandler=',HexStr(Cardinal(lEventHandler),8));
1304  lEventHandler^.OnEvent(lEventHandler^.UserData, condition);
1305  Result := true;
1306end;
1307
1308function TGtk2WidgetSet.AddEventHandler(AHandle: THandle; AFlags: dword;
1309  AEventHandler: TWaitHandleEvent; AData: PtrInt): PEventHandler;
1310var
1311  giochannel: pgiochannel;
1312  lEventHandler: PWaitHandleEventHandler;
1313begin
1314  if AEventHandler = nil then exit;
1315  New(lEventHandler);
1316  giochannel := g_io_channel_unix_new(AHandle);
1317  lEventHandler^.Handle := AHandle;
1318  lEventHandler^.UserData := AData;
1319  lEventHandler^.GIOChannel := giochannel;
1320  lEventHandler^.OnEvent := AEventHandler;
1321  lEventHandler^.GSourceID := g_io_add_watch(giochannel,
1322    AFlags, @waithandle_iocallback, lEventHandler);
1323  //debugln('TGtk2WidgetSet.AddEventHandler lEventHandler=',HexStr(Cardinal(lEventHandler),8),' AHandle=',dbgs(lEventHandler^.Handle));
1324  lEventHandler^.PrevHandler := nil;
1325  lEventHandler^.NextHandler := FWaitHandles;
1326  if FWaitHandles <> nil then
1327    FWaitHandles^.PrevHandler := lEventHandler;
1328  FWaitHandles := lEventHandler;
1329  Result := lEventHandler;
1330end;
1331
1332
1333procedure TGtk2WidgetSet.RemoveEventHandler(var AHandler: PEventHandler);
1334var
1335  lEventHandler: PWaitHandleEventHandler absolute AHandler;
1336begin
1337  if AHandler = nil then exit;
1338  g_source_remove(lEventHandler^.GSourceID);
1339  { channel will be freed with ref count drops to 0 }
1340  g_io_channel_unref(lEventHandler^.GIOChannel);
1341  if lEventHandler^.PrevHandler = nil then
1342    FWaitHandles := lEventHandler^.NextHandler
1343  else
1344    lEventHandler^.PrevHandler^.NextHandler := lEventHandler^.NextHandler;
1345  if lEventHandler^.NextHandler <> nil then
1346    lEventHandler^.NextHandler^.PrevHandler := lEventHandler^.PrevHandler;
1347  //debugln('TGtk2WidgetSet.RemoveEventHandler lEventHandler=',HexStr(Cardinal(lEventHandler),8),' AHandle=',dbgs(lEventHandler^.Handle));
1348  Dispose(lEventHandler);
1349  AHandler := nil;
1350end;
1351
1352procedure TGtk2WidgetSet.SetEventHandlerFlags(AHandler: PEventHandler; NewFlags: dword);
1353var
1354  lEventHandler: PWaitHandleEventHandler absolute AHandler;
1355begin
1356  if AHandler = nil then exit;
1357  g_source_remove(lEventHandler^.GSourceID);
1358  lEventHandler^.GSourceID := g_io_add_watch(lEventHandler^.GIOChannel,
1359    NewFlags, @waithandle_iocallback, lEventHandler);
1360  //debugln('TGtk2WidgetSet.SetEventHandlerFlags lEventHandler=',HexStr(Cardinal(lEventHandler),8),' AHandle=',dbgs(lEventHandler^.Handle));
1361end;
1362
1363procedure TGtk2WidgetSet.SetRubberBandRect(const ARubberBand: HWND; const ARect: TRect);
1364begin
1365  if ARubberBand = 0 then
1366    exit;
1367  with ARect do
1368    gdk_window_move_resize({%H-}PGtkWidget(ARubberBand)^.window, Left,
1369      Top, Right - Left, Bottom - Top);
1370end;
1371
1372type
1373  PPipeEventInfo = ^TPipeEventInfo;
1374  TPipeEventInfo = record
1375    Handler: PEventHandler;
1376    UserData: PtrInt;
1377    OnEvent: TPipeEvent;
1378  end;
1379
1380function TGtk2WidgetSet.AddPipeEventHandler(AHandle: THandle;
1381  AEventHandler: TPipeEvent; AData: PtrInt): PPipeEventHandler;
1382var
1383  lPipeEventInfo: PPipeEventInfo;
1384begin
1385  if AEventHandler = nil then exit;
1386  New(lPipeEventInfo);
1387  lPipeEventInfo^.UserData := AData;
1388  lPipeEventInfo^.OnEvent := AEventHandler;
1389  lPipeEventInfo^.Handler := AddEventHandler(AHandle, G_IO_IN or G_IO_HUP or G_IO_OUT,
1390    @HandlePipeEvent, {%H-}PtrUInt(lPipeEventInfo));
1391  Result := lPipeEventInfo;
1392end;
1393
1394procedure TGtk2WidgetSet.HandlePipeEvent(AData: PtrInt; AFlags: dword);
1395var
1396  lPipeEventInfo: PPipeEventInfo absolute AData;
1397  lReasons: TPipeReasons;
1398begin
1399  lReasons := [];
1400  if AFlags and G_IO_IN = G_IO_IN then
1401    Include(lReasons, prDataAvailable);
1402  if AFlags and G_IO_OUT = G_IO_OUT then
1403    Include(lReasons, prCanWrite);
1404  if AFlags and G_IO_HUP = G_IO_HUP then
1405    Include(lReasons, prBroken);
1406
1407  lPipeEventInfo^.OnEvent(lPipeEventInfo^.UserData, lReasons);
1408end;
1409
1410procedure TGtk2WidgetSet.RemovePipeEventHandler(var AHandler: PPipeEventHandler);
1411var
1412  lPipeEventInfo: PPipeEventInfo absolute AHandler;
1413begin
1414  if AHandler = nil then exit;
1415  RemoveEventHandler(lPipeEventInfo^.Handler);
1416  Dispose(lPipeEventInfo);
1417  AHandler := nil;
1418end;
1419
1420{$ifdef UNIX}
1421function TGtk2WidgetSet.AddProcessEventHandler(AHandle: THandle;
1422  AEventHandler: TChildExitEvent; AData: PtrInt): PProcessEventHandler;
1423var
1424  lHandler: PChildSignalEventHandler;
1425begin
1426  if AEventHandler = nil then exit(nil);
1427  New(lHandler);
1428  lHandler^.PID := TPid(AHandle);
1429  lHandler^.UserData := AData;
1430  lHandler^.OnEvent := AEventHandler;
1431  lHandler^.PrevHandler := nil;
1432  lHandler^.NextHandler := FChildSignalHandlers;
1433  if FChildSignalHandlers <> nil then
1434    FChildSignalHandlers^.PrevHandler := lHandler;
1435  FChildSignalHandlers := lHandler;
1436  Result := lHandler;
1437end;
1438
1439procedure TGtk2WidgetSet.RemoveProcessEventHandler(var AHandler: PProcessEventHandler);
1440var
1441  lHandler: PChildSignalEventHandler absolute AHandler;
1442begin
1443  if AHandler = nil then exit;
1444  if lHandler^.PrevHandler = nil then
1445    FChildSignalHandlers := lHandler^.NextHandler
1446  else
1447    lHandler^.PrevHandler^.NextHandler := lHandler^.NextHandler;
1448  if lHandler^.NextHandler <> nil then
1449    lHandler^.NextHandler^.PrevHandler := lHandler^.PrevHandler;
1450  Dispose(lHandler);
1451  AHandler := nil;
1452end;
1453{$else}
1454{$IFDEF VerboseGtkToDos}{$warning TGtk2WidgetSet.RemoveProcessEventHandler and TGtk2WidgetSet.AddProcessEventHandler not implemented on this OS}{$ENDIF}
1455//PChildSignalEventHandler is only defined on unix
1456function TGtk2WidgetSet.AddProcessEventHandler(AHandle: THandle;
1457  AEventHandler: TChildExitEvent; AData: PtrInt): PProcessEventHandler;
1458begin
1459  Result := nil;
1460end;
1461
1462procedure TGtk2WidgetSet.RemoveProcessEventHandler(var AHandler: PProcessEventHandler);
1463begin
1464end;
1465{$endif}
1466
1467