paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-31 07:41:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

gtk2 intf: fonts of device contexts are now created on demand

Browse Source 
git-svn-id: trunk@11121 -
This commit is contained in:
mattias 2007-05-10 08:44:03 +00:00
parent 65e4295973
commit 0f2b6b8e44
17 changed files with 434 additions and 402 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
components/synedit/syncompletion.pas
View File

@ -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}

2
components/synedit/synhighlightermulti.pas
View File

@ -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

18
lcl/graphics.pp
View File

@ -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;

11
lcl/include/buttonglyph.inc
View File

@ -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

31
lcl/include/canvas.inc
View File

@ -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;
{------------------------------------------------------------------------------

2
lcl/include/customlabel.inc
View File

@ -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);

10
lcl/include/font.inc
View File

@ -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;
{------------------------------------------------------------------------------

10
lcl/interfaces/gtk/gtkdef.pp
View File

@ -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}

7
lcl/interfaces/gtk/gtkfontcache.pas
View File

@ -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

4
lcl/interfaces/gtk/gtkint.pp
View File

@ -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;

450
lcl/interfaces/gtk/gtkobject.inc
View File

@ -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 Width<AvgTxtLen then UseWidthHeuristic;
//TextMetric.tmAscent := TextMetric.tmHeight - TextMetric.tmDescent;
if IsDoubleByteChar then
TextMetric.tmAveCharWidth:=Width div (AvgTxtLen div 2)
else
TextMetric.tmAveCharWidth:=Width div AvgTxtLen;
if TextMetric.tmAveCharWidth<1 then TextMetric.tmAveCharWidth:=1;
TextMetric.tmMaxCharWidth :=
Max(gdk_char_width(UseFont, 'W'),
gdk_char_width(UseFont, 'M')); // temp hack
if TextMetric.tmMaxCharWidth<TextMetric.tmAveCharWidth then
TextMetric.tmMaxCharWidth:=TextMetric.tmAveCharWidth;
{$ELSE Gtk2}
// get pango context (= association to a widget)
AWidget:=DCWidget;
if AWidget=nil then
AWidget:=GetStyleWidget(lgsLabel);
APangoContext := gtk_widget_get_pango_context(AWidget);
if APangoContext=nil then
DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango context']);
// get pango language (e.g. de_DE)
APangoLanguage := pango_context_get_language(APangoContext);
if APangoLanguage=nil then
DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango language']);
// get pango font description (e.g. 'sans 12')
if CachedFont<>nil 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 Width<AvgTxtLen then UseWidthHeuristic;
//TextMetric.tmAscent := TextMetric.tmHeight - TextMetric.tmDescent;
if IsDoubleByteChar then
TextMetric.tmAveCharWidth:=Width div (AvgTxtLen div 2)
else
TextMetric.tmAveCharWidth:=Width div AvgTxtLen;
if TextMetric.tmAveCharWidth<1 then TextMetric.tmAveCharWidth:=1;
TextMetric.tmMaxCharWidth :=
Max(gdk_char_width(UseFont, 'W'),
gdk_char_width(UseFont, 'M')); // temp hack
if TextMetric.tmMaxCharWidth<TextMetric.tmAveCharWidth then
TextMetric.tmMaxCharWidth:=TextMetric.tmAveCharWidth;
{$ELSE Gtk2}
// get pango context (= association to a widget)
AWidget:=DCWidget;
if AWidget=nil then
AWidget:=GetStyleWidget(lgsLabel);
APangoContext := gtk_widget_get_pango_context(AWidget);
if APangoContext=nil then
DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango context']);
// get pango language (e.g. de_DE)
APangoLanguage := pango_context_get_language(APangoContext);
if APangoLanguage=nil then
DebugLn(['TGtkWidgetSet.UpdateDCTextMetric WARNING: no pango language']);
// get pango font description (e.g. 'sans 12')
if CachedFont<>nil 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

21
lcl/interfaces/gtk/gtkproc.inc
View File

@ -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;

207
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -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<NewCount then begin
ReAllocMem(FExtUTF8OutCache,NewCount);
FExtUTF8OutCacheSize:=NewCount;
end;
NewCount:=UTF8ToDoubleByte(Str,Count,FExtUTF8OutCache)*2;
gdk_text_extents(UseFont, FExtUTF8OutCache, NewCount,
@lbearing, @rBearing, @width, @ascent, @descent);
end else begin
gdk_text_extents(UseFont, Str, Count,
@lbearing, @rBearing, @width, @ascent, @descent);
UseFont:=GetGtkFont(TDeviceContext(DC));
descent:=0;
UpdateDCTextMetric(TDeviceContext(DC));
IsDBCSFont:=TDeviceContext(DC).DCTextMetric.IsDoubleByteChar;
if IsDBCSFont then begin
NewCount:=Count*2;
if FExtUTF8OutCacheSize<NewCount then begin
ReAllocMem(FExtUTF8OutCache,NewCount);
FExtUTF8OutCacheSize:=NewCount;
end;
Size.cX := Width;
// I THINK this is accurate...
Size.cY :={$IFDEF Win32}
GDK_String_Height(UseFont, Str)
{$ELSE}
ascent+descent;
{$ENDIF}
//debugln('TGtkWidgetSet.GetTextExtentPoint END Str="'+DbgStr(Str)+'" Size=',dbgs(Size.cX),'x',dbgs(Size.cY),' ascent=',dbgs(ascent),' descent=',dbgs(descent),' tmDescent=',dbgs(TDeviceContext(DC).DCTextMetric.TextMetric.tmDescent));
NewCount:=UTF8ToDoubleByte(Str,Count,FExtUTF8OutCache)*2;
gdk_text_extents(UseFont, FExtUTF8OutCache, NewCount,
@lbearing, @rBearing, @width, @ascent, @descent);
end else begin
gdk_text_extents(UseFont, Str, Count,
@lbearing, @rBearing, @width, @ascent, @descent);
end;
Size.cX := Width;
// I THINK this is accurate...
Size.cY :={$IFDEF Win32}
GDK_String_Height(UseFont, Str)
{$ELSE}
ascent+descent;
{$ENDIF}
//debugln('TGtkWidgetSet.GetTextExtentPoint END Str="'+DbgStr(Str)+'" Size=',dbgs(Size.cX),'x',dbgs(Size.cY),' ascent=',dbgs(ascent),' descent=',dbgs(descent),' tmDescent=',dbgs(TDeviceContext(DC).DCTextMetric.TextMetric.tmDescent));
end;
Assert(False, 'trace:< [TGtkWidgetSet.GetTextExtentPoint]');
@ -7564,16 +7561,16 @@ function TGtkWidgetSet.ReleaseDC(hWnd: HWND; DC: HDC): Integer;
var
aDC, pSavedDC: TDeviceContext;
begin
//DebugLn('[TGtkWidgetSet.ReleaseDC] ',DbgS(DC,8),' ',FDeviceContexts.Count);
//DebugLn('[TGtkWidgetSet.ReleaseDC] ',DbgS(DC),' ',FDeviceContexts.Count);
Assert(False, Format('trace:> [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}

39
lcl/interfaces/gtk2/gtk2winapi.inc
View File

@ -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));

1
lcl/lclmessageglue.pas
View File

@ -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);

1
lcl/lclrescache.pas
View File

@ -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;

1
packager/packagedefs.pas
View File

@ -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',