From 1f41624a5fee00f87c048aeb160de95f57fb91c6 Mon Sep 17 00:00:00 2001 From: mattias Date: Tue, 10 Aug 2004 17:34:13 +0000 Subject: [PATCH] implemented font cache for gtk, which accelerates switching fonts git-svn-id: trunk@5763 - --- .gitattributes | 1 + lcl/include/font.inc | 6 +- lcl/interfaces/gtk/gtkdef.pp | 5 +- lcl/interfaces/gtk/gtkfontcache.pas | 365 ++++++++++++++++++++++++++++ lcl/interfaces/gtk/gtkint.pp | 5 +- lcl/interfaces/gtk/gtkobject.inc | 42 +++- lcl/interfaces/gtk/gtkwinapi.inc | 355 ++++++++++++++------------- 7 files changed, 586 insertions(+), 193 deletions(-) create mode 100644 lcl/interfaces/gtk/gtkfontcache.pas diff --git a/.gitattributes b/.gitattributes index d787a8ea09..f6fc16b8d3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1205,6 +1205,7 @@ lcl/interfaces/gtk/gtkcallback.inc svneol=native#text/pascal lcl/interfaces/gtk/gtkcomboboxcallback.inc svneol=native#text/pascal lcl/interfaces/gtk/gtkdef.pp svneol=native#text/pascal lcl/interfaces/gtk/gtkdragcallback.inc svneol=native#text/pascal +lcl/interfaces/gtk/gtkfontcache.pas svneol=native#text/pascal lcl/interfaces/gtk/gtkglobals.pp svneol=native#text/pascal lcl/interfaces/gtk/gtkimages.lrs svneol=native#text/pascal lcl/interfaces/gtk/gtkint.pp svneol=native#text/pascal diff --git a/lcl/include/font.inc b/lcl/include/font.inc index 1d35f24f3c..16ca18755e 100644 --- a/lcl/include/font.inc +++ b/lcl/include/font.inc @@ -712,6 +712,7 @@ var begin if FFontData.Handle = 0 then with ALogFont do begin + FillChar(ALogFont,SizeOf(ALogFont),0); lfHeight := Height; lfWidth := 0; lfEscapement := 0; @@ -734,6 +735,7 @@ begin end; // ask the interface for the nearest font + // TODO: cache the result for other fonts FFontData.Handle := CreateFontIndirectEx(ALogFont,Name); end; @@ -751,7 +753,6 @@ procedure TFont.FreeHandle; begin if FFontData.Handle <> 0 then begin - //TODO: what if a font is currently selected DeleteObject(FFontData.Handle); FFontData.Handle := 0; end; @@ -833,6 +834,9 @@ end; { ============================================================================= $Log$ + Revision 1.14 2004/08/10 17:34:13 mattias + implemented font cache for gtk, which accelerates switching fonts + Revision 1.13 2004/04/10 17:58:57 mattias implemented mainunit hints for include files diff --git a/lcl/interfaces/gtk/gtkdef.pp b/lcl/interfaces/gtk/gtkdef.pp index 8565c80919..ff4ef83277 100644 --- a/lcl/interfaces/gtk/gtkdef.pp +++ b/lcl/interfaces/gtk/gtkdef.pp @@ -143,7 +143,7 @@ type end; TDevContextTextMetric = record - lbearing: LongInt; + lBearing: LongInt; rBearing: LongInt; TextMetric: TTextMetric; IsDoubleByteChar: boolean; @@ -575,6 +575,9 @@ end. { ============================================================================= $Log$ + Revision 1.62 2004/08/10 17:34:13 mattias + implemented font cache for gtk, which accelerates switching fonts + Revision 1.61 2004/05/16 23:24:41 marc + Added WSBitBtn interface + Implemented WSBitBtn interface for gtk diff --git a/lcl/interfaces/gtk/gtkfontcache.pas b/lcl/interfaces/gtk/gtkfontcache.pas new file mode 100644 index 0000000000..cf509f70fb --- /dev/null +++ b/lcl/interfaces/gtk/gtkfontcache.pas @@ -0,0 +1,365 @@ +{ + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.LCL, 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. * + * * + ***************************************************************************** +} +unit GtkFontCache; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LCLProc, LCLType, AvgLvlTree, gdk, gtkdef; + +type + TGdkFontCache = class; + + { TGdkFontCacheItem } + + TGdkFontCacheItem = class + private + FReferenceCount: integer; + FCache: TGdkFontCache; + public + GdkFont: PGDKFont; + + // font identification + ID: integer; + LogFont: TLogFont; + LongFontName: string; + xlfd: string; + + // metrics + MetricsValid: boolean; + lBearing: LongInt; + rBearing: LongInt; + TextMetric: TTextMetric; + IsDoubleByteChar: boolean; + + constructor Create(TheCache: TGdkFontCache; TheID: integer; + TheGdkFont: PGDKFont); + destructor Destroy; override; + procedure IncreaseRefCount; + procedure DecreaseRefCount; + end; + + { TGdkFontCache } + + TGdkFontCache = class + private + FCacheSize: integer; + FItemsSortedForGdkFont: TAvgLvlTree; + FItemsSortedForLogFont: TAvgLvlTree; + FIDCount: integer; + fDestroying: boolean; + public + constructor Create; + destructor Destroy; override; + function FindGDKFont(TheGdkFont: PGDKFont): TGdkFontCacheItem; + function FindGDKFont(const LogFont: TLogFont; + const LongFontName: string): TGdkFontCacheItem; + procedure Remove(Item: TGdkFontCacheItem); + procedure Add(Item: TGdkFontCacheItem); + procedure Add(TheGdkFont: PGDKFont); + procedure Add(TheGdkFont: PGDKFont; const LogFont: TLogFont; + const LongFontName: string); + function CreateNewItem(TheGdkFont: PGDKFont): TGdkFontCacheItem; + procedure Ref(TheGdkFont: PGDKFont); + procedure UnRef(TheGdkFont: PGDKFont); + procedure UnrefUnusedOldest; + property CacheSize: integer read FCacheSize write FCacheSize; + end; + +var + FontCache: TGdkFontCache; + +implementation + +type + TLogFontAndName = record + LogFont: TLogFont; + LongFontName: string; + end; + PLogFontAndName = ^TLogFontAndName; + +function CompareGdkFonts(Item1, Item2: TGdkFontCacheItem): integer; +begin + Result:=ComparePointers(Item1.GdkFont,Item2.GdkFont); +end; + +function CompareLogFonts(Item1, Item2: TGdkFontCacheItem): integer; +begin + Result:=CompareStr(Item1.LongFontName,Item2.LongFontName); + if Result<>0 then exit; + Result:=CompareMemRange(@Item1.LogFont,@Item2.LogFont,SizeOf(Item1.LogFont)); + if Result<>0 then exit; + if Item1.ID<0 then Result:=-1 + else if Item1.ID>0 then Result:=1; +end; + +function CompareGdkFontWithItem(Font: PGDKFont; + Item: TGdkFontCacheItem): integer; +begin + Result:=ComparePointers(Font,Item.GdkFont); +end; + +function CompareLogFontAndNameWithItem(Key: PLogFontAndName; + Item: TGdkFontCacheItem): integer; +begin + Result:=CompareStr(Key^.LongFontName,Item.LongFontName); + if Result=0 then + Result:=CompareMemRange(@Key^.LogFont,@Item.LogFont,SizeOf(Item.LogFont)); + //writeln('CompareLogFontAndNameWithItem Result=',Result,' Key=',Key^.LogFont.lfWeight,'/',Key^.LongFontName, + //' Item=',Item.LogFont.lfWeight,'/',Item.LongFontName); +end; + + +{ TGdkFontCacheItem } + +constructor TGdkFontCacheItem.Create(TheCache: TGdkFontCache; + TheID: integer; TheGdkFont: PGDKFont); +begin + FCache:=TheCache; + ID:=TheID; + GdkFont:=TheGdkFont; + gdk_font_ref(GdkFont); + FReferenceCount:=2; // one for adding and one for caching +end; + +destructor TGdkFontCacheItem.Destroy; +begin + gdk_font_unref(GdkFont); + if FCache<>nil then + FCache.Remove(Self); + inherited Destroy; +end; + +procedure TGdkFontCacheItem.IncreaseRefCount; + + procedure WarnRef; + begin + debugln('warning: TGdkFontCacheItem.IncreaseRefCount ' + +'It seems a font is not unreferenced. ' + +'FontName=',LongFontName,' ',LogFont.lfFaceName, + +' RefCnt=',dbgs(FReferenceCount)); + //RaiseGDBException('TGdkFontCacheItem.IncreaseRefCount'); + end; + +begin + inc(FReferenceCount); + if (FReferenceCount=100) or (FReferenceCount=1000) then + WarnRef; +end; + +procedure TGdkFontCacheItem.DecreaseRefCount; +begin + if FReferenceCount=0 then + RaiseGDBException('TGdkFontCacheItem.DecreaseRefCount'); + dec(FReferenceCount); + if FReferenceCount=0 then + Free; +end; + +{ TGdkFontCache } + +constructor TGdkFontCache.Create; +begin + FCacheSize:=30; + FItemsSortedForGdkFont:=TAvgLvlTree.Create(@CompareGdkFonts); + FItemsSortedForLogFont:=TAvgLvlTree.Create(@CompareLogFonts); +end; + +destructor TGdkFontCache.Destroy; +begin + fDestroying:=true; + // free all items + FItemsSortedForGdkFont.FreeAndClear; + // free trees + FItemsSortedForGdkFont.Free; + FItemsSortedForLogFont.Free; + inherited Destroy; +end; + +function TGdkFontCache.FindGDKFont(TheGdkFont: PGDKFont): TGdkFontCacheItem; +var + ANode: TAvgLvlTreeNode; +begin + ANode:=FItemsSortedForGdkFont.FindKey(TheGdkFont,@CompareGdkFontWithItem); + if ANode<>nil then + Result:=TGdkFontCacheItem(ANode.Data) + else + Result:=nil; +end; + +function TGdkFontCache.FindGDKFont(const LogFont: TLogFont; + const LongFontName: string): TGdkFontCacheItem; +var + Key: TLogFontAndName; + ANode: TAvgLvlTreeNode; +begin + Key.LogFont:=LogFont; + Key.LongFontName:=LongFontName; + ANode:=FItemsSortedForLogFont.FindKey(@Key,@CompareLogFontAndNameWithItem); + if ANode<>nil then + Result:=TGdkFontCacheItem(ANode.Data) + else + Result:=nil; +end; + +procedure TGdkFontCache.Remove(Item: TGdkFontCacheItem); +begin + {$IFDEF VerboseFontCache} + debugln('TGdkFontCache.Remove ',HexStr(Cardinal(Item.GdkFont),8),' LongFontName=',Item.LongFontName,' lfFaceName=',Item.LogFont.lfFaceName); + {$ENDIF} + if not fDestroying then begin + FItemsSortedForGdkFont.Remove(Item); + FItemsSortedForLogFont.Remove(Item); + end; +end; + +procedure TGdkFontCache.Add(Item: TGdkFontCacheItem); +var + OldItem: TGdkFontCacheItem; + //ANode: TAvgLvlTreeNode; +begin + {$IFDEF VerboseFontCache} + debugln('TGdkFontCache.Add ',HexStr(Cardinal(Item.GdkFont),8), + ' LongFontName=',Item.LongFontName,' lfFaceName=',Item.LogFont.lfFaceName); + {$ENDIF} + OldItem:=FindGDKFont(Item.GdkFont); + if OldItem<>nil then begin + debugln('TGdkFontCache.Add New=',Item.LongFontName,'/',Item.LogFont.lfFaceName); + debugln('TGdkFontCache.Add Old=',OldItem.LongFontName,'/',OldItem.LogFont.lfFaceName); + RaiseGDBException('TGdkFontCache.Add'); + end; + FItemsSortedForGdkFont.Add(Item); + FItemsSortedForLogFont.Add(Item); + + {ANode:=FItemsSortedForGdkFont.FindLowest; + while ANode<>nil do begin + Item:=TGdkFontCacheItem(ANode.Data); + writeln('TGdkFontCache.Add DumpA ',Item.LongFontName,' ',Item.LogFont.lfWeight); + ANode:=FItemsSortedForGdkFont.FindSuccessor(ANode); + end; + ANode:=FItemsSortedForLogFont.FindLowest; + while ANode<>nil do begin + Item:=TGdkFontCacheItem(ANode.Data); + writeln('TGdkFontCache.Add DumpB ',Item.LongFontName,' ',Item.LogFont.lfWeight); + ANode:=FItemsSortedForLogFont.FindSuccessor(ANode); + end;} +end; + +procedure TGdkFontCache.Add(TheGdkFont: PGDKFont); +var + NewItem: TGdkFontCacheItem; +begin + //debugln('TGdkFontCache.Add ',HexStr(Cardinal(TheGdkFont),8)); + NewItem:=CreateNewItem(TheGdkFont); + Add(NewItem); +end; + +procedure TGdkFontCache.Add(TheGdkFont: PGDKFont; const LogFont: TLogFont; + const LongFontName: string); +var + NewItem: TGdkFontCacheItem; + i: Integer; +begin + if FindGDKFont(LogFont,LongFontName)<>nil then + RaiseGDBException('TGdkFontCache.Add Already exists'); + NewItem:=CreateNewItem(TheGdkFont); + NewItem.LogFont:=LogFont; + NewItem.LongFontName:=LongFontName; + {debugln('TGdkFontCache.Add ',HexStr(Cardinal(TheGdkFont),8), + ' LongFontName=',LongFontName,' lfFaceName=',LogFont.lfFaceName, + ' '+dbgs(LogFont.lfCharSet) + +' '+dbgs(LogFont.lfClipPrecision) + +' '+dbgs(LogFont.lfEscapement) + +' '+dbgs(LogFont.lfHeight) + +' '+dbgs(LogFont.lfItalic) + +' '+dbgs(LogFont.lfOrientation) + +' '+dbgs(LogFont.lfOutPrecision) + +' '+dbgs(LogFont.lfPitchAndFamily) + +' '+dbgs(LogFont.lfQuality) + +' '+dbgs(LogFont.lfStrikeOut) + +' '+dbgs(LogFont.lfUnderline) + +' '+dbgs(LogFont.lfWeight) + +' '+dbgs(LogFont.lfWidth)); + for i:=0 to SizeOf(LogFont)-1 do + write(hexstr(ord(PChar(@LogFont)[i]),2)); + writeln('');} + Add(NewItem); + if FindGDKFont(LogFont,LongFontName)=nil then + RaiseGDBException('TGdkFontCache.Add added where?'); +end; + +function TGdkFontCache.CreateNewItem(TheGdkFont: PGDKFont): TGdkFontCacheItem; +begin + if FIDCount=High(integer) then + FIDCount:=Low(integer); + inc(FIDCount); + Result:=TGdkFontCacheItem.Create(Self,FIDCount,TheGdkFont); +end; + +procedure TGdkFontCache.Ref(TheGdkFont: PGDKFont); +var + Item: TGdkFontCacheItem; +begin + Item:=FindGDKFont(TheGdkFont); + if Item<>nil then + Item.IncreaseRefCount + else + gdk_font_ref(TheGdkFont); +end; + +procedure TGdkFontCache.UnRef(TheGdkFont: PGDKFont); +var + Item: TGdkFontCacheItem; +begin + Item:=FindGDKFont(TheGdkFont); + if Item<>nil then + Item.DecreaseRefCount + else + gdk_font_unref(TheGdkFont); + if FItemsSortedForLogFont.Count>FCacheSize then + UnrefUnusedOldest; +end; + +procedure TGdkFontCache.UnrefUnusedOldest; +var + ANode: TAvgLvlTreeNode; + Item, UnusedItem: TGdkFontCacheItem; +begin + ANode:=FItemsSortedForGdkFont.FindLowest; + UnusedItem:=nil; + while ANode<>nil do begin + Item:=TGdkFontCacheItem(ANode.Data); + if (Item.FReferenceCount=1) then begin + // this item is unused + if (UnusedItem=nil) or (UnusedItem.ID>Item.ID) then + UnusedItem:=Item; + end; + ANode:=FItemsSortedForGdkFont.FindSuccessor(ANode); + end; + if UnusedItem<>nil then + UnusedItem.DecreaseRefCount; +end; + +initialization + FontCache:=TGdkFontCache.Create; + +finalization + FontCache.Free; + FontCache:=nil; + +end. + diff --git a/lcl/interfaces/gtk/gtkint.pp b/lcl/interfaces/gtk/gtkint.pp index c8f0519e26..c9755d948c 100644 --- a/lcl/interfaces/gtk/gtkint.pp +++ b/lcl/interfaces/gtk/gtkint.pp @@ -65,7 +65,7 @@ uses {$IFDEF gtk2} glib2, gdk2pixbuf, gdk2, gtk2, Pango, {$ELSE} - glib, gdk, gtk, {$Ifndef NoGdkPixbufLib}gdkpixbuf,{$EndIf} + glib, gdk, gtk, {$Ifndef NoGdkPixbufLib}gdkpixbuf,{$EndIf} GtkFontCache, {$ENDIF} // Target OS specific {$IFDEF UNIX} @@ -459,6 +459,9 @@ end. { ============================================================================= $Log$ + Revision 1.184 2004/08/10 17:34:13 mattias + implemented font cache for gtk, which accelerates switching fonts + Revision 1.183 2004/05/22 14:35:32 mattias fixed button return key diff --git a/lcl/interfaces/gtk/gtkobject.inc b/lcl/interfaces/gtk/gtkobject.inc index 3557bae03a..fb598d7aa3 100644 --- a/lcl/interfaces/gtk/gtkobject.inc +++ b/lcl/interfaces/gtk/gtkobject.inc @@ -8403,7 +8403,7 @@ begin then begin GdiObject:=NewGDIObject(gdiFont); GdiObject^.GDIFontObject := GCValues.Font; - gdk_font_ref(GCValues.Font); + FontCache.Ref(GdiObject^.GDIFontObject); end else GdiObject := CreateDefaultFont; {$EndIf} @@ -8624,25 +8624,32 @@ var UseFont : PGDKFont; UnRef : Boolean; AvgTxtLen: Integer; + CachedFont: TGdkFontCacheItem; begin with TDeviceContext(DC) do begin if dcfTextMetricsValid in DCFlags then begin // cache valid end else begin + UnRef := False; if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin - UseFont := GetDefaultFont(true); - UnRef := True; + UseFont := GetDefaultFont(false); end else begin UseFont := CurrentFont^.GDIFontObject; - UnRef := False; end; If UseFont = nil then DebugLn('WARNING: [TGtkWidgetSet.GetTextMetrics] Missing font') else begin FillChar(DCTextMetric, SizeOf(DCTextMetric), 0); - with DCTextMetric do begin + CachedFont:=FontCache.FindGDKFont(UseFont); + if (CachedFont<>nil) and (CachedFont.MetricsValid) then begin + DCTextMetric.lBearing:=CachedFont.lBearing; + DCTextMetric.rBearing:=CachedFont.rBearing; + DCTextMetric.IsDoubleByteChar:=CachedFont.IsDoubleByteChar; + DCTextMetric.TextMetric:=CachedFont.TextMetric; + end + else with DCTextMetric do begin IsDoubleByteChar:=FontIsDoubleByteCharsFont(UseFont); gdk_text_extents(UseFont, TestString, length(TestString), @lbearing, @rBearing, @dummy, @@ -8661,16 +8668,23 @@ begin XT.cX := XT.cX div AvgTxtLen; TextMetric.tmHeight := XT.cY; TextMetric.tmAscent := TextMetric.tmHeight - TextMetric.tmDescent; - TextMetric.tmAveCharWidth := XT.cX; + TextMetric.tmAveCharWidth := XT.cX; 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<1 then TextMetric.tmMaxCharWidth:=1; + if (CachedFont<>nil) then begin + CachedFont.lBearing:=DCTextMetric.lBearing; + CachedFont.rBearing:=DCTextMetric.rBearing; + CachedFont.IsDoubleByteChar:=DCTextMetric.IsDoubleByteChar; + CachedFont.TextMetric:=DCTextMetric.TextMetric; + CachedFont.MetricsValid:=true; + end; end; If UnRef then - GDK_Font_UnRef(UseFont); + FontCache.UnRef(UseFont); end; Include(DCFlags,dcfTextMetricsValid); end; @@ -8703,6 +8717,7 @@ begin if FDefaultFont = nil then raise EOutOfResources.Create(rsUnableToLoadDefaultFont); end; + gdk_font_ref(FDefaultFont); // mark as used end; Result:=FDefaultFont; if IncreaseReferenceCount then @@ -9084,11 +9099,11 @@ var procedure CleanUpFont; begin If UnRef then - {$IfDef GTK2} - pango_font_description_free(UseFontDesc); - {$Else} - GDK_Font_UnRef(UseFont); - {$EndIf} + {$IfDef GTK2} + pango_font_description_free(UseFontDesc); + {$Else} + FontCache.UnRef(UseFont); + {$EndIf} end; var @@ -9215,6 +9230,9 @@ end; { ============================================================================= $Log$ + Revision 1.521 2004/08/10 17:34:13 mattias + implemented font cache for gtk, which accelerates switching fonts + Revision 1.520 2004/08/09 21:12:43 mattias implemented FormStyle fsSplash for splash screens diff --git a/lcl/interfaces/gtk/gtkwinapi.inc b/lcl/interfaces/gtk/gtkwinapi.inc index 598f3bf0a6..68d48c8865 100644 --- a/lcl/interfaces/gtk/gtkwinapi.inc +++ b/lcl/interfaces/gtk/gtkwinapi.inc @@ -1308,8 +1308,9 @@ var PointSize, ResolutionX, ResolutionY, Spacing, AverageWidth, CharSetRegistry, CharSetCoding: string; n: Integer; + CachedFont: TGdkFontCacheItem; - procedure LoadFont; + function LoadFont: boolean; begin S := Format('%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s-%s', [FontNameRegistry, Foundry, FamilyName, WeightName, @@ -1319,6 +1320,12 @@ var ]); GdiObject^.GDIFontObject := gdk_font_load(PChar(s)); + Result:=GdiObject^.GDIFontObject<>nil; + + if Result then begin + FontCache.Add(GdiObject^.GDIFontObject,LogFont,LongFontName); + end; + {$IFDEF VerboseFonts} DebugLn(' Trying "',S,'" Success=',GdiObject^.GDIFontObject<>nil); {$ENDIF} @@ -1352,10 +1359,10 @@ var begin // For info about xlfd see: // http://wwwinfo.cern.ch/umtf/working-groups/X11/fonts/hp_xlfd.html - // Lets fill in all the xlfd parts. Assume we have scalable fonts + // Lets fill in all the xlfd parts. Assume we have scalable fonts. {$IFDEF VerboseFonts} - DebugLn('TGtkWidgetSet.CreateFontIndirectEx A Name=',LogFont.lfFaceName,' Height=',LogFont.lfHeight); + DebugLn('TGtkWidgetSet.CreateFontIndirectEx A Name=',LogFont.lfFaceName,' Height=',dbgs(LogFont.lfHeight),' LongName=',LongFontName); {$ENDIF} Result := 0; @@ -1363,6 +1370,13 @@ begin try GdiObject^.LogFont := LogFont; + + CachedFont:=FontCache.FindGDKFont(LogFont,LongFontName); + if CachedFont<>nil then begin + CachedFont.IncreaseRefCount; + GdiObject^.GDIFontObject := CachedFont.GdkFont; + exit; + end; // set default values FontNameRegistry := '*'; @@ -1531,96 +1545,65 @@ begin {$IFDEF VerboseFonts} write('CreateFontIndirect->'); {$ENDIF} - LoadFont; + if LoadFont then exit; - if GdiObject^.GDIFontObject = nil - then begin - if (WeightName='normal') then begin - WeightName:='medium'; - LoadFont; - end else if (WeightName='bold') then begin - WeightName:='black'; - LoadFont; - end; + if (WeightName='normal') then begin + WeightName:='medium'; + if LoadFont then exit; + end else if (WeightName='bold') then begin + WeightName:='black'; + if LoadFont then exit; end; - if GdiObject^.GDIFontObject = nil - then begin - if (WeightName='medium') then begin - WeightName:='regular'; - LoadFont; - end else if (WeightName='black') then begin - WeightName:='demi bold'; - LoadFont; - end; + if (WeightName='medium') then begin + WeightName:='regular'; + if LoadFont then exit; + end else if (WeightName='black') then begin + WeightName:='demi bold'; + if LoadFont then exit; end; - if GdiObject^.GDIFontObject = nil - then begin - // try instead of mono spaced, character cell spaced - if (Spacing='m') then begin - Spacing:='c'; - LoadFont; - end; + // try instead of mono spaced, character cell spaced + if (Spacing='m') then begin + Spacing:='c'; + if LoadFont then exit; end; - if GdiObject^.GDIFontObject = nil - then begin - // try instead of italic oblique - if (Slant='i') then begin - Slant := 'o'; - LoadFont; - end; + // try instead of italic oblique + if (Slant='i') then begin + Slant := 'o'; + if GdiObject^.GDIFontObject <> nil then exit; end; - if GdiObject^.GDIFontObject = nil - then begin - // try all weights - WeightName := '*'; - LoadFont; - end; + // try all weights + WeightName := '*'; + if GdiObject^.GDIFontObject <> nil then exit; - if GdiObject^.GDIFontObject = nil - then begin - // try all slants - Slant := '*'; - LoadFont; - end; + // try all slants + Slant := '*'; + if GdiObject^.GDIFontObject <> nil then exit; - if GdiObject^.GDIFontObject = nil - then begin - // try all spacings - Spacing := '*'; - LoadFont; - end; + // try all spacings + Spacing := '*'; + if GdiObject^.GDIFontObject <> nil then exit; - if GdiObject^.GDIFontObject = nil - then begin - // try one height lower - PixelSize := IntToStr(Abs(LogFont.lfHeight)-1); - LoadFont; - end; + // try one height lower + PixelSize := IntToStr(Abs(LogFont.lfHeight)-1); + if GdiObject^.GDIFontObject <> nil then exit; - if GdiObject^.GDIFontObject = nil - then begin - // try one height higher - PixelSize := IntToStr(Abs(LogFont.lfHeight)+1); - LoadFont; - end; + // try one height higher + PixelSize := IntToStr(Abs(LogFont.lfHeight)+1); + if GdiObject^.GDIFontObject <> nil then exit; - if (GdiObject^.GDIFontObject = nil) and (Foundry<>'*') - then begin - // try all Familys + if (Foundry<>'*') then begin + // try all Families PixelSize := IntToStr(Abs(LogFont.lfHeight)); FamilyName := '*'; - LoadFont; - end; - - if GdiObject^.GDIFontObject = nil - then begin - // nothing exists -> use default - LoadDefaultFont; + if GdiObject^.GDIFontObject <> nil then exit; end; + + // nothing exists -> use default + LoadDefaultFont; finally if GdiObject^.GDIFontObject = nil @@ -2133,32 +2116,41 @@ begin case GDIType of gdiFont: begin - if GDIFontObject<>nil then - {$Ifdef GTK2} - pango_font_description_free(GDIFontObject); - {$Else} - gdk_font_unref(GDIFontObject); - {$EndIf} + if GDIFontObject<>nil then begin + {$Ifdef GTK2} + pango_font_description_free(GDIFontObject); + {$Else} + FontCache.UnRef(GDIFontObject); + {$EndIf} + end; end; gdiBrush: begin + {$IFDEF DebugGDKTraps} BeginGDKErrorTrap; + {$ENDIF} if (GDIBrushPixmap <> nil) then gdk_bitmap_unref(GDIBrushPixmap); + {$IFDEF DebugGDKTraps} EndGDKErrorTrap; + {$ENDIF} FreeGDIColor(@GDIBrushColor); end; gdiBitmap: begin + {$IFDEF DebugGDKTraps} BeginGDKErrorTrap; + {$ENDIF} if GDIBitmapObject <> nil then gdk_bitmap_unref(GDIBitmapObject); If (Visual <> nil) and (not SystemVisual) then gdk_visual_unref(Visual); If Colormap <> nil then gdk_colormap_unref(Colormap); + {$IFDEF DebugGDKTraps} EndGDKErrorTrap; + {$ENDIF} end; gdiPen: begin @@ -2171,12 +2163,16 @@ begin end; gdiPalette: begin + {$IFDEF DebugGDKTraps} BeginGDKErrorTrap; + {$ENDIF} If PaletteVisual <> nil then gdk_visual_unref(PaletteVisual); If PaletteColormap <> nil then gdk_colormap_unref(PaletteColormap); + {$IFDEF DebugGDKTraps} EndGDKErrorTrap; + {$ENDIF} RGBTable.Free; IndexTable.Free; @@ -3175,115 +3171,115 @@ begin then begin DebugLn('WARNING: [TGtkWidgetSet.ExtTextOut] Uninitialized GC'); Result := False; - end - else if ((Options and (ETO_OPAQUE+ETO_CLIPPED)) <> 0) + exit; + end; + if ((Options and (ETO_OPAQUE+ETO_CLIPPED)) <> 0) and (Rect=nil) then begin DebugLn('WARNING: [TGtkWidgetSet.ExtTextOut] Rect=nil'); Result := False; - end else begin - // TODO: implement other parameters. + exit; + end; + // TODO: implement other parameters. - // to reduce flickering calculate first and then paint - DCOrigin:=GetDCOffset(TDeviceContext(DC)); - buffered := false; - UseFont:=nil; - buffer := Drawable; + // to reduce flickering calculate first and then paint + DCOrigin:=GetDCOffset(TDeviceContext(DC)); + buffered := false; + UseFont:=nil; + buffer := Drawable; + UnRef := false; + UnderLine := false; - if (Str<>nil) and (Count>0) then begin - if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin - UseFont := GetDefaultFont(false); - UnRef := false; - UnderLine := false; - end else begin - UseFont := CurrentFont^.GDIFontObject; - UnRef := False; - UnderLine := (CurrentFont^.LogFont.lfUnderline<>0); - end; - - if UseFont <> nil then begin - 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; - end else begin - DebugLn('WARNING: [TGtkWidgetSet.ExtTextOut] Missing Font'); - Result := False; - end; + if (Str<>nil) and (Count>0) then begin + if (CurrentFont = nil) or (CurrentFont^.GDIFontObject = nil) then begin + UseFont := GetDefaultFont(false); + end else begin + UseFont := CurrentFont^.GDIFontObject; + UnderLine := (CurrentFont^.LogFont.lfUnderline<>0); end; - if ((Options and ETO_OPAQUE) <> 0) then - begin - Width := Rect^.Right - Rect^.Left; - Height := Rect^.Bottom - Rect^.Top; - SelectedColors := dcscCustom; - EnsureGCColor(DC, dccCurrentBackColor, True, False); - if buffered then begin - Left:=0; - Top:=0; - end else begin - Left:=Rect^.Left+DCOrigin.X; - Top:=Rect^.Top+DCOrigin.Y; + if UseFont <> nil then begin + 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; + end else begin + DebugLn('WARNING: [TGtkWidgetSet.ExtTextOut] Missing Font'); + Result := False; + end; + end; + + if ((Options and ETO_OPAQUE) <> 0) then + begin + Width := Rect^.Right - Rect^.Left; + Height := Rect^.Bottom - Rect^.Top; + SelectedColors := dcscCustom; + EnsureGCColor(DC, dccCurrentBackColor, True, False); + if buffered then begin + Left:=0; + Top:=0; + end else begin + Left:=Rect^.Left+DCOrigin.X; + Top:=Rect^.Top+DCOrigin.Y; + end; + {$IFDEF DebugGDKTraps} + BeginGDKErrorTrap; + {$ENDIF} + if IsBackgroundColor(TColor(CurrentBackColor.ColorRef)) then + StyleFillRectangle(buffer, GC, CurrentBackColor.ColorRef, + Left, Top, Width, Height) + else + gdk_draw_rectangle(buffer, GC, 1, Left, Top, Width, Height); + {$IFDEF DebugGDKTraps} + EndGDKErrorTrap; + {$ENDIF} + end; + + if UseFont<>nil then begin + LineLen := FindChar(#10,Str,Count); + UpdateDCTextMetric(TDeviceContext(DC)); + LineHeight:=GetTextHeight(DCTextMetric); + if Buffered then begin + TxtPt.X := 0; + TxtPt.Y := LineHeight; + end + else begin + TopY := Y; + TxtPt.X := X + DCOrigin.X; + TxtPt.Y := TopY + LineHeight + DCOrigin.Y; + end; + SelectGDKTextProps(DC); + 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 (LineStartnil then begin - LineLen := FindChar(#10,Str,Count); - UpdateDCTextMetric(TDeviceContext(DC)); - LineHeight:=GetTextHeight(DCTextMetric); - if Buffered then begin - TxtPt.X := 0; - TxtPt.Y := LineHeight; - end - else begin - TopY := Y; - TxtPt.X := X + DCOrigin.X; - TxtPt.Y := TopY + LineHeight + DCOrigin.Y; - end; - SelectGDKTextProps(DC); - 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