paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-06-06 09:18:45 +02:00
Code Issues Packages Projects Releases Wiki Activity

implemented font cache for gtk, which accelerates switching fonts

Browse Source 
git-svn-id: trunk@5763 -
This commit is contained in:
mattias 2004-08-10 17:34:13 +00:00
parent fe6fe05521
commit 1f41624a5f
7 changed files with 586 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

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

6
lcl/include/font.inc
View File

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

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

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

365
lcl/interfaces/gtk/gtkfontcache.pas Normal file
View File

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

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

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

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

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

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

@ -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 (LineStart<StrEnd) and (LineStart^=#13) then
inc(LineStart); // skip #10
Count:=StrEnd-LineStart;
LineLen:=FindChar(#10,LineStart,Count);
if LineLen<0 then
LineLen:=Count;
end;
end;
If UnRef then begin
{$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);
FontCache.UnRef(UseFont);
{$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 (LineStart<StrEnd) and (LineStart^=#13) then
inc(LineStart); // skip #10
Count:=StrEnd-LineStart;
LineLen:=FindChar(#10,LineStart,Count);
if LineLen<0 then
LineLen:=Count;
end;
end;
If UnRef then begin
{$IFDEF DebugGDKTraps}
BeginGDKErrorTrap;
{$ENDIF}
GDK_Font_UnRef(UseFont);
{$IFDEF DebugGDKTraps}
EndGDKErrorTrap;
{$ENDIF}
end;
end;
end;
end;
Assert(False, Format('trace:< [TGtkWidgetSet.ExtTextOut] DC:0x%x, X:%d, Y:%d, Options:%d, Str:''%s'', Count: %d', [DC, X, Y, Options, Str, Count]));
@ -5384,7 +5380,7 @@ begin
Size.cY := GDK_String_Height(UseFont, Str)
{$IfNDef Win32} + descent div 2{$EndIf};
If UnRef then
GDK_Font_UnRef(UseFont);
FontCache.UnRef(UseFont);
end;
end;
Assert(False, 'trace:< [TGtkWidgetSet.GetTextExtentPoint]');
@ -8506,7 +8502,7 @@ begin
end;
Result := True;
If UnRef then
GDK_Font_UnRef(UseFont);
FontCache.UnRef(UseFont);
end;
end;
end;
@ -8709,6 +8705,9 @@ end;
{ =============================================================================
$Log$
Revision 1.358 2004/08/10 17:34:13 mattias
implemented font cache for gtk, which accelerates switching fonts
Revision 1.357 2004/07/01 10:23:27 mattias
fixed uninitialsed vars from Jeroen