diff --git a/components/synedit/syncompletion.pas b/components/synedit/syncompletion.pas index caa0c77dd0..3f2c854a26 100644 --- a/components/synedit/syncompletion.pas +++ b/components/synedit/syncompletion.pas @@ -379,6 +379,25 @@ uses { TSynBaseCompletionForm } constructor TSynBaseCompletionForm.Create(AOwner: TComponent); + + function GetDefaultFontHeight: integer; + {$IFDEF SYN_LAZARUS} + var + TextMetric: TTextMetric; + DC: HDC; + begin + DC:=GetDC(0); + FillChar(TextMetric,SizeOf(TextMetric),0); + GetTextMetrics(DC,TextMetric); + Result := TextMetric.tmHeight+2; + ReleaseDC(0,DC); + end; + {$ELSE} + begin + Result := Canvas.TextHeight('Cyrille de Brebisson')+2; + end; + {$ENDIF} + begin {$IFDEF SYN_LAZARUS} inherited Create(AOwner); @@ -410,7 +429,7 @@ begin FHint := TSynBaseCompletionHint.Create(Self); {$ENDIF} Visible := false; - FFontHeight := Canvas.TextHeight('Cyrille de Brebisson')+2; + FFontHeight := GetDefaultFontHeight; {$IFNDEF SYN_LAZARUS} Color := clWindow; {$ENDIF} diff --git a/components/synedit/synhighlightermulti.pas b/components/synedit/synhighlightermulti.pas index 5a2464d771..c02329cc4f 100644 --- a/components/synedit/synhighlightermulti.pas +++ b/components/synedit/synhighlightermulti.pas @@ -239,6 +239,7 @@ end; { TSynMultiSyn } procedure TSynMultiSyn.ClearMarkers; +{$IFNDEF FPC} const { if the compiler stops here, something is wrong with the constants above } { there is no special reason for this to be here. the constant must be @@ -246,6 +247,7 @@ const so this function was randomly chosen } RangeInfoSize: byte = ( SizeOf(pointer) * 8 ) - ( (MaxNestedMultiSyn * SchemeIndexSize) + SchemeRangeSize ); +{$ENDIF} var i: integer; begin diff --git a/lcl/graphics.pp b/lcl/graphics.pp index fcc6809ed8..dfeb94820c 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -465,15 +465,6 @@ type function IsNameStored: boolean; procedure SetData(const FontData: TFontData); protected - procedure DoAllocateResources; override; - procedure DoDeAllocateResources; override; - procedure DoCopyProps(From: TFPCanvasHelper); override; - procedure SetFlags(Index: integer; AValue: boolean); override; - procedure SetName(AValue: string); override; - procedure SetSize(AValue: integer); override; - procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual; - procedure SetFPColor(const AValue: TFPColor); override; - procedure Changed; override; function GetCharSet: TFontCharSet; function GetHandle: HFONT; function GetHeight: Integer; @@ -481,11 +472,20 @@ type function GetPitch: TFontPitch; function GetSize: Integer; function GetStyle: TFontStyles; + procedure Changed; override; + procedure DoAllocateResources; override; + procedure DoCopyProps(From: TFPCanvasHelper); override; + procedure DoDeAllocateResources; override; procedure SetCharSet(const AValue: TFontCharSet); + procedure SetColor(const NewColor: TColor; const NewFPColor: TFPColor); virtual; procedure SetColor(Value: TColor); + procedure SetFlags(Index: integer; AValue: boolean); override; + procedure SetFPColor(const AValue: TFPColor); override; procedure SetHandle(const Value: HFONT); procedure SetHeight(value: Integer); + procedure SetName(AValue: string); override; procedure SetPitch(Value: TFontPitch); + procedure SetSize(AValue: integer); override; procedure SetStyle(Value: TFontStyles); public constructor Create; override; diff --git a/lcl/include/buttonglyph.inc b/lcl/include/buttonglyph.inc index c4a2469efa..3fb31912ef 100644 --- a/lcl/include/buttonglyph.inc +++ b/lcl/include/buttonglyph.inc @@ -113,10 +113,11 @@ begin //Canvas.CopyRect(DestRect, FOriginal.Canvas, SrcRect) UseMaskHandle:=FOriginal.MaskHandle; - MaskBlt(Canvas.Handle, + MaskBlt(Canvas.GetUpdatedHandle([csHandleValid]), DestRect.Left,DestRect.Top, DestRect.Right-DestRect.Left,DestRect.Bottom-DestRect.Top, - FOriginal.Canvas.Handle,SrcRect.Left,SrcRect.Top, + FOriginal.Canvas.GetUpdatedHandle([csHandleValid]), + SrcRect.Left,SrcRect.Top, UseMaskHandle,SrcRect.Left,SrcRect.Top); // ToDo: VCL returns the text rectangle @@ -124,9 +125,9 @@ begin end; -{------------------------------------------------------------------------------} -{ TButtonGlyph SetNumGlyphs } -{------------------------------------------------------------------------------} +{------------------------------------------------------------------------------ + TButtonGlyph SetNumGlyphs +------------------------------------------------------------------------------} procedure TButtonGlyph.SetNumGlyphs(Value : TNumGlyphs); begin if Value <> FNumGlyphs then begin diff --git a/lcl/include/canvas.inc b/lcl/include/canvas.inc index 95c779a7ec..ebe547707d 100644 --- a/lcl/include/canvas.inc +++ b/lcl/include/canvas.inc @@ -178,7 +178,11 @@ end; procedure TCanvas.CreateFont; var OldHandle: HFONT; begin + // The first time the font handle is selected, the default font handle + // is returned. Save this font handle to restore it later in DeselectHandles. + // The TFont will call DeleteObject itself, so we never need to call it. OldHandle:=SelectObject(FHandle, Font.Handle); + //DebugLn(['TCanvas.CreateFont OldHandle=',dbghex(OldHandle),' Font.Handle=',dbghex(Font.Handle)]); if (OldHandle<>Font.Handle) and (FSavedFontHandle=0) then FSavedFontHandle:=OldHandle; Include(FState, csFontValid); @@ -186,9 +190,9 @@ begin end; {------------------------------------------------------------------------------ - Procedure TCanvas.CreateRegion; + procedure TCanvas.CreateRegion; ------------------------------------------------------------------------------} -Procedure TCanvas.CreateRegion; +procedure TCanvas.CreateRegion; var OldHandle: HRGN; begin OldHandle:=SelectObject(FHandle, Region.Handle); @@ -1016,6 +1020,7 @@ begin Options := Options or DT_INTERNAL; RequiredState([csHandleValid]); SelectObject(Self.Handle, GetStockObject(DEFAULT_GUI_FONT)); + Exclude(FState, csFontValid); end else RequiredState([csHandleValid, csFontValid]); @@ -1390,14 +1395,11 @@ begin if FHandle <> 0 then begin DeselectHandles; - FHandle := 0; Exclude(FState, csHandleValid); end; - if NewHandle <> 0 then - begin + FHandle := NewHandle; + if FHandle <> 0 then Include(FState, csHandleValid); - FHandle := NewHandle; - end; //DebugLn('[TCanvas.SetHandle] END Self=',DbgS(Self),' Handle=',DbgS(FHandle,8)); end; end; @@ -1414,20 +1416,17 @@ begin //debugln('TCanvas.DeselectHandles ',ClassName,' Self=',DbgS(Self),' Handle=',DbgS(FHandle),' FSavedBrushHandle=',DbgS(Cardinal(FSavedBrushHandle))); if (FHandle<>0) then begin // select default sub handles in the device context without deleting owns - if FSavedBrushHandle<>0 then begin + if FSavedBrushHandle<>0 then SelectObject(FHandle,FSavedBrushHandle); - FSavedBrushHandle:=0; - end; - if FSavedPenHandle<>0 then begin + if FSavedPenHandle<>0 then SelectObject(FHandle,FSavedPenHandle); - FSavedPenHandle:=0; - end; - if FSavedFontHandle<>0 then begin + if FSavedFontHandle<>0 then SelectObject(FHandle,FSavedFontHandle); - FSavedFontHandle:=0; - end; FState := FState - [csPenValid, csBrushValid, csFontValid]; end; + FSavedBrushHandle:=0; + FSavedPenHandle:=0; + FSavedFontHandle:=0; end; {------------------------------------------------------------------------------ diff --git a/lcl/include/customlabel.inc b/lcl/include/customlabel.inc index e02156beee..7a68139785 100644 --- a/lcl/include/customlabel.inc +++ b/lcl/include/customlabel.inc @@ -394,7 +394,7 @@ begin SystemFont:=false; end; TextLeft := R.Left; - if layout = tlTop then begin + if Layout = tlTop then begin TextTop := R.Top; end else begin CalcSize(lTextWidth, lTextHeight); diff --git a/lcl/include/font.inc b/lcl/include/font.inc index 677ef17981..a0eb9c6a7f 100644 --- a/lcl/include/font.inc +++ b/lcl/include/font.inc @@ -171,18 +171,8 @@ begin end; function GetDefFontCharSet: TFontCharSet; -//var -// DisplayDC: HDC; -// TxtMetric: TTEXTMETRIC; begin Result := DEFAULT_CHARSET; - {DisplayDC := GetDC(0); - if (DisplayDC <> 0) then begin - if (SelectObject(DisplayDC, StockFont) <> 0) then - if (GetTextMetrics(DisplayDC, TxtMetric)) then - Result := TxtMetric.tmCharSet; - ReleaseDC(0, DisplayDC); - end;} end; {------------------------------------------------------------------------------ diff --git a/lcl/interfaces/gtk/gtkdef.pp b/lcl/interfaces/gtk/gtkdef.pp index 11b884d0ee..78957aebd7 100644 --- a/lcl/interfaces/gtk/gtkdef.pp +++ b/lcl/interfaces/gtk/gtkdef.pp @@ -225,6 +225,7 @@ type procedure Clear; function GetGC: pgdkGC; + function GetFont: PGdiObject; end; @@ -397,8 +398,10 @@ procedure DisposeDeviceContext(DeviceContext: TDeviceContext); type TCreateGCForDC = procedure(DC: TDeviceContext) of object; + TCreateFontForDC = procedure(DC: TDeviceContext) of object; var CreateGCForDC: TCreateGCForDC = nil; + CreateFontForDC: TCreateFontForDC = nil; {$IFDEF DebugLCLComponents} var @@ -629,6 +632,13 @@ begin Result:=GC; end; +function TDeviceContext.GetFont: PGdiObject; +begin + if CurrentFont=nil then + CreateFontForDC(Self); + Result:=CurrentFont; +end; + procedure GtkDefInit; begin {$IFDEF DebugLCLComponents} diff --git a/lcl/interfaces/gtk/gtkfontcache.pas b/lcl/interfaces/gtk/gtkfontcache.pas index af858c19fb..0545f7d151 100644 --- a/lcl/interfaces/gtk/gtkfontcache.pas +++ b/lcl/interfaces/gtk/gtkfontcache.pas @@ -62,7 +62,12 @@ type end; - { TGtkFontCache } + { TGtkFontCache + Notes: + Each font can be used by several Device Contexts. + Each font can have several font descriptors. + A font descriptor has one font. + } TGtkFontCache = class(TResourceCache) protected diff --git a/lcl/interfaces/gtk/gtkint.pp b/lcl/interfaces/gtk/gtkint.pp index 2482eefc7a..c920cd7cc7 100644 --- a/lcl/interfaces/gtk/gtkint.pp +++ b/lcl/interfaces/gtk/gtkint.pp @@ -167,6 +167,8 @@ type procedure DisposeDC(aDC: TDeviceContext);virtual; function CreateDCForWidget(TheWidget: PGtkWidget; TheWindow: PGdkWindow; WithChildWindows: boolean): HDC; + procedure OnCreateGCForDC(DC: TDeviceContext); + procedure OnCreateFontForDC(DC: TDeviceContext); function GetDoubleBufferedDC(Handle: HWND): HDC; // GDIObjects @@ -186,6 +188,7 @@ type function GetDefaultFontDesc(IncreaseReferenceCount: boolean): PPangoFontDescription; {$Endif} function GetDefaultGtkFont(IncreaseReferenceCount: boolean): TGtkIntfFont; + function GetGtkFont(DC: TDeviceContext): TGtkIntfFont; function CreateRegionCopy(SrcRGN: hRGN): hRGN; override; function DCClipRegionValid(DC: HDC): boolean; override; function CreateEmptyRegion: hRGN; override; @@ -243,7 +246,6 @@ type procedure RemoveCallbacks(Widget: PGtkWidget); virtual; function ROP2ModeToGdkFunction(Mode: Integer): TGdkFunction; function gdkFunctionToROP2Mode(aFunction: TGdkFunction): Integer; - procedure OnCreateGCForDC(DC: TDeviceContext); // for gtk specific components: procedure SetLabelCaption(const ALabel: PGtkLabel; const ACaption: String; diff --git a/lcl/interfaces/gtk/gtkobject.inc b/lcl/interfaces/gtk/gtkobject.inc index 4c823db8b9..59454d954f 100644 --- a/lcl/interfaces/gtk/gtkobject.inc +++ b/lcl/interfaces/gtk/gtkobject.inc @@ -176,6 +176,7 @@ begin FDeviceContexts := TDynHashArray.Create(-1); FDeviceContexts.Options:=FDeviceContexts.Options+[dhaoCacheContains]; CreateGCForDC:=@OnCreateGCForDC; + CreateFontForDC:=@OnCreateFontForDC; FGDIObjects := TDynHashArray.Create(-1); FGDIObjects.Options:=FGDIObjects.Options+[dhaoCacheContains]; @@ -362,6 +363,9 @@ var QueueItem : TGtkMessageQueueItem; NextQueueItem : TGtkMessageQueueItem; begin + CreateGCForDC:=nil; + CreateFontForDC:=nil; + ReAllocMem(FExtUTF8OutCache,0); FExtUTF8OutCacheSize:=0; @@ -409,7 +413,7 @@ begin DebugLn(); end; {$endif} - + if (FGDIObjects.Count > 0) then begin DebugLn(ProcName,Format(rsWarningUnreleasedGDIObjectsDump, @@ -6393,22 +6397,14 @@ end; Params: none Returns: a gtkwinapi DeviceContext - Creates an initial DC + Creates a raw DC and adds it to FDeviceContexts. + + Used internally by: CreateCompatibleDC, CreateDCForWidget and SaveDC ------------------------------------------------------------------------------} function TGtkWidgetSet.NewDC: TDeviceContext; begin Assert(False, Format('Trace:> [TGtkWidgetSet.NewDC]', [])); Result:=NewDeviceContext; - with Result do - begin - {$ifdef TraceGdiCalls} - FillStackAddrs(get_caller_frame(get_frame), @StackAddrs); - {$endif} - gdk_color_black(gdk_colormap_get_system, @CurrentTextColor.Color); - BuildColorRefFromGDKColor(CurrentTextColor); - gdk_color_white(gdk_colormap_get_system, @CurrentBackColor.Color); - BuildColorRefFromGDKColor(CurrentBackColor); - end; FDeviceContexts.Add(Result); //DebugLn('[TGtkWidgetSet.NewDC] ',DbgS(Result),' ',FDeviceContexts.Count); // Assert(False, Format('Trace:< [TGtkWidgetSet.NewDC] FDeviceContexts[%d] --> 0x%p', [n, Result])); @@ -6441,11 +6437,20 @@ function TGtkWidgetSet.CreateDCForWidget(TheWidget: PGtkWidget; RaiseGDBException('TGtkWidgetSet.CreateWindowDC widget ' +DbgS(TheWidget)+' has no client area'); end; + + procedure WriteWidgetNotRealized(aWidget: PGtkWidget); + begin + {DebugLn(['NOTE: TGtkWidgetSet.CreateDCForWidget: ', + 'creating a DC for a widget, which has not been realized yet: ', + GetWidgetDebugReport(aWidget),'. ', + 'This means normally you do a visual operation on a control, that is not yet on any screen. ', + 'Forcing .... ']);} + //DumpStack; + end; var aDC: TDeviceContext; ClientWidget: PGtkWidget; - FontGdiObject: PGdiObject; begin aDC := nil; @@ -6453,7 +6458,6 @@ begin aDC.WithChildWindows := WithChildWindows; aDC.DCWidget := TheWidget; - FontGdiObject := nil; ClientWidget := nil; if TheWidget = nil @@ -6468,6 +6472,8 @@ begin TheWindow:=GetControlWindow(ClientWidget); if TheWindow=nil then begin //force creation + if not GTK_WIDGET_REALIZED(ClientWidget) then + WriteWidgetNotRealized(ClientWidget); gtk_widget_realize(ClientWidget); TheWindow := GetControlWindow(ClientWidget); if TheWindow=nil then @@ -6482,39 +6488,94 @@ begin {$ENDIF} end; - if aDC <> nil - then begin - {$Ifdef GTK1} - // ToDo: create font on demand - if aDC.GCValues.Font <> nil - then begin - FontGdiObject:=NewGDIObject(gdiFont); - FontGdiObject^.GDIFontObject := aDC.GCValues.Font; - FontCache.Reference(FontGdiObject^.GDIFontObject); - end - else FontGdiObject := CreateDefaultFont; - {$ELSE} - // ToDo: create font on demand - if ClientWidget<>nil then begin - FontGdiObject:=NewGDIObject(gdiFont); - FontGdiObject^.GDIFontObject:= - gtk_widget_create_pango_layout(ClientWidget,nil); - FontCache.Reference(FontGdiObject^.GDIFontObject); - end; - {$EndIf} - - If FontGdiObject = nil then - FontGdiObject := CreateDefaultFont; - - aDC.CurrentFont := FontGdiObject; - aDC.CurrentBrush := CreateDefaultBrush; - aDC.CurrentPen := CreateDefaultPen; + with aDC do + begin + {$ifdef TraceGdiCalls} + FillStackAddrs(get_caller_frame(get_frame), @StackAddrs); + {$endif} + gdk_color_black(gdk_colormap_get_system, @CurrentTextColor.Color); + BuildColorRefFromGDKColor(CurrentTextColor); + gdk_color_white(gdk_colormap_get_system, @CurrentBackColor.Color); + BuildColorRefFromGDKColor(CurrentBackColor); end; + {$Ifdef GTK1} + aDC.GetFont; + {$ELSE} + // font is created on demand + {$EndIf} + + aDC.CurrentBrush := CreateDefaultBrush; + aDC.CurrentPen := CreateDefaultPen; + Result := HDC(aDC); Assert(False, Format('trace:< [TGtkWidgetSet.CreateDCForWidget] Got 0x%x', [Result])); end; +procedure TGTKWidgetSet.OnCreateGCForDC(DC: TDeviceContext); +{$IFDEF Gtk1} +var + CurWidget: PGtkWidget; + CurWindow: PGdkWindow; +{$ENDIF} +begin + if DC.GC<>nil then exit; + + // create GC + if DC.Drawable<>nil then begin + if DC.WithChildWindows then begin + FillChar(DC.GCValues, SizeOf(DC.GCValues), #0); + DC.GCValues.subwindow_mode := GDK_INCLUDE_INFERIORS; + DC.GC:=gdk_gc_new_with_values(DC.Drawable, + @DC.GCValues,GDK_GC_FUNCTION or GDK_GC_SUBWINDOW); + end else begin + DC.GC:=gdk_gc_new(DC.Drawable); + end; + end else begin + // create default GC + {$IFDEF Gtk1} + CurWidget:=GetStyleWidget(lgsWindow); + CurWindow:=CurWidget^.window; + DC.GC:=gdk_gc_new(CurWindow); + {$ELSE} + DC.GC:=gdk_gc_new(gdk_screen_get_root_window(gdk_screen_get_default)); + {$ENDIF} + end; + if DC.GC<>nil then begin + gdk_gc_set_function(DC.GC, GDK_COPY); + gdk_gc_get_values(DC.GC, @DC.GCValues); + end; +end; + +procedure TGTKWidgetSet.OnCreateFontForDC(DC: TDeviceContext); +{$IFDEF Gtk2} +var + ClientWidget: PGtkWidget; +{$ENDIF} +begin + if DC.CurrentFont<>nil then exit; + + // create font + {$IFDEF Gtk1} + if DC.GCValues.Font <> nil then begin + DC.CurrentFont:=NewGDIObject(gdiFont); + DC.CurrentFont^.GDIFontObject := DC.GCValues.Font; + FontCache.Reference(DC.CurrentFont^.GDIFontObject); + end else + DC.CurrentFont := CreateDefaultFont; + {$ELSE} + if DC.DCWidget<>nil then begin + ClientWidget:=GetFixedWidget(DC.DCWidget); + DC.CurrentFont:=NewGDIObject(gdiFont); + DC.CurrentFont^.GDIFontObject:= + gtk_widget_create_pango_layout(ClientWidget,nil); + FontCache.Reference(DC.CurrentFont^.GDIFontObject); + end else + DC.CurrentFont := CreateDefaultFont; + //DebugLn(['TGTKWidgetSet.OnCreateFontForDC DC=',dbghex(PtrInt(DC)),' Font=',dbghex(PtrInt(DC.CurrentFont))]); + {$ENDIF} +end; + {------------------------------------------------------------------------------ function TGtkWidgetSet.GetDoubleBufferedDC(Handle: HWND): HDC; ------------------------------------------------------------------------------} @@ -6687,7 +6748,7 @@ var CachedFont: TGtkFontCacheDescriptor; begin Result := NewGDIObject(gdiFont); - Result^.GDIFontObject:= GetDefaultGtkFont(true); + Result^.GDIFontObject:=GetDefaultGtkFont(false); CachedFont:=FontCache.FindADescriptor(Result^.GDIFontObject); if CachedFont<>nil then FontCache.Reference(Result^.GDIFontObject) @@ -6704,7 +6765,7 @@ end; ------------------------------------------------------------------------------} function TGtkWidgetSet.CreateDefaultPen: PGdiObject; begin -//write(' TGtkWidgetSet.CreateDefaultPen ->'); + //write(' TGtkWidgetSet.CreateDefaultPen ->'); Result := NewGDIObject(gdiPen); Result^.GDIPenStyle := PS_SOLID; Result^.GDIPenColor.ColorRef := 0; @@ -6750,137 +6811,127 @@ begin // cache valid exit; end; - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) - then begin - UseFont := GetDefaultGtkFont(false); - end - else begin - UseFont := CurrentFont^.GDIFontObject; + UseFont:=GetGtkFont(TDeviceContext(DC)); + FillChar(DCTextMetric, SizeOf(DCTextMetric), 0); + CachedFont:=FontCache.FindGTKFont(UseFont); + if (CachedFont=nil) and (UseFont <> GetDefaultGtkFont(false)) then begin + DebugLn(['TGtkWidgetSet.UpdateDCTextMetric no CachedFont UseFont=',dbgs(UseFont)]); + DumpStack; end; - If UseFont = nil then begin - DebugLn('WARNING: [TGtkWidgetSet.GetTextMetrics] Missing font') - end else begin - FillChar(DCTextMetric, SizeOf(DCTextMetric), 0); - CachedFont:=FontCache.FindGTKFont(UseFont); - if (CachedFont=nil) and (UseFont <> GetDefaultGtkFont(false)) then begin - DebugLn(['TGtkWidgetSet.UpdateDCTextMetric no CachedFont UseFont=',dbgs(UseFont)]); - DumpStack; - end; - - if (CachedFont<>nil) and (CachedFont.MetricsValid) then begin - DCTextMetric.lBearing:=CachedFont.lBearing; - DCTextMetric.rBearing:=CachedFont.rBearing; - DCTextMetric.IsDoubleByteChar:=CachedFont.IsDoubleByteChar; - DCTextMetric.IsMonoSpace:=CachedFont.IsMonoSpace; - DCTextMetric.TextMetric:=CachedFont.TextMetric; - end - else with DCTextMetric do begin - IsDoubleByteChar:=FontIsDoubleByteCharsFont(UseFont); - IsMonoSpace:=FontIsMonoSpaceFont(UseFont); - {$IFDEF Gtk1} - AvgTxtLen:=length(TestString[false]); - if IsDoubleByteChar then begin - gdk_text_extents(UseFont, PChar(TestString[IsDoubleByteChar]), - AvgTxtLen, @lBearing, @rBearing, @Width, - @TextMetric.tmAscent, @TextMetric.tmDescent); - //debugln('TGtkWidgetSet.UpdateDCTextMetric A IsDoubleByteChar=',dbgs(IsDoubleByteChar),' Width=',dbgs(Width),' AvgTxtLen=',dbgs(AvgTxtLen)); - TextMetric.tmHeight := TextMetric.tmAscent+TextMetric.tmDescent; - // gdk_text_height(UseFont,PChar(TestString[IsDoubleByteChar]), - // AvgTxtLen*2) - // {$IfNDef Win32} + TextMetric.tmdescent div 2{$EndIf}; - end else begin - gdk_text_extents(UseFont, PChar(TestString[IsDoubleByteChar]), - AvgTxtLen, @lBearing, @rBearing, @Width, - @TextMetric.tmAscent, @TextMetric.tmDescent); - TextMetric.tmHeight := TextMetric.tmAscent+TextMetric.tmDescent; - // gdk_text_height(UseFont,PChar(TestString[IsDoubleByteChar]), - // AvgTxtLen) - // {$IfNDef Win32} + TextMetric.tmdescent div 2{$EndIf}; - end; - //if Widthnil then begin - Desc:=FontCache.FindADescriptor(UseFont); - if Desc<>nil then - APangoFontDescription := Desc.PangoFontDescription; - //DebugLn(['TGtkWidgetSet.UpdateDCTextMetric CachedFont Desc.PangoFontDescription=',GetPangoDescriptionReport(APangoFontDescription)]); - end; - if APangoFontDescription=nil then - APangoFontDescription:=GetDefaultFontDesc(false); - if APangoFontDescription=nil then - DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango font description']); - //DebugLn(['TGtkWidgetSet.UpdateDCTextMetric APangoFontDescription=',GetPangoDescriptionReport(APangoFontDescription)]); - // get pango metrics (e.g. ascent, descent) - APangoMetrics := pango_context_get_metrics(APangoContext, - APangoFontDescription, APangoLanguage); - if APangoMetrics=nil then - DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango metrics']); - - TextMetric.tmAveCharWidth := Max(1, - pango_font_metrics_get_approximate_char_width(APangoMetrics) - div PANGO_SCALE); - TextMetric.tmAscent := pango_font_metrics_get_ascent(APangoMetrics) div PANGO_SCALE; - TextMetric.tmDescent := pango_font_metrics_get_descent(APangoMetrics) div PANGO_SCALE; + + if (CachedFont<>nil) and (CachedFont.MetricsValid) then begin + DCTextMetric.lBearing:=CachedFont.lBearing; + DCTextMetric.rBearing:=CachedFont.rBearing; + DCTextMetric.IsDoubleByteChar:=CachedFont.IsDoubleByteChar; + DCTextMetric.IsMonoSpace:=CachedFont.IsMonoSpace; + DCTextMetric.TextMetric:=CachedFont.TextMetric; + end + else with DCTextMetric do begin + IsDoubleByteChar:=FontIsDoubleByteCharsFont(UseFont); + IsMonoSpace:=FontIsMonoSpaceFont(UseFont); + {$IFDEF Gtk1} + AvgTxtLen:=length(TestString[false]); + if IsDoubleByteChar then begin + gdk_text_extents(UseFont, PChar(TestString[IsDoubleByteChar]), + AvgTxtLen, @lBearing, @rBearing, @Width, + @TextMetric.tmAscent, @TextMetric.tmDescent); + //debugln('TGtkWidgetSet.UpdateDCTextMetric A IsDoubleByteChar=',dbgs(IsDoubleByteChar),' Width=',dbgs(Width),' AvgTxtLen=',dbgs(AvgTxtLen)); TextMetric.tmHeight := TextMetric.tmAscent+TextMetric.tmDescent; + // gdk_text_height(UseFont,PChar(TestString[IsDoubleByteChar]), + // AvgTxtLen*2) + // {$IfNDef Win32} + TextMetric.tmdescent div 2{$EndIf}; + end else begin + gdk_text_extents(UseFont, PChar(TestString[IsDoubleByteChar]), + AvgTxtLen, @lBearing, @rBearing, @Width, + @TextMetric.tmAscent, @TextMetric.tmDescent); + TextMetric.tmHeight := TextMetric.tmAscent+TextMetric.tmDescent; + // gdk_text_height(UseFont,PChar(TestString[IsDoubleByteChar]), + // AvgTxtLen) + // {$IfNDef Win32} + TextMetric.tmdescent div 2{$EndIf}; + end; + //if Widthnil then begin + Desc:=FontCache.FindADescriptor(UseFont); + if Desc<>nil then + APangoFontDescription := Desc.PangoFontDescription; + //DebugLn(['TGtkWidgetSet.UpdateDCTextMetric CachedFont Desc.PangoFontDescription=',GetPangoDescriptionReport(APangoFontDescription)]); + end; + if APangoFontDescription=nil then + APangoFontDescription:=GetDefaultFontDesc(false); + if APangoFontDescription=nil then + DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango font description']); + //DebugLn(['TGtkWidgetSet.UpdateDCTextMetric APangoFontDescription=',GetPangoDescriptionReport(APangoFontDescription)]); + // get pango metrics (e.g. ascent, descent) + APangoMetrics := pango_context_get_metrics(APangoContext, + APangoFontDescription, APangoLanguage); + if APangoMetrics=nil then + DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango metrics']); - pango_layout_set_text(UseFont, PChar(TestString[IsDoubleByteChar]), - length(PChar(TestString[IsDoubleByteChar]))); - pango_layout_get_extents(UseFont, nil, @aRect); + TextMetric.tmAveCharWidth := Max(1, + pango_font_metrics_get_approximate_char_width(APangoMetrics) + div PANGO_SCALE); + TextMetric.tmAscent := pango_font_metrics_get_ascent(APangoMetrics) div PANGO_SCALE; + TextMetric.tmDescent := pango_font_metrics_get_descent(APangoMetrics) div PANGO_SCALE; + TextMetric.tmHeight := TextMetric.tmAscent+TextMetric.tmDescent; - lBearing := PANGO_LBEARING(aRect) div PANGO_SCALE; - rBearing := PANGO_RBEARING(aRect) div PANGO_SCALE; + pango_layout_set_text(UseFont, PChar(TestString[IsDoubleByteChar]), + length(PChar(TestString[IsDoubleByteChar]))); + pango_layout_get_extents(UseFont, nil, @aRect); - pango_layout_set_text(UseFont, 'M', 1); - pango_layout_get_pixel_size(UseFont, @aRect.width, @aRect.height); - TextMetric.tmMaxCharWidth := Max(1,aRect.width); - pango_layout_set_text(UseFont, 'W', 1); - pango_layout_get_pixel_size(UseFont, @aRect.width, @aRect.height); - TextMetric.tmMaxCharWidth := Max(TextMetric.tmMaxCharWidth,aRect.width); + lBearing := PANGO_LBEARING(aRect) div PANGO_SCALE; + rBearing := PANGO_RBEARING(aRect) div PANGO_SCALE; - pango_font_metrics_unref(APangoMetrics); + pango_layout_set_text(UseFont, 'M', 1); + pango_layout_get_pixel_size(UseFont, @aRect.width, @aRect.height); + TextMetric.tmMaxCharWidth := Max(1,aRect.width); + pango_layout_set_text(UseFont, 'W', 1); + pango_layout_get_pixel_size(UseFont, @aRect.width, @aRect.height); + TextMetric.tmMaxCharWidth := Max(TextMetric.tmMaxCharWidth,aRect.width); + + pango_font_metrics_unref(APangoMetrics); + {$ENDIF} + (*debugln('TGtkWidgetSet.UpdateDCTextMetric A IsDoubleByteChar=',dbgs(IsDoubleByteChar), + ' lbearing=',dbgs(lBearing),' rbearing=',dbgs(rBearing), + {$IFDEF Gtk1} + ' width='+dbgs(width), + ' AvgTxtLen='+dbgs(AvgTxtLen), {$ENDIF} - (*debugln('TGtkWidgetSet.UpdateDCTextMetric A IsDoubleByteChar=',dbgs(IsDoubleByteChar), - ' lbearing=',dbgs(lBearing),' rbearing=',dbgs(rBearing), - {$IFDEF Gtk1} - ' width='+dbgs(width), - ' AvgTxtLen='+dbgs(AvgTxtLen), - {$ENDIF} - ' tmAscent='+dbgs(TextMetric.tmAscent), - ' tmDescent='+dbgs(TextMetric.tmdescent), - ' tmHeight='+dbgs(TextMetric.tmHeight), - ' tmMaxCharWidth='+dbgs(TextMetric.tmMaxCharWidth), - ' tmAveCharWidth='+dbgs(TextMetric.tmAveCharWidth));*) - if (CachedFont<>nil) then begin - CachedFont.lBearing:=lBearing; - CachedFont.rBearing:=rBearing; - CachedFont.IsDoubleByteChar:=IsDoubleByteChar; - CachedFont.IsMonoSpace:=IsMonoSpace; - CachedFont.TextMetric:=TextMetric; - CachedFont.MetricsValid:=true; - end; + ' tmAscent='+dbgs(TextMetric.tmAscent), + ' tmDescent='+dbgs(TextMetric.tmdescent), + ' tmHeight='+dbgs(TextMetric.tmHeight), + ' tmMaxCharWidth='+dbgs(TextMetric.tmMaxCharWidth), + ' tmAveCharWidth='+dbgs(TextMetric.tmAveCharWidth));*) + if (CachedFont<>nil) then begin + CachedFont.lBearing:=lBearing; + CachedFont.rBearing:=rBearing; + CachedFont.IsDoubleByteChar:=IsDoubleByteChar; + CachedFont.IsMonoSpace:=IsMonoSpace; + CachedFont.TextMetric:=TextMetric; + CachedFont.MetricsValid:=true; end; end; Include(DCFlags,dcfTextMetricsValid); @@ -6917,11 +6968,27 @@ begin FDefaultFont:=LoadDefaultFont; if FDefaultFont = nil then raise EOutOfResources.Create(rsUnableToLoadDefaultFont); - ReferenceGtkIntfFont(FDefaultFont); // mark as used + ReferenceGtkIntfFont(FDefaultFont); // mark as used globally end; Result:=FDefaultFont; if IncreaseReferenceCount then - ReferenceGtkIntfFont(Result); + ReferenceGtkIntfFont(Result); // mark again +end; + +function TGTKWidgetSet.GetGtkFont(DC: TDeviceContext): TGtkIntfFont; +begin + {$IFDEF Gtk} + if (DC.CurrentFont = nil) or (DC.CurrentFont^.GDIFontObject = nil) + then begin + Result := GetDefaultGtkFont(false); + end + else begin + Result := DC.CurrentFont^.GDIFontObject; + end; + {$ELSE} + // create font if needed + Result:=DC.GetFont^.GDIFontObject; + {$ENDIF} end; function TGtkWidgetSet.CreateRegionCopy(SrcRGN: hRGN): hRGN; @@ -7276,15 +7343,7 @@ var procedure InitFont; begin - with TDeviceContext(DC) do begin - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) - then begin - UseFont := GetDefaultGtkFont(false); - end - else begin - UseFont := CurrentFont^.GDIFontObject; - end; - end; + UseFont:=GetGtkFont(TDeviceContext(DC)); end; var @@ -7409,41 +7468,6 @@ begin end; end; -procedure TGTKWidgetSet.OnCreateGCForDC(DC: TDeviceContext); -{$IFDEF Gtk1} -var - CurWidget: PGtkWidget; - CurWindow: PGdkWindow; -{$ENDIF} -begin - if DC.GC=nil then begin - // create GC - if DC.Drawable<>nil then begin - if DC.WithChildWindows then begin - FillChar(DC.GCValues, SizeOf(DC.GCValues), #0); - DC.GCValues.subwindow_mode := GDK_INCLUDE_INFERIORS; - DC.GC:=gdk_gc_new_with_values(DC.Drawable, - @DC.GCValues,GDK_GC_FUNCTION or GDK_GC_SUBWINDOW); - end else begin - DC.GC:=gdk_gc_new(DC.Drawable); - end; - end else begin - // create default GC - {$IFDEF Gtk1} - CurWidget:=GetStyleWidget(lgsWindow); - CurWindow:=CurWidget^.window; - DC.GC:=gdk_gc_new(CurWindow); - {$ELSE} - DC.GC:=gdk_gc_new(gdk_screen_get_root_window(gdk_screen_get_default)); - {$ENDIF} - end; - if DC.GC<>nil then begin - gdk_gc_set_function(DC.GC, GDK_COPY); - gdk_gc_get_values(DC.GC, @DC.GCValues); - end; - end; -end; - function TGtkWidgetSet.ForceLineBreaks(DC : hDC; Src: PChar; MaxWidthInPixels : Longint; ProcessAmpersands : Boolean) : PChar; var diff --git a/lcl/interfaces/gtk/gtkproc.inc b/lcl/interfaces/gtk/gtkproc.inc index 83b40e3ba0..be340aaaab 100644 --- a/lcl/interfaces/gtk/gtkproc.inc +++ b/lcl/interfaces/gtk/gtkproc.inc @@ -1416,20 +1416,23 @@ end; Function: CopyDCData Params: DestinationDC: a dc to copy data to SourceDC: a dc to copy data from + FreeObjects: boolean Returns: True if succesful Creates a copy DC from the given DC ------------------------------------------------------------------------------} function CopyDCData(DestinationDC, SourceDC: TDeviceContext): Boolean; begin -// Assert(False, Format('Trace:> [CopyDCData] DestDC:0x%x, SourceDC:0x%x', [Integer(DestinationDC), Integer(SourceDC)])); + // Assert(False, Format('Trace:> [CopyDCData] DestDC:0x%x, SourceDC:0x%x', [Integer(DestinationDC), Integer(SourceDC)])); Result := (DestinationDC <> nil) and (SourceDC <> nil); if Result then begin with DestinationDC do begin DCWidget := SourceDC.DCWidget; + WithChildWindows := SourceDC.WithChildWindows; Drawable := SourceDC.Drawable; + OriginalDrawable := SourceDC.OriginalDrawable; if GC<>nil then begin // free old GC BeginGDKErrorTrap; @@ -1455,11 +1458,21 @@ begin DCTextMetric := SourceDC.DCTextMetric; end else Exclude(DCFlags,dcfTextMetricsValid); + // ToDo: should the bitmap be freed automatically? CurrentBitmap := SourceDC.CurrentBitmap; + //DebugLn(['CopyDCData DC=',dbghex(PtrInt(DestinationDC)),' OldFont=',dbghex(PtrInt(CurrentFont2)),' NewFont=',dbghex(PtrInt(SourceDC.CurrentFont2))]); + if (CurrentFont<>nil) and (CurrentFont<>SourceDC.CurrentFont) then + DeleteObject(HGDIObj(CurrentFont)); CurrentFont := SourceDC.CurrentFont; + if (CurrentPen<>nil) and (CurrentPen<>SourceDC.CurrentPen) then + DeleteObject(HGDIObj(CurrentPen)); CurrentPen := SourceDC.CurrentPen; + if (CurrentBrush<>nil) and (CurrentBrush<>SourceDC.CurrentBrush) then + DeleteObject(HGDIObj(CurrentBrush)); CurrentBrush := SourceDC.CurrentBrush; - //CurrentPalette := SourceDC.CurrentPalette; + if (CurrentPalette<>nil) and (CurrentPalette<>SourceDC.CurrentPalette) then + DeleteObject(HGDIObj(CurrentPalette)); + CurrentPalette := SourceDC.CurrentPalette; CopyGDIColor(SourceDC.CurrentTextColor,CurrentTextColor); CopyGDIColor(SourceDC.CurrentBackColor,CurrentBackColor); ClipRegion := SourceDC.ClipRegion; @@ -3910,6 +3923,10 @@ begin Result := PGTKWidget(Widget)^.Window else Result := PGtkLayout(Widget)^.bin_window; + {$IFDEF Gtk2} + if (Result=nil) and (GTK_WIDGET_NO_WINDOW(Widget)) then + Result:=gtk_widget_get_parent_window(Widget); + {$ENDIF} end else RaiseGDBException('GetControlWindow Widget=nil'); end; diff --git a/lcl/interfaces/gtk/gtkwinapi.inc b/lcl/interfaces/gtk/gtkwinapi.inc index 954af49a83..a19a7a9e03 100644 --- a/lcl/interfaces/gtk/gtkwinapi.inc +++ b/lcl/interfaces/gtk/gtkwinapi.inc @@ -1228,8 +1228,18 @@ begin // Wait till a bitmap get selected end; *) + with pNewDC do + begin + {$ifdef TraceGdiCalls} + FillStackAddrs(get_caller_frame(get_frame), @StackAddrs); + {$endif} + gdk_color_black(gdk_colormap_get_system, @CurrentTextColor.Color); + BuildColorRefFromGDKColor(CurrentTextColor); + gdk_color_white(gdk_colormap_get_system, @CurrentBackColor.Color); + BuildColorRefFromGDKColor(CurrentBackColor); + end; - pNewDC.CurrentFont := CreateDefaultFont; + pNewDC.GetFont; pNewDC.CurrentBrush := CreateDefaultBrush; pNewDC.CurrentPen := CreateDefaultPen; @@ -4019,12 +4029,9 @@ begin UnderLine:=false; if (Str<>nil) and (Count>0) then begin - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin - UseFont := GetDefaultGtkFont(false); - end else begin - UseFont := CurrentFont^.GDIFontObject; + Usefont:=GetGtkFont(TDeviceContext(DC)); + if (CurrentFont <> nil) and (CurrentFont^.GDIFontObject <> nil) then UnderLine:= (CurrentFont^.LogFont.lfUnderline<>0); - end; if UseFont <> nil then begin if (Options and ETO_CLIPPED) <> 0 then @@ -6156,41 +6163,31 @@ begin if Result then with TDeviceContext(DC) do begin - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) - then begin - UseFont := GetDefaultGtkFont(false); - end - else begin - UseFont := CurrentFont^.GDIFontObject; - end; - If UseFont = nil then - DebugLn('WARNING: [TGtkWidgetSet.GetTextExtentPoint] Missing font') - else begin - descent:=0; - UpdateDCTextMetric(TDeviceContext(DC)); - IsDBCSFont:=TDeviceContext(DC).DCTextMetric.IsDoubleByteChar; - if IsDBCSFont then begin - NewCount:=Count*2; - if FExtUTF8OutCacheSize [TGtkWidgetSet.ReleaseDC] DC:0x%x', [DC])); Result := 0; - if {(hWnd <> 0) and} (DC <> 0) + if (DC <> 0) then begin if FDeviceContexts.Contains(Pointer(DC)) then begin aDC := TDeviceContext(DC); - { Release all saved device contexts } + // Release all saved device contexts pSavedDC:=aDC.SavedContext; if pSavedDC<>nil then begin if pSavedDC.CurrentBitmap = aDC.CurrentBitmap @@ -7589,8 +7586,9 @@ begin if pSavedDC.CurrentBrush = aDC.CurrentBrush then aDC.CurrentBrush := nil; - {if pSavedDC.CurrentPalette = aDC.CurrentPalette - then aDC.CurrentPalette := nil;} + if pSavedDC.CurrentPalette = aDC.CurrentPalette + then + aDC.CurrentPalette := nil; if pSavedDC.ClipRegion = aDC.ClipRegion then pSavedDC.ClipRegion := 0; @@ -7601,11 +7599,12 @@ begin // Release all graphic objects DeleteObject(HGDIObj(aDC.CurrentBrush)); DeleteObject(HGDIObj(aDC.CurrentPen)); + //DebugLn(['TGtkWidgetSet.ReleaseDC DC=',dbghex(PtrInt(DC)),' Font=',dbghex(PtrInt(aDC.CurrentFont))]); DeleteObject(HGDIObj(aDC.CurrentFont)); // bitmaps are not auto created, they are set via SelectObject // -> user must free it // ... DeleteObject(HGDIObj(aDC.CurrentBitmap)); - //DeleteObject(HGDIObj(aDC.CurrentPalette)); + DeleteObject(HGDIObj(aDC.CurrentPalette)); DeleteObject(HGDIObj(aDC.ClipRegion)); {FreeGDIColor(aDC.CurrentTextColor); FreeGDIColor(aDC.CurrentBackColor);} @@ -7618,8 +7617,8 @@ begin end; except on E:Exception do begin - //Nothing, just try to unref it - //(it segfaults if the window doesnt exist anymore :-) + // Nothing, just try to unref it + // (it segfaults if the window doesnt exist anymore :-) DebugLn('TGtkWidgetSet.ReleaseDC: ',E.Message); end; end; @@ -7658,6 +7657,7 @@ var ClipRegionChanged: Boolean; begin Assert(False, Format('Trace:> [TGtkWidgetSet.RestoreDC] DC:0x%x, SavedDC: %d', [DC, SavedDC])); + Result := IsValidDC(DC) and (SavedDC <> 0); if Result then begin @@ -7695,7 +7695,7 @@ begin // free saved DC - //prevent deleting of copied objects: + //prevent deletion of copied objects: if pSavedDC.CurrentBitmap = aDC.CurrentBitmap then pSavedDC.CurrentBitmap := nil; @@ -7998,8 +7998,10 @@ begin with TDeviceContext(DC) do begin Assert(False, Format('trace: [TGtkWidgetSet.SelectObject] DC: 0x%x, Type: Font', [DC])); - Result := HFONT(CurrentFont); + Result := HFONT(GetFont);// always create: a valid GDIObject is needed to restore if CurrentFont<> PGDIObject(GDIObj) then begin + //DebugLn(['TGtkWidgetSet.SelectObject DC=',dbghex(DC),' Font Old=',dbghex(PtrInt(CurrentFont)),' New=',dbghex(GDIObj)]); + //dumpstack; CurrentFont := PGDIObject(GDIObj); {$IfDef GTK1} gdk_gc_set_font(GetGC, PGdiObject(GDIObj)^.GDIFontObject); @@ -9511,77 +9513,72 @@ begin if Result and (Count>0) then with TDeviceContext(DC) do begin + UseFont:=GetGtkFont(TDeviceContext(DC)); if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin - UseFont := GetDefaultGtkFont(false); Underline := False; StrikeOut := False; end else begin - UseFont := CurrentFont^.GDIFontObject; Underline := LongBool(CurrentFont^.LogFont.lfUnderline); StrikeOut := LongBool(CurrentFont^.LogFont.lfStrikeOut); end; - If UseFont = nil then - DebugLn('WARNING: [TGtkWidgetSet.TextOut] Missing Font') - else begin - DCOrigin:=GetDCOffset(TDeviceContext(DC)); - descent:=0; - gdk_text_extents(UseFont, Str, Count, - @lbearing, @rBearing, @width, @ascent, @descent); - sz.cx:=width; - Sz.cY :={$IFDEF Win32} - GDK_String_Height(UseFont, Str) - {$ELSE} - ascent+descent; - {$ENDIF} + DCOrigin:=GetDCOffset(TDeviceContext(DC)); + descent:=0; + gdk_text_extents(UseFont, Str, Count, + @lbearing, @rBearing, @width, @ascent, @descent); + sz.cx:=width; + Sz.cY :={$IFDEF Win32} + GDK_String_Height(UseFont, Str) + {$ELSE} + ascent+descent; + {$ENDIF} - - aRect := Rect(X+DCOrigin.X,Y+DCOrigin.Y,X + Sz.CX, Sz.CY); - //DebugLn('TGtkWidgetSet.TextOut ',ARect.Left,',',ARect.Top,',',ARect.RIght,',',ARect.Bottom); - FillRect(DC,aRect,hBrush(CurrentBrush)); - UpdateDCTextMetric(TDeviceContext(DC)); - TxtPt.X := X; - {$IfDef Win32} - TxtPt.Y := Y + DCTextMetric.TextMetric.tmHeight div 2; - {$Else} - TxtPt.Y := Y + DCTextMetric.TextMetric.tmAscent; - {$EndIf} - SelectGDKTextProps(DC); - {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} - gdk_draw_text(Drawable, UseFont, - GetGC, TxtPt.X+DCOrigin.X, TxtPt.Y+DCOrigin.Y, Str, Count); - {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} - If Underline or StrikeOut then begin - {Create & select pen of font color} - LogP.lopnStyle := PS_SOLID; - LogP.lopnWidth.X := 1; - LogP.lopnColor := GetTextColor(DC); - TempPen := SelectObject(DC, CreatePenIndirect(LogP)); + + aRect := Rect(X+DCOrigin.X,Y+DCOrigin.Y,X + Sz.CX, Sz.CY); + //DebugLn('TGtkWidgetSet.TextOut ',ARect.Left,',',ARect.Top,',',ARect.RIght,',',ARect.Bottom); + FillRect(DC,aRect,hBrush(CurrentBrush)); + UpdateDCTextMetric(TDeviceContext(DC)); + TxtPt.X := X; + {$IfDef Win32} + TxtPt.Y := Y + DCTextMetric.TextMetric.tmHeight div 2; + {$Else} + TxtPt.Y := Y + DCTextMetric.TextMetric.tmAscent; + {$EndIf} + SelectGDKTextProps(DC); + {$IFDEF DebugGDK}BeginGDKErrorTrap;{$ENDIF} + gdk_draw_text(Drawable, UseFont, + GetGC, TxtPt.X+DCOrigin.X, TxtPt.Y+DCOrigin.Y, Str, Count); + {$IFDEF DebugGDKTraps}EndGDKErrorTrap;{$ENDIF} + If Underline or StrikeOut then begin + {Create & select pen of font color} + LogP.lopnStyle := PS_SOLID; + LogP.lopnWidth.X := 1; + LogP.lopnColor := GetTextColor(DC); + TempPen := SelectObject(DC, CreatePenIndirect(LogP)); - {Get line(s) horizontal position(s)} - Points[0].cX := X; - Points[1].cX := X + sz.cX; + {Get line(s) horizontal position(s)} + Points[0].cX := X; + Points[1].cX := X + sz.cX; - {Draw line(s)} - If Underline then begin - Points[0].cY := Y + 2 + DCTextMetric.TextMetric.tmHeight - - DCTextMetric.TextMetric.tmDescent; - Points[1].cY := Points[0].cY; - Polyline(DC, PPoint(@Points[0]), 2); - end; - - If StrikeOut then begin - Points[0].cY := Y + 2 + (TxtPt.Y - Y) div 2; - Points[1].cY := Points[0].cY; - Polyline(DC, PPoint(@Points[0]), 2); - end; - - DeleteObject(SelectObject(DC, TempPen)); + {Draw line(s)} + If Underline then begin + Points[0].cY := Y + 2 + DCTextMetric.TextMetric.tmHeight - + DCTextMetric.TextMetric.tmDescent; + Points[1].cY := Points[0].cY; + Polyline(DC, PPoint(@Points[0]), 2); end; - Result := True; + + If StrikeOut then begin + Points[0].cY := Y + 2 + (TxtPt.Y - Y) div 2; + Points[1].cY := Points[0].cY; + Polyline(DC, PPoint(@Points[0]), 2); + end; + + DeleteObject(SelectObject(DC, TempPen)); end; + Result := True; end; end; {$EndIf} diff --git a/lcl/interfaces/gtk2/gtk2winapi.inc b/lcl/interfaces/gtk2/gtk2winapi.inc index 134c4232ec..a2e09cad64 100644 --- a/lcl/interfaces/gtk2/gtk2winapi.inc +++ b/lcl/interfaces/gtk2/gtk2winapi.inc @@ -367,18 +367,7 @@ begin exit; end; - UseFont:=nil; - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin - UseFont := GetDefaultGtkFont(false); - end else begin - UseFont := CurrentFont^.GDIFontObject; - end; - - if (UseFont = nil) then begin - DebugLn('WARNING: [TGtk2WidgetSet.ExtTextOut] Missing Font'); - Result:=false; - exit; - end; + UseFont:=GetGtkFont(TDeviceContext(DC)); // to reduce flickering calculate first and then paint @@ -471,19 +460,7 @@ begin if Result and (Count>0) then with TDeviceContext(DC) do begin - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) - then begin - UseFont := GetDefaultGtkFont(false); - end - else begin - UseFont := CurrentFont^.GDIFontObject; - end; - - if UseFont = nil then begin - DebugLn('WARNING: [TGtk2WidgetSet.GetTextExtentPoint] Missing Font'); - Result:=false; - exit; - end; + UseFont:=GetGtkFont(TDeviceContext(DC)); UpdateDCTextMetric(TDeviceContext(DC)); @@ -516,18 +493,8 @@ begin if Result and (Count>0) then with TDeviceContext(DC) do begin - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) - then begin - UseFont := GetDefaultGtkFont(false); - end - else begin - UseFont := CurrentFont^.GDIFontObject; - end; + UseFont:=GetGtkFont(TDeviceContext(DC)); - If UseFont = nil then begin - DebugLn('WARNING: [TGtk2WidgetSet.TextOut] Missing Font'); - exit(false); - end; UpdateDCTextMetric(TDeviceContext(DC)); DCOrigin:=GetDCOffset(TDeviceContext(DC)); diff --git a/lcl/lclmessageglue.pas b/lcl/lclmessageglue.pas index f756dc41a6..b5d6b353e8 100644 --- a/lcl/lclmessageglue.pas +++ b/lcl/lclmessageglue.pas @@ -419,7 +419,6 @@ function LCLSendMouseWheelMsg(const Target: TControl; XPos, YPos, WheelDelta: SmallInt; ShiftState: TShiftState): PtrInt; var Mess: TLMMouseEvent; - Keys: PtrInt; begin FillChar(Mess, SizeOf(Mess), 0); diff --git a/lcl/lclrescache.pas b/lcl/lclrescache.pas index 94492fcdcc..0150172583 100644 --- a/lcl/lclrescache.pas +++ b/lcl/lclrescache.pas @@ -315,6 +315,7 @@ procedure TResourceCache.ItemUsed(Item: TResourceCacheItem); // called after creation or when Item is used again begin if not ItemIsUsed(Item) then begin + // remove from unused list Item.RemoveFromList(FFirstUnusedItem,FLastUnusedItem); dec(FUnUsedItemCount); end; diff --git a/packager/packagedefs.pas b/packager/packagedefs.pas index a9016fe92e..74ae11b663 100644 --- a/packager/packagedefs.pas +++ b/packager/packagedefs.pas @@ -3805,7 +3805,6 @@ begin da_Block); FMain.AddChild(FSrcDirectories); end; - DebugLn(['TLazPackageDefineTemplates.UpdateSrcDirIfDef BBB1 ',FSrcDirIfDef=nil,' ',LazPackage.IDAsString]); if FSrcDirIfDef=nil then begin FSrcDirIfDef:=TDefineTemplate.Create('Source Directory Additions', 'Additional defines for package source directories',