{%MainUnit gtk2int.pp} { $Id$ } {****************************************************************************** All GTK2 Winapi implementations. Initial Revision : Mon Sep 22 15:50:00 2003 !! Keep alphabetical !! Support routines go to gtk2proc.pp ****************************************************************************** Implementation ****************************************************************************** ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.modifiedLGPL, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** } {$IFOPT C-} // Uncomment for local trace // {$C+} // {$DEFINE ASSERT_IS_ON} {$EndIf} //##apiwiz##sps## // Do not remove function TGtk2WidgetSet.BeginPaint(Handle: hWnd; Var PS : TPaintStruct) : hdc; var paintrect : TGDKRectangle; begin result := Inherited BeginPaint(Handle, PS); If (Handle <> 0) and (not GTK_WIDGET_DOUBLE_BUFFERED((PGTKWidget(Handle)))) then begin paintrect.x := PS.rcPaint.Left; paintrect.y := PS.rcPaint.Top; paintrect.width := PS.rcPaint.Right- PS.rcPaint.Left; paintrect.height := PS.rcPaint.Bottom - PS.rcPaint.Top; if (paintrect.width <= 0) or (paintrect.height <=0) then begin paintrect.x := 0; paintrect.y := 0; gdk_drawable_get_size(TDeviceContext(Result).Drawable, @paintrect.width, @paintrect.height); end; gdk_window_freeze_updates(TDeviceContext(Result).Drawable); gdk_window_begin_paint_rect (TDeviceContext(Result).Drawable, @paintrect); end; end; function TGtk2WidgetSet.CreateFontIndirectEx(const LogFont: TLogFont; const LongFontName: string): HFONT; var GdiObject: PGdiObject; FullString: String; aFamily,aStyle: String; aSize: Integer; procedure LoadDefaultFont; begin DisposeGDIObject(GdiObject); GdiObject:=CreateDefaultFont; end; begin result := 0; GdiObject := NewGdiObject(gdiFont); try with LogFont do begin if lfFaceName[0] = #0 then begin Assert(false,'ERROR: [Tgt2kObject.CreateFontIndirectEx] No fontname'); Exit; end; if CompareText(lfFacename,'default')=0 then begin LoadDefaultFont; Result := HFONT(GdiObject); exit; end; FontNameToPangoFontDescStr(LongFontname, aFamily, aStyle, aSize); // if font specified size, prefer this instead of 'posibly' inacurate lfHeight // note that lfHeight may actually have a most acurate value but there is no // way to know this at this point. // setting the size, this could be done in two ways // method 1: fontdesc using fontname like "helvetica 12" // method 2: fontdesc using fontname like "helvetica" and later modify size // to obtain consistent font sizes method 2 should be used // for method 1 converting lfheight to fontsize can lead to rounding errors // for example, font size=12, lfheight=-12 (75dpi), at 75 dpi aSize=11 // so we would get a font "helvetica 11" instead of "helvetica 12" // size information, and later modify font size // using method 2 FullString := AFamily + ' ' + aStyle; GdiObject^.GDIFontObject := pango_font_description_from_string(PChar(FullString)); If lfWeight <> FW_DONTCARE then pango_font_description_set_weight(GdiObject^.GDIFontObject, lfWeight); if lfItalic = 0 then pango_font_description_set_style(GdiObject^.GDIFontObject, PANGO_STYLE_NORMAL) else pango_font_description_set_style(GdiObject^.GDIFontObject, PANGO_STYLE_ITALIC); if aSize=0 then begin // a size is not specified, try to calculate one based on lfHeight // and use this value not in the font name but set this value appart // NOTE: in gtk2.8 is possible to use pango_font_description_set_absolute_size // which would be great with the given lfheight value, but older gtk2 version // doesn't have this funtion aSize:= (abs(lfheight) * 72) div ScreenInfo.PixelsPerInchX; if aSize=0 then aSize := 12; end; pango_font_description_set_size( GdiObject^.GDIFontObject, aSize*PANGO_SCALE); GdiObject^.StrikeOut := lfStrikeOut <> 0; GdiObject^.Underline := lfUnderline <> 0; end; finally if GdiObject^.GDIFontObject = nil then begin DisposeGDIObject(GdiObject); Result := 0; end else begin Result := HFONT(GdiObject); end; end; end; {------------------------------------------------------------------------------ Function: EndPaint Params: none Returns: Nothing ------------------------------------------------------------------------------} Function TGtk2WidgetSet.EndPaint(Handle : hwnd; var PS : TPaintStruct): Integer; begin If (Handle <> 0) and (not GTK_WIDGET_DOUBLE_BUFFERED((PGTKWidget(Handle)))) then begin if PS.HDC <> 0 then begin gdk_window_thaw_updates(TDeviceContext(PS.HDC).Drawable); gdk_window_end_paint (TDeviceContext(PS.HDC).Drawable); end; end; result := Inherited EndPaint(Handle, PS); end; {------------------------------------------------------------------------------ Function: ExtTextOut Params: none Returns: Nothing ------------------------------------------------------------------------------} function TGtk2WidgetSet.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean; var LineStart, LineEnd, StrEnd: PChar; Width, Height: Integer; TopY, LineLen, LineHeight : Integer; TxtPt : TPoint; DCOrigin: TPoint; UnRef, Underline, StrikeOut : Boolean; RGBColor : Longint; Foreground : PGDKColor; Layout : PPangoLayout; UseFontDesc : PPangoFontDescription; AttrList : PPangoAttrList; Attr : PPangoAttribute; procedure DoTextOut(X,Y : Integer; Str : Pchar; Count: Integer); var aRect : TRect; begin with TDeviceContext(DC) do begin //fix me... and what about UTF-8 conversion? //this could be a massive problem since we //will need to know before hand what the current //locale is, and if we stored UTF-8 string this would break //cross-compatibility with GTK1.2 and win32 interfaces..... pango_layout_set_text(Layout, Str, Count); aRect := Classes.Rect(0,0,0,0); pango_layout_get_pixel_size(Layout, @arect.Right, @arect.Bottom); OffsetRect(aRect, X+DCOrigin.X,Y+DCOrigin.Y); gdk_draw_layout_with_colors(drawable, gc, aRect.Left, aRect.Top, Layout, Foreground, nil); end; end; procedure DrawTextLine; begin with TDeviceContext(DC) do begin DoTextOut(TxtPt.X, TxtPt.Y, LineStart, LineLen); end; end; begin Assert(False, Format('trace:> [TGtk2WidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count])); Result := IsValidDC(DC); if Result then with TDeviceContext(DC) do begin if GC = nil then begin DebugLn('WARNING: [TGtk2WidgetSet.ExtTextOut] Uninitialized GC'); Result := False; end else if ((Options and (ETO_OPAQUE+ETO_CLIPPED)) <> 0) and (Rect=nil) then begin DebugLn('WARNING: [TGtk2WidgetSet.ExtTextOut] Rect=nil'); Result := False; end else begin // TODO: implement other parameters. UseFontDesc:=nil; if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin UseFontDesc := GetDefaultFontDesc(true); UnRef := True; Underline := False; StrikeOut := False; end else begin UseFontDesc := CurrentFont^.GDIFontObject; UnRef := False; Underline := CurrentFont^.Underline; StrikeOut := CurrentFont^.StrikeOut; end; GetStyle(lgsdefault); If (UseFontDesc = nil) or (GetStyleWidget(lgsdefault)=nil) then DebugLn('WARNING: [TGtk2WidgetSet.ExtTextOut] Missing Font') else begin // to reduce flickering calculate first and then paint DCOrigin:=GetDCOffset(TDeviceContext(DC)); Layout := gtk_widget_create_pango_layout (GetStyleWidget(lgsdefault), nil); If (Layout = nil) then DebugLn('WARNING: [TGtk2WidgetSet.ExtTextOut] Missing Pango Layout') else begin pango_layout_set_font_description(Layout, UseFontDesc); AttrList := pango_layout_get_attributes(Layout); If (AttrList = nil) then AttrList := pango_attr_list_new(); If Underline then Attr := pango_attr_underline_new(PANGO_UNDERLINE_SINGLE) else Attr := pango_attr_underline_new(PANGO_UNDERLINE_NONE); pango_attr_list_change(AttrList,Attr); Attr := pango_attr_strikethrough_new(StrikeOut); pango_attr_list_change(AttrList,Attr); if (Options and ETO_CLIPPED) <> 0 then begin X := Rect^.Left; Y := Rect^.Top; IntersectClipRect(DC, Rect^.Left, Rect^.Top, Rect^.Right, Rect^.Bottom); end; LineLen := FindChar(#10,Str,Count); TopY := Y; UpdateDCTextMetric(TDeviceContext(DC)); TxtPt.X := X + DCOrigin.X; LineHeight := DCTextMetric.TextMetric.tmAscent; TxtPt.Y := TopY + LineHeight + DCOrigin.Y; SelectedColors := dcscCustom; if ((Options and ETO_OPAQUE) <> 0) then begin Width := Rect^.Right - Rect^.Left; Height := Rect^.Bottom - Rect^.Top; EnsureGCColor(DC, dccCurrentBackColor, True, False); gdk_draw_rectangle(Drawable, GC, 1, Rect^.Left+DCOrigin.X, Rect^.Top+DCOrigin.Y, Width, Height); end; EnsureGCColor(DC, dccCurrentTextColor, True, False); RGBColor := ColorToRGB(CurrentTextColor.ColorRef); Attr := pango_attr_foreground_new(gushort(GetRValue(RGBColor)) shl 8, gushort(GetGValue(RGBColor)) shl 8, gushort(GetBValue(RGBColor)) shl 8); pango_attr_list_change(AttrList,Attr); pango_layout_set_attributes(Layout, AttrList); Foreground := StyleForegroundColor(CurrentTextColor.ColorRef, nil); LineStart:=Str; if LineLen < 0 then begin LineLen:=Count; if Count> 0 then DrawTextLine; end else Begin //write multiple lines StrEnd:=Str+Count; while LineStart < StrEnd do begin LineEnd:=LineStart+LineLen; if LineLen>0 then DrawTextLine; inc(TxtPt.Y,LineHeight); LineStart:=LineEnd+1; // skip #10 if (LineStart nil do begin if (List^.Data <> nil) and gdk_window_is_visible(List^.Data) then begin XQueryPointer(gdk_x11_drawable_get_xdisplay (List^.Data), gdk_x11_drawable_get_xid(List^.Data), @root, @child, @lpPoint.X, @lpPoint.Y, @winx, @winy, @xmask); Result := True; Break; end; List := g_list_next(List); end; if TopList <> nil then g_list_free(TopList); {$Else} // Win32 Todo DebugLn('ToDo(Win32): TGtk2WidgetSet.GetCursorPos'); {$EndIf} {$EndIf} end; function TGtk2WidgetSet.GetTextExtentPoint(DC: HDC; Str: PChar; Count: Integer; var Size: TSize): Boolean; var UnRef, Underline, StrikeOut : Boolean; Layout : PPangoLayout; UseFontDesc : PPangoFontDescription; AttrList : PPangoAttrList; Attr : PPangoAttribute; begin Result := IsValidDC(DC); if Result and (Count>0) then with TDeviceContext(DC) do begin if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin UseFontDesc := GetDefaultFontDesc(true); UnRef := True; Underline := False; StrikeOut := False; end else begin UseFontDesc := CurrentFont^.GDIFontObject; UnRef := False; Underline := CurrentFont^.Underline; StrikeOut := CurrentFont^.StrikeOut; end; If UseFontDesc = nil then DebugLn('WARNING: [TGtk2WidgetSet.GetTextExtentPoint] Missing Font') else begin GetStyle(lgsdefault); Layout := gtk_widget_create_pango_layout (GetStyleWidget(lgsdefault), nil); pango_layout_set_font_description(Layout, UseFontDesc); AttrList := pango_layout_get_attributes(Layout); If (AttrList = nil) then AttrList := pango_attr_list_new(); //fix me... what about &&, can we strip and do do markup substitution? If Underline then Attr := pango_attr_underline_new(PANGO_UNDERLINE_SINGLE) else Attr := pango_attr_underline_new(PANGO_UNDERLINE_NONE); pango_attr_list_change(AttrList,Attr); Attr := pango_attr_strikethrough_new(StrikeOut); pango_attr_list_change(AttrList,Attr); pango_layout_set_attributes(Layout, AttrList); pango_layout_set_single_paragraph_mode(Layout, TRUE); pango_layout_set_width(Layout, -1); pango_layout_set_alignment(Layout, PANGO_ALIGN_LEFT); //fix me... and what about UTF-8 conversion? //this could be a massive problem since we //will need to know before hand what the current //locale is, and if we stored UTF-8 string this would break //cross-compatibility with GTK1.2 and win32 interfaces..... pango_layout_set_text(Layout, Str, Count); pango_layout_get_pixel_size(Layout, @Size.cX, @Size.cY); g_object_unref(Layout); Result := True; If UnRef then pango_font_description_free(UseFontDesc); end; end; end; {------------------------------------------------------------------------------ Function: TextOut Params: DC: X: Y: Str: Count: Returns: ------------------------------------------------------------------------------} Function TGtk2WidgetSet.TextOut(DC: HDC; X,Y : Integer; Str : Pchar; Count: Integer) : Boolean; var DCOrigin: TPoint; aRect : TRect; UnRef, Underline, StrikeOut : Boolean; RGBColor : Longint; Foreground : PGDKColor; Layout : PPangoLayout; UseFontDesc : PPangoFontDescription; AttrList : PPangoAttrList; Attr : PPangoAttribute; begin Result := IsValidDC(DC); if Result and (Count>0) then with TDeviceContext(DC) do begin if GC = nil then begin DebugLn('WARNING: [TGtk2WidgetSet.TextOut] Uninitialized GC'); end else begin if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin UseFontDesc := GetDefaultFontDesc(true); UnRef := True; Underline := False; StrikeOut := False; end else begin UseFontDesc := CurrentFont^.GDIFontObject; UnRef := False; Underline := CurrentFont^.Underline; StrikeOut := CurrentFont^.StrikeOut; end; If UseFontDesc = nil then DebugLn('WARNING: [TGtk2WidgetSet.TextOut] Missing Font') else begin DCOrigin:=GetDCOffset(TDeviceContext(DC)); GetStyle(lgsdefault); Layout := gtk_widget_create_pango_layout (GetStyleWidget(lgsdefault), nil); pango_layout_set_font_description(Layout, UseFontDesc); AttrList := pango_layout_get_attributes(Layout); If (AttrList = nil) then AttrList := pango_attr_list_new(); //fix me... what about &&, can we strip and do do markup substitution? If Underline then Attr := pango_attr_underline_new(PANGO_UNDERLINE_SINGLE) else Attr := pango_attr_underline_new(PANGO_UNDERLINE_NONE); pango_attr_list_change(AttrList,Attr); Attr := pango_attr_strikethrough_new(StrikeOut); pango_attr_list_change(AttrList,Attr); SelectedColors := dcscCustom; EnsureGCColor(DC, dccCurrentBackColor, True, False); EnsureGCColor(DC, dccCurrentTextColor, True, False); RGBColor := ColorToRGB(CurrentTextColor.ColorRef); Attr := pango_attr_foreground_new(gushort(GetRValue(RGBColor)) shl 8, gushort(GetGValue(RGBColor)) shl 8, gushort(GetBValue(RGBColor)) shl 8); pango_attr_list_change(AttrList,Attr); pango_layout_set_attributes(Layout, AttrList); Foreground := StyleForegroundColor(CurrentTextColor.ColorRef, nil); pango_layout_set_single_paragraph_mode(Layout, TRUE); pango_layout_set_width(Layout, -1); pango_layout_set_alignment(Layout, PANGO_ALIGN_LEFT); //fix me... and what about UTF-8 conversion? //this could be a massive problem since we //will need to know before hand what the current //locale is, and if we stored UTF-8 string this would break //cross-compatibility with GTK1.2 and win32 interfaces..... pango_layout_set_text(Layout, Str, Count); aRect := Rect(0,0,0, 0); pango_layout_get_pixel_size(Layout, @arect.Right, @arect.Bottom); OffsetRect(aRect, X+DCOrigin.X,Y+DCOrigin.Y); gdk_draw_layout_with_colors(drawable, GC, aRect.Left, aRect.Top, Layout, Foreground, nil); g_object_unref(Layout); Result := True; If UnRef then pango_font_description_free(UseFontDesc); end; end; end; end; //##apiwiz##eps## // Do not remove {$IfDef ASSERT_IS_ON} {$UNDEF ASSERT_IS_ON} {$C-} {$EndIf}